module Hakyll.Core.Identifier.Pattern
( Pattern
, parseGlob
, predicate
, 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 = Glob [GlobComponent]
| Predicate (Identifier -> Bool)
instance IsString Pattern where
fromString = parseGlob
instance Monoid Pattern 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
parseGlob :: String -> Pattern
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 -> Bool) -> Pattern
predicate = Predicate
regex :: String -> Pattern
regex str = predicate $ fromMaybe False . (=~~ str) . toFilePath
inGroup :: Maybe String -> Pattern
inGroup group = predicate $ (== group) . identifierGroup
matches :: Pattern -> Identifier -> Bool
matches (Glob p) = isJust . capture (Glob p)
matches (Predicate p) = (p $)
filterMatches :: Pattern -> [Identifier] -> [Identifier]
filterMatches = filter . matches
splits :: [a] -> [([a], [a])]
splits = inits &&& tails >>> uncurry zip >>> reverse
capture :: Pattern -> Identifier -> Maybe [String]
capture (Glob p) (Identifier _ i) = capture' p i
capture (Predicate _) _ = 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 -> String -> Identifier
fromCapture pattern = fromCaptures pattern . repeat
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' :: [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