@@ -0,0 +1,91 @@
1+-- | Module providing pattern matching and capturing on 'Identifier's.
2+--
3+-- TODO: Documentation
4+--
5+module Hakyll.Core.Identifier.Pattern
6+ ( Pattern
7+ , parsePattern
8+ , match
9+ , doesMatch
10+ , matches
11+ ) where
12+
13+import Data.List (intercalate)
14+import Control.Monad (msum)
15+import Data.Maybe (isJust)
16+
17+import GHC.Exts (IsString, fromString)
18+
19+import Hakyll.Core.Identifier
20+
21+-- | One base element of a pattern
22+--
23+data PatternComponent = CaptureOne
24+ | CaptureMany
25+ | Literal String
26+ deriving (Eq)
27+
28+instance Show PatternComponent where
29+ show CaptureOne = "*"
30+ show CaptureMany = "**"
31+ show (Literal s) = s
32+
33+-- | Type that allows matching on identifiers
34+--
35+newtype Pattern = Pattern {unPattern :: [PatternComponent]}
36+ deriving (Eq)
37+
38+instance Show Pattern where
39+ show = intercalate "/" . map show . unPattern
40+
41+instance IsString Pattern where
42+ fromString = parsePattern
43+
44+-- | Parse a pattern from a string
45+--
46+parsePattern :: String -> Pattern
47+parsePattern = Pattern . map toPattern . unIdentifier . parseIdentifier
48+ where
49+ toPattern x | x == "*" = CaptureOne
50+ | x == "**" = CaptureMany
51+ | otherwise = Literal x
52+
53+-- | Match an identifier against a pattern, generating a list of captures
54+--
55+match :: Pattern -> Identifier -> Maybe [[String]]
56+match (Pattern p) (Identifier i) = match' p i
57+
58+-- | Check if an identifier matches a pattern
59+--
60+doesMatch :: Pattern -> Identifier -> Bool
61+doesMatch p = isJust . match p
62+
63+-- | Given a list of identifiers, retain only those who match the given pattern
64+--
65+matches :: Pattern -> [Identifier] -> [Identifier]
66+matches p = filter (doesMatch p)
67+
68+-- | Split a list at every possible point, generate a list of (init, tail) cases
69+--
70+splits :: [a] -> [([a], [a])]
71+splits ls = reverse $ splits' [] ls
72+ where
73+ splits' lx ly = (lx, ly) : case ly of
74+ [] -> []
75+ (y : ys) -> splits' (lx ++ [y]) ys
76+
77+-- | Internal verion of 'match'
78+--
79+match' :: [PatternComponent] -> [String] -> Maybe [[String]]
80+match' [] [] = Just [] -- An empty match
81+match' [] _ = Nothing -- No match
82+match' _ [] = Nothing -- No match
83+match' (m : ms) (s : ss) = case m of
84+ -- Take one string and one literal, fail on mismatch
85+ Literal l -> if s == l then match' ms ss else Nothing
86+ -- Take one string and one capture
87+ CaptureOne -> fmap ([s] :) $ match' ms ss
88+ -- Take one string, and one or many captures
89+ CaptureMany ->
90+ let take' (i, t) = fmap (i :) $ match' ms t
91+ in msum $ map take' $ splits (s : ss)