module Hakyll.Core.Identifier.Pattern
( Pattern
, parsePattern
, match
, doesMatch
, matches
, fromCapture
, fromCaptureString
, fromCaptures
) where
import Data.List (isPrefixOf, inits, tails)
import Control.Arrow ((&&&), (>>>))
import Control.Monad (msum)
import Data.Maybe (isJust)
import Data.Monoid (mempty, mappend)
import GHC.Exts (IsString, fromString)
import Hakyll.Core.Identifier
data PatternComponent = Capture
| CaptureMany
| Literal String
deriving (Eq, Show)
newtype Pattern = Pattern {unPattern :: [PatternComponent]}
deriving (Eq, Show)
instance IsString Pattern where
fromString = parsePattern
parsePattern :: String -> Pattern
parsePattern = Pattern . 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 : []
match :: Pattern -> Identifier -> Maybe [Identifier]
match p (Identifier i) = fmap (map Identifier) $ match' (unPattern p) i
doesMatch :: Pattern -> Identifier -> Bool
doesMatch p = isJust . match p
matches :: Pattern -> [Identifier] -> [Identifier]
matches p = filter (doesMatch p)
splits :: [a] -> [([a], [a])]
splits = inits &&& tails >>> uncurry zip >>> reverse
match' :: [PatternComponent] -> String -> Maybe [String]
match' [] [] = Just []
match' [] _ = Nothing
match' (Literal l : ms) str
| l `isPrefixOf` str = match' ms $ drop (length l) str
| otherwise = Nothing
match' (Capture : ms) str =
let (chunk, rest) = break (== '/') str
in msum $ [ fmap (i :) (match' ms (t ++ rest)) | (i, t) <- splits chunk ]
match' (CaptureMany : ms) str =
msum $ [ fmap (i :) (match' ms t) | (i, t) <- splits str ]
fromCapture :: Pattern -> Identifier -> Identifier
fromCapture pattern = fromCaptures pattern . repeat
fromCaptureString :: Pattern -> String -> Identifier
fromCaptureString pattern = fromCapture pattern . parseIdentifier
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: "
++ "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