Type-safe patterns

5 files changed, 37 insertions, 29 deletions

diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index 2164dda..6237d5a 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -258,7 +258,7 @@ requireA identifier = (id &&& require_ identifier >>>)
 -- | Variant of 'requireAll' which drops the current value
 --
 requireAll_ :: (Binary a, Typeable a, Writable a)
-            => Pattern
+            => Pattern a
             -> Compiler b [a]
 requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_'
   where
@@ -271,7 +271,7 @@ requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_'
 -- of dependencies
 --
 requireAll :: (Binary a, Typeable a, Writable a)
-           => Pattern
+           => Pattern a
            -> (b -> [a] -> c)
            -> Compiler b c
 requireAll pattern = requireAllA pattern . arr . uncurry
@@ -279,7 +279,7 @@ requireAll pattern = requireAllA pattern . arr . uncurry
 -- | Arrow-based variant of 'requireAll'
 --
 requireAllA :: (Binary a, Typeable a, Writable a)
-            => Pattern
+            => Pattern a
             -> Compiler (b, [a]) c
             -> Compiler b c
 requireAllA pattern = (id &&& requireAll_ pattern >>>)
diff --git a/src/Hakyll/Core/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs
index cee4bbc..a7a534e 100644
--- a/src/Hakyll/Core/Identifier/Pattern.hs
+++ b/src/Hakyll/Core/Identifier/Pattern.hs
@@ -33,6 +33,7 @@
 --
 module Hakyll.Core.Identifier.Pattern
     ( Pattern
+    , castPattern
     , parseGlob
     , predicate
     , regex
@@ -64,21 +65,27 @@ data GlobComponent = Capture
 
 -- | Type that allows matching on identifiers
 --
-data Pattern = Glob [GlobComponent]
-             | Predicate (Identifier -> Bool)
+data Pattern a = Glob [GlobComponent]
+               | Predicate (Identifier -> Bool)
+               | List [Identifier]
 
-instance IsString Pattern where
+instance IsString (Pattern a) where
     fromString = parseGlob
 
-instance Monoid Pattern where
+instance Monoid (Pattern a) where
     mempty = Predicate (const True)
-    g@(Glob _)  `mappend` x           = Predicate (matches g) `mappend` x
-    x           `mappend` g@(Glob _)  = x `mappend` Predicate (matches g)
-    Predicate f `mappend` Predicate g = Predicate $ \i -> f i && g i
+    p1 `mappend` p2 = Predicate $ \i -> matches p1 i && matches p2 i
+
+-- | Discard the phantom type parameter
+--
+castPattern :: Pattern a -> Pattern b
+castPattern (Glob g)      = Glob g
+castPattern (Predicate p) = Predicate p
+castPattern (List l)      = List l
 
 -- | Parse a pattern from a string
 --
-parseGlob :: String -> Pattern
+parseGlob :: String -> Pattern a
 parseGlob = Glob . parse'
   where
     parse' str =
@@ -95,7 +102,7 @@ parseGlob = Glob . parse'
 --
 -- > predicate (\i -> matches "foo/*" i && not (matches "foo/bar" i))
 --
-predicate :: (Identifier -> Bool) -> Pattern
+predicate :: (Identifier -> Bool) -> Pattern a
 predicate = Predicate
 
 -- | Create a 'Pattern' from a regex
@@ -104,24 +111,25 @@ predicate = Predicate
 --
 -- > regex "^foo/[^x]*$
 --
-regex :: String -> Pattern
+regex :: String -> Pattern a
 regex str = predicate $ fromMaybe False . (=~~ str) . toFilePath
 
 -- | Create a 'Pattern' which matches if the identifier is in a certain group
 -- (or in no group)
 --
-inGroup :: Maybe String -> Pattern
+inGroup :: Maybe String -> Pattern a
 inGroup group = predicate $ (== group) . identifierGroup
 
 -- | Check if an identifier matches a pattern
 --
-matches :: Pattern -> Identifier -> Bool
+matches :: Pattern a -> Identifier -> Bool
 matches (Glob p)      = isJust . capture (Glob p)
 matches (Predicate p) = (p $)
+matches (List l)      = (`elem` l)
 
 -- | Given a list of identifiers, retain only those who match the given pattern
 --
-filterMatches :: Pattern -> [Identifier] -> [Identifier]
+filterMatches :: Pattern a -> [Identifier] -> [Identifier]
 filterMatches = filter . matches
 
 -- | Split a list at every possible point, generate a list of (init, tail)
@@ -132,9 +140,9 @@ splits = inits &&& tails >>> uncurry zip >>> reverse
 
 -- | Match a glob against a pattern, generating a list of captures
 --
-capture :: Pattern -> Identifier -> Maybe [String]
+capture :: Pattern a -> Identifier -> Maybe [String]
 capture (Glob p) (Identifier _ i) = capture' p i
-capture (Predicate _) _           = Nothing
+capture _        _                = Nothing
 
 -- | Internal verion of 'capture'
 --
@@ -164,17 +172,17 @@ capture' (CaptureMany : ms) str =
 --
 -- > "tags/foo"
 --
-fromCapture :: Pattern -> String -> Identifier
+fromCapture :: Pattern a -> String -> Identifier
 fromCapture pattern = fromCaptures pattern . repeat
 
 -- | Create an identifier from a pattern by filling in the captures with the
 -- given list of strings
 --
-fromCaptures :: Pattern -> [String] -> Identifier
-fromCaptures (Glob p)      = Identifier Nothing . fromCaptures' p
-fromCaptures (Predicate _) = error $
-    "Hakyll.Core.Identifier.Pattern.fromCaptures: fromCaptures called on a " ++
-    "predicate instead of a glob"
+fromCaptures :: Pattern a -> [String] -> Identifier
+fromCaptures (Glob p) = Identifier Nothing . fromCaptures' p
+fromCaptures _        = error $
+    "Hakyll.Core.Identifier.Pattern.fromCaptures: fromCaptures only works " ++
+    "on simple globs!"
 
 -- | Internally used version of 'fromCaptures'
 --
diff --git a/src/Hakyll/Core/Routes.hs b/src/Hakyll/Core/Routes.hs
index abbd0a7..0b500b3 100644
--- a/src/Hakyll/Core/Routes.hs
+++ b/src/Hakyll/Core/Routes.hs
@@ -88,7 +88,7 @@ setExtension extension = Routes $ fmap (`replaceExtension` extension)
 -- | Apply the route if the identifier matches the given pattern, fail
 -- otherwise
 --
-matchRoute :: Pattern -> Routes -> Routes
+matchRoute :: Pattern a -> Routes -> Routes
 matchRoute pattern (Routes route) = Routes $ \id' ->
     if matches pattern id' then route id' else Nothing
 
diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs
index fe2c59c..a9e1375 100644
--- a/src/Hakyll/Core/Rules.hs
+++ b/src/Hakyll/Core/Rules.hs
@@ -78,11 +78,11 @@ tellResources resources' = RulesM $ tell $
 
 -- | Only compile/route items satisfying the given predicate
 --
-match :: Pattern -> Rules -> Rules
+match :: Pattern a -> RulesM b -> RulesM b
 match pattern = RulesM . local addPredicate . unRulesM
   where
     addPredicate env = env
-        { rulesPattern = rulesPattern env `mappend` pattern
+        { rulesPattern = rulesPattern env `mappend` castPattern pattern
         }
 
 -- | Greate a group of compilers
diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs
index 83783b5..fe16062 100644
--- a/src/Hakyll/Core/Rules/Internal.hs
+++ b/src/Hakyll/Core/Rules/Internal.hs
@@ -1,6 +1,6 @@
 -- | Internal rules module for types which are not exposed to the user
 --
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, Rank2Types #-}
 module Hakyll.Core.Rules.Internal
     ( CompileRule (..)
     , RuleSet (..)
@@ -63,7 +63,7 @@ data RuleState = RuleState
 --
 data RuleEnvironment = RuleEnvironment
     { rulesResourceProvider :: ResourceProvider
-    , rulesPattern          :: Pattern
+    , rulesPattern          :: forall a. Pattern a
     , rulesGroup            :: Maybe String
     }