module Hakyll.Core.Identifier.Pattern
( Pattern
, castPattern
, parseGlob
, predicate
, list
, regex
, inGroup
, matches
, filterMatches
, capture
, fromCapture
, fromCaptures
) where
import Data.List (isPrefixOf, inits, tails)
import Control.Arrow ((&&&), (>>>))
import Control.Monad (msum)
import Data.Maybe (isJust, fromMaybe)
import Data.Monoid (Monoid, mempty, mappend)
import GHC.Exts (IsString, fromString)
import Text.Regex.PCRE ((=~~))
import Hakyll.Core.Identifier
data GlobComponent = Capture
| CaptureMany
| Literal String
deriving (Eq, Show)
data Pattern a = Glob [GlobComponent]
| Predicate (Identifier a -> Bool)
| List [Identifier a]
instance IsString (Pattern a) where
fromString = parseGlob
instance Monoid (Pattern a) where
mempty = Predicate (const True)
p1 `mappend` p2 = Predicate $ \i -> matches p1 i && matches p2 i
castPattern :: Pattern a -> Pattern b
castPattern (Glob g) = Glob g
castPattern (Predicate p) = Predicate $ p . castIdentifier
castPattern (List l) = List $ map castIdentifier l
parseGlob :: String -> Pattern a
parseGlob = Glob . parse'
where
parse' str =
let (chunk, rest) = break (`elem` "\\*") str
in case rest of
('\\' : x : xs) -> Literal (chunk ++ [x]) : parse' xs
('*' : '*' : xs) -> Literal chunk : CaptureMany : parse' xs
('*' : xs) -> Literal chunk : Capture : parse' xs
xs -> Literal chunk : Literal xs : []
predicate :: (Identifier a -> Bool) -> Pattern a
predicate = Predicate
list :: [Identifier a] -> Pattern a
list = List
regex :: String -> Pattern a
regex str = predicate $ fromMaybe False . (=~~ str) . toFilePath
inGroup :: Maybe String -> Pattern a
inGroup group = predicate $ (== group) . identifierGroup
matches :: Pattern a -> Identifier a -> Bool
matches (Glob p) = isJust . capture (Glob p)
matches (Predicate p) = (p $)
matches (List l) = (`elem` l)
filterMatches :: Pattern a -> [Identifier a] -> [Identifier a]
filterMatches = filter . matches
splits :: [a] -> [([a], [a])]
splits = inits &&& tails >>> uncurry zip >>> reverse
capture :: Pattern a -> Identifier a -> Maybe [String]
capture (Glob p) (Identifier _ i) = capture' p i
capture _ _ = Nothing
capture' :: [GlobComponent] -> String -> Maybe [String]
capture' [] [] = Just []
capture' [] _ = Nothing
capture' (Literal l : ms) str
| l `isPrefixOf` str = capture' ms $ drop (length l) str
| otherwise = Nothing
capture' (Capture : ms) str =
let (chunk, rest) = break (== '/') str
in msum $ [ fmap (i :) (capture' ms (t ++ rest)) | (i, t) <- splits chunk ]
capture' (CaptureMany : ms) str =
msum $ [ fmap (i :) (capture' ms t) | (i, t) <- splits str ]
fromCapture :: Pattern a -> String -> Identifier a
fromCapture pattern = fromCaptures pattern . repeat
fromCaptures :: Pattern a -> [String] -> Identifier a
fromCaptures (Glob p) = Identifier Nothing . fromCaptures' p
fromCaptures _ = error $
"Hakyll.Core.Identifier.Pattern.fromCaptures: fromCaptures only works " ++
"on simple globs!"
fromCaptures' :: [GlobComponent] -> [String] -> String
fromCaptures' [] _ = mempty
fromCaptures' (m : ms) [] = case m of
Literal l -> l `mappend` fromCaptures' ms []
_ -> error $ "Hakyll.Core.Identifier.Pattern.fromCaptures': "
++ "identifier list exhausted"
fromCaptures' (m : ms) ids@(i : is) = case m of
Literal l -> l `mappend` fromCaptures' ms ids
_ -> i `mappend` fromCaptures' ms is