git.iko.soy/hakyll
on 33fdc41 help sign in
hakyll/src/Hakyll/Core/Identifier/Pattern.hs
313 lines 11 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
46 , fromVersion
48 -- * Manipulating patterns
49 , complement
50 , withVersion
51 , fromLiteral
53 -- * Applying patterns
54 , matches
55 , filterMatches
57 -- * Capturing strings
58 , capture
59 , fromCapture
60 , fromCaptures
61 ) where
64--------------------------------------------------------------------------------
65import Control.Applicative (pure, (<$>), (<*>))
66import Control.Arrow ((&&&), (>>>))
67import Control.Monad (msum)
68import Data.Binary (Binary (..), getWord8, putWord8)
69import Data.List (inits, isPrefixOf, tails)
70import Data.Maybe (isJust)
71import Data.Monoid (Monoid, mappend, mempty)
72import Data.Set (Set)
73import qualified Data.Set as S
76--------------------------------------------------------------------------------
77import GHC.Exts (IsString, fromString)
78import Text.Regex.TDFA ((=~))
81--------------------------------------------------------------------------------
82import Hakyll.Core.Identifier
85--------------------------------------------------------------------------------
86-- | Elements of a glob pattern
87data GlobComponent
88 = Capture
89 | CaptureMany
90 | Literal String
91 deriving (Eq, Show)
94--------------------------------------------------------------------------------
95instance Binary GlobComponent where
96 put Capture = putWord8 0
97 put CaptureMany = putWord8 1
98 put (Literal s) = putWord8 2 >> put s
100 get = getWord8 >>= \t -> case t of
101 0 -> pure Capture
102 1 -> pure CaptureMany
103 2 -> Literal <$> get
104 _ -> error "Data.Binary.get: Invalid GlobComponent"
107--------------------------------------------------------------------------------
108-- | Type that allows matching on identifiers
109data Pattern
110 = Everything
111 | Complement Pattern
112 | And Pattern Pattern
113 | Glob [GlobComponent]
114 | List (Set Identifier)
115 | Regex String
116 | Version (Maybe String)
117 deriving (Show)
120--------------------------------------------------------------------------------
121instance Binary Pattern where
122 put Everything = putWord8 0
123 put (Complement p) = putWord8 1 >> put p
124 put (And x y) = putWord8 2 >> put x >> put y
125 put (Glob g) = putWord8 3 >> put g
126 put (List is) = putWord8 4 >> put is
127 put (Regex r) = putWord8 5 >> put r
128 put (Version v) = putWord8 6 >> put v
130 get = getWord8 >>= \t -> case t of
131 0 -> pure Everything
132 1 -> Complement <$> get
133 2 -> And <$> get <*> get
134 3 -> Glob <$> get
135 4 -> List <$> get
136 5 -> Regex <$> get
137 _ -> Version <$> get
140--------------------------------------------------------------------------------
141instance IsString Pattern where
142 fromString = fromGlob
145--------------------------------------------------------------------------------
146instance Monoid Pattern where
147 mempty = Everything
148 mappend x y = optimize $ And x y
151--------------------------------------------------------------------------------
152-- | This is necessary for good 'isLiteral' results
153optimize :: Pattern -> Pattern
154optimize (Complement x) = Complement (optimize x)
155optimize (And x Everything) = x
156optimize (And Everything y) = y
157optimize (And x y) = And (optimize x) (optimize y)
158optimize p = p
161--------------------------------------------------------------------------------
162-- | Parse a pattern from a string
163fromGlob :: String -> Pattern
164fromGlob = Glob . parse'
165 where
166 parse' str =
167 let (chunk, rest) = break (`elem` "\\*") str
168 in case rest of
169 ('\\' : x : xs) -> Literal (chunk ++ [x]) : parse' xs
170 ('*' : '*' : xs) -> Literal chunk : CaptureMany : parse' xs
171 ('*' : xs) -> Literal chunk : Capture : parse' xs
172 xs -> Literal chunk : Literal xs : []
175--------------------------------------------------------------------------------
176-- | Create a 'Pattern' from a list of 'Identifier's it should match
177fromList :: [Identifier] -> Pattern
178fromList = List . S.fromList
181--------------------------------------------------------------------------------
182-- | Create a 'Pattern' from a regex
183--
184-- Example:
185--
186-- > regex "^foo/[^x]*$
187fromRegex :: String -> Pattern
188fromRegex = Regex
191--------------------------------------------------------------------------------
192-- | Create a pattern which matches all items with the given version.
193fromVersion :: Maybe String -> Pattern
194fromVersion = Version
197--------------------------------------------------------------------------------
198-- | Inverts a pattern, e.g.
199--
200-- > complement "foo/bar.html"
201--
202-- will match /anything/ except @\"foo\/bar.html\"@
203complement :: Pattern -> Pattern
204complement = Complement
207--------------------------------------------------------------------------------
208-- | Specify a version, e.g.
209--
210-- > "foo/*.markdown" `withVersion` "pdf"
211withVersion :: Pattern -> String -> Pattern
212withVersion p v = optimize $ And p $ fromVersion $ Just v
215--------------------------------------------------------------------------------
216-- | Check if a pattern is a literal. @"*.markdown"@ is not a literal but
217-- @"posts.markdown"@ is.
218fromLiteral :: Pattern -> Maybe Identifier
219fromLiteral pattern = case pattern of
220 Glob p -> fmap fromFilePath $ foldr fromLiteral' (Just "") p
221 _ -> Nothing
222 where
223 fromLiteral' (Literal x) (Just y) = Just $ x ++ y
224 fromLiteral' _ _ = Nothing
228--------------------------------------------------------------------------------
229-- | Check if an identifier matches a pattern
230matches :: Pattern -> Identifier -> Bool
231matches Everything _ = True
232matches (Complement p) i = not $ matches p i
233matches (And x y) i = matches x i && matches y i
234matches (Glob p) i = isJust $ capture (Glob p) i
235matches (List l) i = i `S.member` l
236matches (Regex r) i = toFilePath i =~ r
237matches (Version v) i = identifierVersion i == v
240--------------------------------------------------------------------------------
241-- | Given a list of identifiers, retain only those who match the given pattern
242filterMatches :: Pattern -> [Identifier] -> [Identifier]
243filterMatches = filter . matches
246--------------------------------------------------------------------------------
247-- | Split a list at every possible point, generate a list of (init, tail)
248-- cases. The result is sorted with inits decreasing in length.
249splits :: [a] -> [([a], [a])]
250splits = inits &&& tails >>> uncurry zip >>> reverse
253--------------------------------------------------------------------------------
254-- | Match a glob against a pattern, generating a list of captures
255capture :: Pattern -> Identifier -> Maybe [String]
256capture (Glob p) i = capture' p (toFilePath i)
257capture _ _ = Nothing
260--------------------------------------------------------------------------------
261-- | Internal verion of 'capture'
262capture' :: [GlobComponent] -> String -> Maybe [String]
263capture' [] [] = Just [] -- An empty match
264capture' [] _ = Nothing -- No match
265capture' (Literal l : ms) str
266 -- Match the literal against the string
267 | l `isPrefixOf` str = capture' ms $ drop (length l) str
268 | otherwise = Nothing
269capture' (Capture : ms) str =
270 -- Match until the next /
271 let (chunk, rest) = break (== '/') str
272 in msum $ [ fmap (i :) (capture' ms (t ++ rest)) | (i, t) <- splits chunk ]
273capture' (CaptureMany : ms) str =
274 -- Match everything
275 msum $ [ fmap (i :) (capture' ms t) | (i, t) <- splits str ]
278--------------------------------------------------------------------------------
279-- | Create an identifier from a pattern by filling in the captures with a given
280-- string
281--
282-- Example:
283--
284-- > fromCapture (parseGlob "tags/*") "foo"
285--
286-- Result:
287--
288-- > "tags/foo"
289fromCapture :: Pattern -> String -> Identifier
290fromCapture pattern = fromCaptures pattern . repeat
293--------------------------------------------------------------------------------
294-- | Create an identifier from a pattern by filling in the captures with the
295-- given list of strings
296fromCaptures :: Pattern -> [String] -> Identifier
297fromCaptures (Glob p) = fromFilePath . fromCaptures' p
298fromCaptures _ = error $
299 "Hakyll.Core.Identifier.Pattern.fromCaptures: fromCaptures only works " ++
300 "on simple globs!"
303--------------------------------------------------------------------------------
304-- | Internally used version of 'fromCaptures'
305fromCaptures' :: [GlobComponent] -> [String] -> String
306fromCaptures' [] _ = mempty
307fromCaptures' (m : ms) [] = case m of
308 Literal l -> l `mappend` fromCaptures' ms []
309 _ -> error $ "Hakyll.Core.Identifier.Pattern.fromCaptures': "
310 ++ "identifier list exhausted"
311fromCaptures' (m : ms) ids@(i : is) = case m of
312 Literal l -> l `mappend` fromCaptures' ms ids
313 _ -> i `mappend` fromCaptures' ms is