git.iko.soy/hakyll
on 86ede74 help sign in
hakyll/src/Hakyll/Core/Identifier/Pattern.hs
280 lines 9.5 kB history raw
1--------------------------------------------------------------------------------
2-- | Module providing pattern matching and capturing on 'Identifier's.
3-- 'Pattern's come in two kinds:
4--
5-- * Simple glob patterns, like @foo\/*@;
6--
7-- * Custom, arbitrary predicates of the type @Identifier -> Bool@.
8--
9-- They both have advantages and disadvantages. By default, globs are used,
10-- unless you construct your 'Pattern' using the 'predicate' function.
11--
12-- A very simple pattern could be, for example, @foo\/bar@. This pattern will
13-- only match the exact @foo\/bar@ identifier.
14--
15-- To match more than one identifier, there are different captures that one can
16-- use:
17--
18-- * @*@: matches at most one element of an identifier;
19--
20-- * @**@: matches one or more elements of an identifier.
21--
22-- Some examples:
23--
24-- * @foo\/*@ will match @foo\/bar@ and @foo\/foo@, but not @foo\/bar\/qux@;
25--
26-- * @**@ will match any identifier;
27--
28-- * @foo\/**@ will match @foo\/bar@ and @foo\/bar\/qux@, but not @bar\/foo@;
29--
30-- * @foo\/*.html@ will match all HTML files in the @foo\/@ directory.
31--
32-- The 'capture' function allows the user to get access to the elements captured
33-- by the capture elements in the pattern.
34--
35-- Like an 'Identifier', a 'Pattern' also has a type parameter. This is simply
36-- an extra layer of safety, and can be discarded using the 'castPattern'
37-- function.
38module Hakyll.Core.Identifier.Pattern
39 ( -- * The pattern type
40 Pattern
42 -- * Creating patterns
43 , fromGlob
44 , fromList
45 , fromRegex
47 -- * Manipulating patterns
48 , complement
49 , castPattern
51 -- * Applying patterns
52 , matches
53 , filterMatches
55 -- * Capturing strings
56 , capture
57 , fromCapture
58 , fromCaptures
59 ) where
62--------------------------------------------------------------------------------
63import Control.Applicative (pure, (<$>), (<*>))
64import Control.Arrow ((&&&), (>>>))
65import Control.Monad (msum)
66import Data.Binary (Binary (..), getWord8, putWord8)
67import Data.List (inits, isPrefixOf, tails)
68import Data.Maybe (isJust)
69import Data.Monoid (Monoid, mappend, mempty)
72--------------------------------------------------------------------------------
73import GHC.Exts (IsString, fromString)
74import Text.Regex.TDFA ((=~))
77--------------------------------------------------------------------------------
78import Hakyll.Core.Identifier
81--------------------------------------------------------------------------------
82-- | Elements of a glob pattern
83data GlobComponent
84 = Capture
85 | CaptureMany
86 | Literal String
87 deriving (Eq, Show)
90--------------------------------------------------------------------------------
91instance Binary GlobComponent where
92 put Capture = putWord8 0
93 put CaptureMany = putWord8 1
94 put (Literal s) = putWord8 2 >> put s
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"
103--------------------------------------------------------------------------------
104-- | Type that allows matching on identifiers
105data 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)
115--------------------------------------------------------------------------------
116instance 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
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
133--------------------------------------------------------------------------------
134instance IsString (Pattern a) where
135 fromString = fromGlob
138--------------------------------------------------------------------------------
139instance Monoid (Pattern a) where
140 mempty = Everything
141 mappend = And
144--------------------------------------------------------------------------------
145-- | Parse a pattern from a string
146fromGlob :: String -> Pattern a
147fromGlob = Glob . parse'
148 where
149 parse' str =
150 let (chunk, rest) = break (`elem` "\\*") str
151 in case rest of
152 ('\\' : x : xs) -> Literal (chunk ++ [x]) : parse' xs
153 ('*' : '*' : xs) -> Literal chunk : CaptureMany : parse' xs
154 ('*' : xs) -> Literal chunk : Capture : parse' xs
155 xs -> Literal chunk : Literal xs : []
158--------------------------------------------------------------------------------
159-- | Create a 'Pattern' from a list of 'Identifier's it should match
160fromList :: [Identifier a] -> Pattern a
161fromList = List
164--------------------------------------------------------------------------------
165-- | Create a 'Pattern' from a regex
166--
167-- Example:
168--
169-- > regex "^foo/[^x]*$
170fromRegex :: String -> Pattern a
171fromRegex = Regex
174--------------------------------------------------------------------------------
175-- | Inverts a pattern, e.g.
176--
177-- > complement "foo/bar.html"
178--
179-- will match /anything/ except @\"foo\/bar.html\"@
180--
181complement :: Pattern a -> Pattern a
182complement = Complement
185--------------------------------------------------------------------------------
186-- | Discard the phantom type parameter
187castPattern :: Pattern a -> Pattern b
188castPattern Everything = Everything
189castPattern (Complement x) = Complement (castPattern x)
190castPattern (And x y) = And (castPattern x) (castPattern y)
191castPattern (Glob g) = Glob g
192castPattern (List l) = List $ map castIdentifier l
193castPattern (Regex r) = Regex r
196--------------------------------------------------------------------------------
197-- | Check if an identifier matches a pattern
198matches :: Pattern a -> Identifier a -> Bool
199matches Everything _ = True
200matches (Complement p) i = not $ matches p i
201matches (And x y) i = matches x i && matches y i
202matches (Glob p) i = isJust $ capture (Glob p) i
203matches (List l) i = i `elem` l
204matches (Regex r) i = toFilePath i =~ r
207--------------------------------------------------------------------------------
208-- | Given a list of identifiers, retain only those who match the given pattern
209filterMatches :: Pattern a -> [Identifier a] -> [Identifier a]
210filterMatches = filter . matches
213--------------------------------------------------------------------------------
214-- | Split a list at every possible point, generate a list of (init, tail)
215-- cases. The result is sorted with inits decreasing in length.
216splits :: [a] -> [([a], [a])]
217splits = inits &&& tails >>> uncurry zip >>> reverse
220--------------------------------------------------------------------------------
221-- | Match a glob against a pattern, generating a list of captures
222capture :: Pattern a -> Identifier a -> Maybe [String]
223capture (Glob p) i = capture' p (toFilePath i)
224capture _ _ = Nothing
227--------------------------------------------------------------------------------
228-- | Internal verion of 'capture'
229capture' :: [GlobComponent] -> String -> Maybe [String]
230capture' [] [] = Just [] -- An empty match
231capture' [] _ = Nothing -- No match
232capture' (Literal l : ms) str
233 -- Match the literal against the string
234 | l `isPrefixOf` str = capture' ms $ drop (length l) str
235 | otherwise = Nothing
236capture' (Capture : ms) str =
237 -- Match until the next /
238 let (chunk, rest) = break (== '/') str
239 in msum $ [ fmap (i :) (capture' ms (t ++ rest)) | (i, t) <- splits chunk ]
240capture' (CaptureMany : ms) str =
241 -- Match everything
242 msum $ [ fmap (i :) (capture' ms t) | (i, t) <- splits str ]
245--------------------------------------------------------------------------------
246-- | Create an identifier from a pattern by filling in the captures with a given
247-- string
248--
249-- Example:
250--
251-- > fromCapture (parseGlob "tags/*") "foo"
252--
253-- Result:
254--
255-- > "tags/foo"
256fromCapture :: Pattern a -> String -> Identifier a
257fromCapture pattern = fromCaptures pattern . repeat
260--------------------------------------------------------------------------------
261-- | Create an identifier from a pattern by filling in the captures with the
262-- given list of strings
263fromCaptures :: Pattern a -> [String] -> Identifier a
264fromCaptures (Glob p) = fromFilePath . fromCaptures' p
265fromCaptures _ = error $
266 "Hakyll.Core.Identifier.Pattern.fromCaptures: fromCaptures only works " ++
267 "on simple globs!"
270--------------------------------------------------------------------------------
271-- | Internally used version of 'fromCaptures'
272fromCaptures' :: [GlobComponent] -> [String] -> String
273fromCaptures' [] _ = mempty
274fromCaptures' (m : ms) [] = case m of
275 Literal l -> l `mappend` fromCaptures' ms []
276 _ -> error $ "Hakyll.Core.Identifier.Pattern.fromCaptures': "
277 ++ "identifier list exhausted"
278fromCaptures' (m : ms) ids@(i : is) = case m of
279 Literal l -> l `mappend` fromCaptures' ms ids
280 _ -> i `mappend` fromCaptures' ms is