diff options
| -rw-r--r-- | src/Hakyll/Core/Identifier/Pattern.hs | 101 |
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 |