1 files changed, 59 insertions, 42 deletions
diff --git a/src/Hakyll/Core/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs
index a1e36df..52b998b 100644
--- a/src/Hakyll/Core/Identifier/Pattern.hs
+++ b/src/Hakyll/Core/Identifier/Pattern.hs
@@ -1,4 +1,12 @@
 -- | Module providing pattern matching and capturing on 'Identifier's.
+-- 'Pattern's come in two kinds:
+--
+-- * Simple glob patterns, like @foo\/*@;
+--
+-- * Custom, arbitrary predicates of the type @Identifier -> Bool@.
+--
+-- They both have advantages and disadvantages. By default, globs are used,
+-- unless you construct your 'Pattern' using the 'predicate' function.
 --
 -- A very simple pattern could be, for example, @foo\/bar@. This pattern will
 -- only match the exact @foo\/bar@ identifier.
@@ -20,15 +28,15 @@
 --
 -- * @foo\/*.html@ will match all HTML files in the @foo\/@ directory.
 --
--- The 'match' function allows the user to get access to the elements captured
+-- The 'capture' function allows the user to get access to the elements captured
 -- by the capture elements in the pattern.
 --
 module Hakyll.Core.Identifier.Pattern
     ( Pattern
-    , parsePattern
-    , match
-    , doesMatch
+    , parseGlob
     , matches
+    , filterMatches
+    , capture
     , fromCapture
     , fromCaptureString
     , fromCaptures
@@ -46,23 +54,23 @@ import Hakyll.Core.Identifier
 
 -- | One base element of a pattern
 --
-data PatternComponent = Capture
-                      | CaptureMany
-                      | Literal String
-                      deriving (Eq, Show)
+data GlobComponent = Capture
+                   | CaptureMany
+                   | Literal String
+                   deriving (Eq, Show)
 
 -- | Type that allows matching on identifiers
 --
-newtype Pattern = Pattern {unPattern :: [PatternComponent]}
-                deriving (Eq, Show)
+data Pattern = Glob [GlobComponent]
+             | Predicate (Identifier -> Bool)
 
 instance IsString Pattern where
-    fromString = parsePattern
+    fromString = parseGlob
 
 -- | Parse a pattern from a string
 --
-parsePattern :: String -> Pattern
-parsePattern = Pattern . parse' -- undefined -- Pattern . map toPattern . unIdentifier . parseIdentifier
+parseGlob :: String -> Pattern
+parseGlob = Glob . parse'
   where
     parse' str =
         let (chunk, rest) = break (`elem` "\\*") str
@@ -72,20 +80,16 @@ parsePattern = Pattern . parse' -- undefined -- Pattern . map toPattern . unIden
             ('*'  : xs)       -> Literal chunk : Capture : parse' xs
             xs                -> Literal chunk : Literal xs : []
 
--- | Match an identifier against a pattern, generating a list of captures
---
-match :: Pattern -> Identifier -> Maybe [Identifier]
-match p (Identifier i) = fmap (map Identifier) $ match' (unPattern p) i
-
 -- | Check if an identifier matches a pattern
 --
-doesMatch :: Pattern -> Identifier -> Bool
-doesMatch p = isJust . match p
+matches :: Pattern -> Identifier -> Bool
+matches (Glob p)      = isJust . capture (Glob p)
+matches (Predicate p) = (p $)
 
 -- | Given a list of identifiers, retain only those who match the given pattern
 --
-matches :: Pattern -> [Identifier] -> [Identifier]
-matches p = filter (doesMatch p)
+filterMatches :: Pattern -> [Identifier] -> [Identifier]
+filterMatches = filter . matches
 
 -- | Split a list at every possible point, generate a list of (init, tail)
 -- cases. The result is sorted with inits decreasing in length.
@@ -93,30 +97,35 @@ matches p = filter (doesMatch p)
 splits :: [a] -> [([a], [a])]
 splits = inits &&& tails >>> uncurry zip >>> reverse
 
--- | Internal verion of 'match'
+-- | Match a glob against a pattern, generating a list of captures
 --
-match' :: [PatternComponent] -> String -> Maybe [String]
-match' [] [] = Just []  -- An empty match
-match' [] _  = Nothing  -- No match
--- match' _  [] = Nothing   -- No match
-match' (Literal l : ms) str
+capture :: Pattern -> Identifier -> Maybe [Identifier]
+capture (Glob p) (Identifier i) = fmap (map Identifier) $ capture' p i
+capture (Predicate _) _         = Nothing
+
+-- | Internal verion of 'capture'
+--
+capture' :: [GlobComponent] -> String -> Maybe [String]
+capture' [] [] = Just []  -- An empty match
+capture' [] _  = Nothing  -- No match
+capture' (Literal l : ms) str
     -- Match the literal against the string
-    | l `isPrefixOf` str = match' ms $ drop (length l) str
+    | l `isPrefixOf` str = capture' ms $ drop (length l) str
     | otherwise          = Nothing
-match' (Capture : ms) str =
+capture' (Capture : ms) str =
     -- Match until the next /
     let (chunk, rest) = break (== '/') str
-    in msum $ [ fmap (i :) (match' ms (t ++ rest)) | (i, t) <- splits chunk ]
-match' (CaptureMany : ms) str =
+    in msum $ [ fmap (i :) (capture' ms (t ++ rest)) | (i, t) <- splits chunk ]
+capture' (CaptureMany : ms) str =
     -- Match everything
-    msum $ [ fmap (i :) (match' ms t) | (i, t) <- splits str ]
+    msum $ [ fmap (i :) (capture' ms t) | (i, t) <- splits str ]
     
 -- | Create an identifier from a pattern by filling in the captures with a given
 -- string
 --
 -- Example:
 --
--- > fromCapture (parsePattern "tags/*") (parseIdentifier "foo")
+-- > fromCapture (parseGlob "tags/*") (parseIdentifier "foo")
 --
 -- Result:
 --
@@ -128,7 +137,7 @@ fromCapture pattern = fromCaptures pattern . repeat
 -- | Simplified version of 'fromCapture' which takes a 'String' instead of an
 -- 'Identifier'
 --
--- > fromCaptureString (parsePattern "tags/*") "foo"
+-- > fromCaptureString (parseGlob "tags/*") "foo"
 --
 -- Result:
 --
@@ -141,11 +150,19 @@ fromCaptureString pattern = fromCapture pattern . parseIdentifier
 -- given list of strings
 --
 fromCaptures :: Pattern -> [Identifier] -> Identifier
-fromCaptures (Pattern []) _ = mempty
-fromCaptures (Pattern (m : ms)) [] = case m of
-    Literal l -> Identifier l `mappend` fromCaptures (Pattern ms) []
-    _         -> error $  "Hakyll.Core.Identifier.Pattern.fromCaptures: "
+fromCaptures (Glob p)      = fromCaptures' p
+fromCaptures (Predicate _) = error $
+    "Hakyll.Core.Identifier.Pattern.fromCaptures: fromCaptures called on a " ++
+    "predicate instead of a glob"
+
+-- | Internally used version of 'fromCaptures'
+--
+fromCaptures' :: [GlobComponent] -> [Identifier] -> Identifier
+fromCaptures' []        _ = mempty
+fromCaptures' (m : ms) [] = case m of
+    Literal l -> Identifier l `mappend` fromCaptures' ms []
+    _         -> error $  "Hakyll.Core.Identifier.Pattern.fromCaptures': "
                        ++ "identifier list exhausted"
-fromCaptures (Pattern (m : ms)) ids@(i : is) = case m of
-    Literal l -> Identifier l `mappend` fromCaptures (Pattern ms) ids
-    _         -> i `mappend` fromCaptures (Pattern ms) is
+fromCaptures' (m : ms) ids@(i : is) = case m of
+    Literal l -> Identifier l `mappend` fromCaptures' ms ids
+    _         -> i `mappend` fromCaptures' ms is