module Hakyll.Core.Identifier.Pattern
( Pattern
, parsePattern
, match
, doesMatch
, matches
, fromCapture
, fromCaptureString
, fromCaptures
) where
import Data.List (intercalate)
import Control.Monad (msum)
import Data.Maybe (isJust)
import Data.Monoid (mempty, mappend)
import GHC.Exts (IsString, fromString)
import Hakyll.Core.Identifier
data PatternComponent = CaptureOne
| CaptureMany
| Literal String
deriving (Eq)
instance Show PatternComponent where
show CaptureOne = "*"
show CaptureMany = "**"
show (Literal s) = s
newtype Pattern = Pattern {unPattern :: [PatternComponent]}
deriving (Eq)
instance Show Pattern where
show = intercalate "/" . map show . unPattern
instance IsString Pattern where
fromString = parsePattern
parsePattern :: String -> Pattern
parsePattern = Pattern . map toPattern . unIdentifier . parseIdentifier
where
toPattern x | x == "*" = CaptureOne
| x == "**" = CaptureMany
| otherwise = Literal x
match :: Pattern -> Identifier -> Maybe [Identifier]
match (Pattern p) (Identifier i) = fmap (map Identifier) $ match' 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 ls = reverse $ splits' [] ls
where
splits' lx ly = (lx, ly) : case ly of
[] -> []
(y : ys) -> splits' (lx ++ [y]) ys
match' :: [PatternComponent] -> [String] -> Maybe [[String]]
match' [] [] = Just []
match' [] _ = Nothing
match' _ [] = Nothing
match' (m : ms) (s : ss) = case m of
Literal l -> if s == l then match' ms ss else Nothing
CaptureOne -> fmap ([s] :) $ match' ms ss
CaptureMany ->
let take' (i, t) = fmap (i :) $ match' ms t
in msum $ map take' $ splits (s : ss)
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