@@ -1,3 +1,4 @@
1+--------------------------------------------------------------------------------
12-- | Module providing pattern matching and capturing on 'Identifier's.
23-- 'Pattern's come in two kinds:
34--
@@ -34,71 +35,116 @@
3435-- Like an 'Identifier', a 'Pattern' also has a type parameter. This is simply
3536-- an extra layer of safety, and can be discarded using the 'castPattern'
3637-- function.
37−--
3838module Hakyll.Core.Identifier.Pattern
3939 ( -- * The pattern type
4040 Pattern
41− , castPattern
4241
4342 -- * Creating patterns
44− , parseGlob
45− , predicate
46− , list
47− , regex
48− , inGroup
43+ , fromGlob
44+ , fromList
45+ , fromRegex
46+
47+ -- * Manipulating patterns
4948 , complement
49+ , castPattern
5050
5151 -- * Applying patterns
5252 , matches
5353 , filterMatches
54+
55+ -- * Capturing strings
5456 , capture
5557 , fromCapture
5658 , fromCaptures
5759 ) where
5860
59−import Data.List (isPrefixOf, inits, tails)
60−import Control.Arrow ((&&&), (>>>))
61−import Control.Monad (msum)
62−import Data.Maybe (isJust, fromMaybe)
63−import Data.Monoid (Monoid, mempty, mappend)
6461
65−import GHC.Exts (IsString, fromString)
66−import Text.Regex.TDFA ((=~~))
62+--------------------------------------------------------------------------------
63+import Control.Applicative (pure, (<$>), (<*>))
64+import Control.Arrow ((&&&), (>>>))
65+import Control.Monad (msum)
66+import Data.Binary (Binary (..), getWord8, putWord8)
67+import Data.List (inits, isPrefixOf, tails)
68+import Data.Maybe (isJust)
69+import Data.Monoid (Monoid, mappend, mempty)
6770
68−import Hakyll.Core.Identifier
6971
70−-- | One base element of a pattern
71−--
72−data GlobComponent = Capture
73− | CaptureMany
74− | Literal String
75− deriving (Eq, Show)
72+--------------------------------------------------------------------------------
73+import GHC.Exts (IsString, fromString)
74+import Text.Regex.TDFA ((=~))
75+
76+
77+--------------------------------------------------------------------------------
78+import Hakyll.Core.Identifier
79+
80+
81+--------------------------------------------------------------------------------
82+-- | Elements of a glob pattern
83+data GlobComponent
84+ = Capture
85+ | CaptureMany
86+ | Literal String
87+ deriving (Eq, Show)
88+
89+
90+--------------------------------------------------------------------------------
91+instance Binary GlobComponent where
92+ put Capture = putWord8 0
93+ put CaptureMany = putWord8 1
94+ put (Literal s) = putWord8 2 >> put s
95+
96+ get = getWord8 >>= \t -> case t of
97+ 0 -> pure Capture
98+ 1 -> pure CaptureMany
99+ 2 -> Literal <$> get
100+ _ -> error "Data.Binary.get: Invalid GlobComponent"
101+
76102
103+--------------------------------------------------------------------------------
77104-- | Type that allows matching on identifiers
78−--
79−data Pattern a = Glob [GlobComponent]
80− | Predicate (Identifier a -> Bool)
81− | List [Identifier a]
105+data Pattern a
106+ = Everything
107+ | Complement (Pattern a)
108+ | And (Pattern a) (Pattern a)
109+ | Glob [GlobComponent]
110+ | List [Identifier a] -- TODO Maybe use a set here
111+ | Regex String
112+ deriving (Show)
113+
114+
115+--------------------------------------------------------------------------------
116+instance Binary (Pattern a) where
117+ put Everything = putWord8 0
118+ put (Complement p) = putWord8 1 >> put p
119+ put (And x y) = putWord8 2 >> put x >> put y
120+ put (Glob g) = putWord8 3 >> put g
121+ put (List is) = putWord8 4 >> put is
122+ put (Regex r) = putWord8 5 >> put r
123+
124+ get = getWord8 >>= \t -> case t of
125+ 0 -> pure Everything
126+ 1 -> Complement <$> get
127+ 2 -> And <$> get <*> get
128+ 3 -> Glob <$> get
129+ 4 -> List <$> get
130+ _ -> Regex <$> get
82131
132+
133+--------------------------------------------------------------------------------
83134instance IsString (Pattern a) where
84− fromString = parseGlob
135+ fromString = fromGlob
136+
85137
138+--------------------------------------------------------------------------------
86139instance Monoid (Pattern a) where
87− mempty = Predicate (const True)
88− p1 `mappend` p2 = Predicate $ \i -> matches p1 i && matches p2 i
140+ mempty = Everything
141+ mappend = And
89142
90−-- | Discard the phantom type parameter
91−--
92−castPattern :: Pattern a -> Pattern b
93−castPattern (Glob g) = Glob g
94−castPattern (Predicate p) = Predicate $ p . castIdentifier
95−castPattern (List l) = List $ map castIdentifier l
96−{-# INLINE castPattern #-}
97143
144+--------------------------------------------------------------------------------
98145-- | Parse a pattern from a string
99−--
100−parseGlob :: String -> Pattern a
101−parseGlob = Glob . parse'
146+fromGlob :: String -> Pattern a
147+fromGlob = Glob . parse'
102148 where
103149 parse' str =
104150 let (chunk, rest) = break (`elem` "\\*") str
@@ -108,35 +154,24 @@ parseGlob = Glob . parse'
108154 ('*' : xs) -> Literal chunk : Capture : parse' xs
109155 xs -> Literal chunk : Literal xs : []
110156
111−-- | Create a 'Pattern' from an arbitrary predicate
112−--
113−-- Example:
114−--
115−-- > predicate (\i -> matches "foo/*" i && not (matches "foo/bar" i))
116−--
117−predicate :: (Identifier a -> Bool) -> Pattern a
118−predicate = Predicate
119157
158+--------------------------------------------------------------------------------
120159-- | Create a 'Pattern' from a list of 'Identifier's it should match
121−--
122−list :: [Identifier a] -> Pattern a
123−list = List
160+fromList :: [Identifier a] -> Pattern a
161+fromList = List
124162
163+
164+--------------------------------------------------------------------------------
125165-- | Create a 'Pattern' from a regex
126166--
127167-- Example:
128168--
129169-- > regex "^foo/[^x]*$
130−--
131−regex :: String -> Pattern a
132−regex str = predicate $ fromMaybe False . (=~~ str) . toFilePath
170+fromRegex :: String -> Pattern a
171+fromRegex = Regex
133172
134−-- | Create a 'Pattern' which matches if the identifier is in a certain group
135−-- (or in no group)
136−--
137−inGroup :: Maybe String -> Pattern a
138−inGroup group = predicate $ (== group) . identifierGroup
139173
174+--------------------------------------------------------------------------------
140175-- | Inverts a pattern, e.g.
141176--
142177-- > complement "foo/bar.html"
@@ -144,34 +179,53 @@ inGroup group = predicate $ (== group) . identifierGroup
144179-- will match /anything/ except @\"foo\/bar.html\"@
145180--
146181complement :: Pattern a -> Pattern a
147−complement p = predicate (not . matches p)
182+complement = Complement
183+
148184
185+--------------------------------------------------------------------------------
186+-- | Discard the phantom type parameter
187+castPattern :: Pattern a -> Pattern b
188+castPattern Everything = Everything
189+castPattern (Complement x) = Complement (castPattern x)
190+castPattern (And x y) = And (castPattern x) (castPattern y)
191+castPattern (Glob g) = Glob g
192+castPattern (List l) = List $ map castIdentifier l
193+castPattern (Regex r) = Regex r
194+
195+
196+--------------------------------------------------------------------------------
149197-- | Check if an identifier matches a pattern
150−--
151198matches :: Pattern a -> Identifier a -> Bool
152−matches (Glob p) = isJust . capture (Glob p)
153−matches (Predicate p) = (p $)
154−matches (List l) = (`elem` l)
199+matches Everything _ = True
200+matches (Complement p) i = not $ matches p i
201+matches (And x y) i = matches x i && matches y i
202+matches (Glob p) i = isJust $ capture (Glob p) i
203+matches (List l) i = i `elem` l
204+matches (Regex r) i = toFilePath i =~ r
205+
155206
207+--------------------------------------------------------------------------------
156208-- | Given a list of identifiers, retain only those who match the given pattern
157−--
158209filterMatches :: Pattern a -> [Identifier a] -> [Identifier a]
159210filterMatches = filter . matches
160211
212+
213+--------------------------------------------------------------------------------
161214-- | Split a list at every possible point, generate a list of (init, tail)
162215-- cases. The result is sorted with inits decreasing in length.
163−--
164216splits :: [a] -> [([a], [a])]
165217splits = inits &&& tails >>> uncurry zip >>> reverse
166218
219+
220+--------------------------------------------------------------------------------
167221-- | Match a glob against a pattern, generating a list of captures
168−--
169222capture :: Pattern a -> Identifier a -> Maybe [String]
170−capture (Glob p) (Identifier _ i) = capture' p i
171−capture _ _ = Nothing
223+capture (Glob p) i = capture' p (toFilePath i)
224+capture _ _ = Nothing
172225
226+
227+--------------------------------------------------------------------------------
173228-- | Internal verion of 'capture'
174−--
175229capture' :: [GlobComponent] -> String -> Maybe [String]
176230capture' [] [] = Just [] -- An empty match
177231capture' [] _ = Nothing -- No match
@@ -186,7 +240,9 @@ capture' (Capture : ms) str =
186240capture' (CaptureMany : ms) str =
187241 -- Match everything
188242 msum $ [ fmap (i :) (capture' ms t) | (i, t) <- splits str ]
189−
243+
244+
245+--------------------------------------------------------------------------------
190246-- | Create an identifier from a pattern by filling in the captures with a given
191247-- string
192248--
@@ -197,21 +253,22 @@ capture' (CaptureMany : ms) str =
197253-- Result:
198254--
199255-- > "tags/foo"
200−--
201256fromCapture :: Pattern a -> String -> Identifier a
202257fromCapture pattern = fromCaptures pattern . repeat
203258
259+
260+--------------------------------------------------------------------------------
204261-- | Create an identifier from a pattern by filling in the captures with the
205262-- given list of strings
206−--
207263fromCaptures :: Pattern a -> [String] -> Identifier a
208−fromCaptures (Glob p) = Identifier Nothing . fromCaptures' p
264+fromCaptures (Glob p) = fromFilePath . fromCaptures' p
209265fromCaptures _ = error $
210266 "Hakyll.Core.Identifier.Pattern.fromCaptures: fromCaptures only works " ++
211267 "on simple globs!"
212268
269+
270+--------------------------------------------------------------------------------
213271-- | Internally used version of 'fromCaptures'
214−--
215272fromCaptures' :: [GlobComponent] -> [String] -> String
216273fromCaptures' [] _ = mempty
217274fromCaptures' (m : ms) [] = case m of