diff options
| -rw-r--r-- | examples/brochure/hakyll.hs | 18 | ||||
| -rw-r--r-- | examples/feedblog/hakyll.hs | 48 | ||||
| -rw-r--r-- | examples/hakyll/hakyll.hs | 34 | ||||
| -rw-r--r-- | examples/hakyll/tutorial.markdown | 55 | ||||
| -rw-r--r-- | examples/morepages/hakyll.hs | 23 | ||||
| -rw-r--r-- | examples/simpleblog/hakyll.hs | 46 | ||||
| -rw-r--r-- | examples/tagblog/hakyll.hs | 52 | ||||
| -rw-r--r-- | src/Hakyll/Core/Compiler.hs | 2 | ||||
| -rw-r--r-- | src/Hakyll/Core/Identifier/Pattern.hs | 115 | ||||
| -rw-r--r-- | src/Hakyll/Core/Routes.hs | 16 | ||||
| -rw-r--r-- | src/Hakyll/Core/Rules.hs | 50 | ||||
| -rw-r--r-- | src/Hakyll/Core/Rules/Internal.hs | 16 | ||||
| -rw-r--r-- | tests/Hakyll/Core/Identifier/Tests.hs | 28 |
13 files changed, 285 insertions, 218 deletions
diff --git a/examples/brochure/hakyll.hs b/examples/brochure/hakyll.hs index 819924f..1bc5919 100644 --- a/examples/brochure/hakyll.hs +++ b/examples/brochure/hakyll.hs @@ -6,13 +6,15 @@ import Hakyll main :: IO () main = hakyll $ do - route "css/*" idRoute - compile "css/*" compressCssCompiler + match "css/*" $ do + route idRoute + compile compressCssCompiler - compile "templates/*" templateCompiler + match "templates/*" $ compile templateCompiler - forM_ ["about.rst", "index.markdown", "code.lhs"] $ \page -> do - route page $ setExtension "html" - compile page $ pageCompiler - >>> applyTemplateCompiler "templates/default.html" - >>> relativizeUrlsCompiler + forM_ ["about.rst", "index.markdown", "code.lhs"] $ \page -> + match page $ do + route $ setExtension "html" + compile $ pageCompiler + >>> applyTemplateCompiler "templates/default.html" + >>> relativizeUrlsCompiler diff --git a/examples/feedblog/hakyll.hs b/examples/feedblog/hakyll.hs index e10af10..4aa8ed9 100644 --- a/examples/feedblog/hakyll.hs +++ b/examples/feedblog/hakyll.hs @@ -11,47 +11,43 @@ import Hakyll main :: IO () main = hakyll $ do -- Compress CSS - route "css/*" idRoute - compile "css/*" compressCssCompiler + match "css/*" $ do + route idRoute + compile compressCssCompiler -- Render posts - route "posts/*" $ setExtension ".html" - compile "posts/*" $ - pageCompiler + match "posts/*" $ do + route $ setExtension ".html" + compile $ pageCompiler >>> applyTemplateCompiler "templates/post.html" >>> applyTemplateCompiler "templates/default.html" >>> relativizeUrlsCompiler -- Render posts list - route "posts.html" $ idRoute - create "posts.html" $ - constA mempty - >>> arr (setField "title" "All posts") - >>> requireAllA "posts/*" addPostList - >>> applyTemplateCompiler "templates/posts.html" - >>> applyTemplateCompiler "templates/default.html" - >>> relativizeUrlsCompiler + match "posts.html" $ route idRoute + create "posts.html" $ constA mempty + >>> arr (setField "title" "All posts") + >>> requireAllA "posts/*" addPostList + >>> applyTemplateCompiler "templates/posts.html" + >>> applyTemplateCompiler "templates/default.html" + >>> relativizeUrlsCompiler -- Index - route "index.html" $ idRoute - create "index.html" $ - constA mempty - >>> arr (setField "title" "Home") - >>> requireAllA "posts/*" (id *** arr (take 3 . reverse . sortByBaseName) >>> addPostList) - >>> applyTemplateCompiler "templates/index.html" - >>> applyTemplateCompiler "templates/default.html" - >>> relativizeUrlsCompiler + match "index.html" $ route idRoute + create "index.html" $ constA mempty + >>> arr (setField "title" "Home") + >>> requireAllA "posts/*" (id *** arr (take 3 . reverse . sortByBaseName) >>> addPostList) + >>> applyTemplateCompiler "templates/index.html" + >>> applyTemplateCompiler "templates/default.html" + >>> relativizeUrlsCompiler -- Render RSS feed - route "rss.xml" $ idRoute + match "rss.xml" $ route idRoute create "rss.xml" $ requireAll_ "posts/*" >>> renderRss feedConfiguration -- Read templates - compile "templates/*" templateCompiler - - -- End - return () + match "templates/*" $ compile templateCompiler -- | Auxiliary compiler: generate a post list from a list of given posts, and -- add it to the current page under @$posts@ diff --git a/examples/hakyll/hakyll.hs b/examples/hakyll/hakyll.hs index c4f339c..60ddc33 100644 --- a/examples/hakyll/hakyll.hs +++ b/examples/hakyll/hakyll.hs @@ -6,35 +6,37 @@ import Text.Pandoc main :: IO () main = hakyll $ do - route "css/*" idRoute - compile "css/*" compressCssCompiler + match "css/*" $ do + route idRoute + compile compressCssCompiler -- Static directories - forM_ ["images/*", "examples/*", "reference/*"] $ \f -> do - route f idRoute - compile f copyFileCompiler + forM_ ["images/*", "examples/*", "reference/*"] $ \f -> match f $ do + route idRoute + compile copyFileCompiler -- Pages - forM_ pages $ \p -> do - route p $ setExtension "html" - compile p $ pageCompiler + forM_ pages $ \p -> match p $ do + route $ setExtension "html" + compile $ pageCompiler >>> requireA "sidebar.markdown" (setFieldA "sidebar" $ arr pageBody) >>> applyTemplateCompiler "templates/default.html" >>> relativizeUrlsCompiler -- Tutorial - route "tutorial.markdown" $ setExtension "html" - compile "tutorial.markdown" $ readPageCompiler - >>> pageRenderPandocWith defaultHakyllParserState withToc - >>> requireA "sidebar.markdown" (setFieldA "sidebar" $ arr pageBody) - >>> applyTemplateCompiler "templates/default.html" - >>> relativizeUrlsCompiler + match "tutorial.markdown" $ do + route $ setExtension "html" + compile $ readPageCompiler + >>> pageRenderPandocWith defaultHakyllParserState withToc + >>> requireA "sidebar.markdown" (setFieldA "sidebar" $ arr pageBody) + >>> applyTemplateCompiler "templates/default.html" + >>> relativizeUrlsCompiler -- Sidebar - compile "sidebar.markdown" pageCompiler + match "sidebar.markdown" $ compile pageCompiler -- Templates - compile "templates/*" templateCompiler + match "templates/*" $ compile templateCompiler where withToc = defaultHakyllWriterOptions { writerTableOfContents = True diff --git a/examples/hakyll/tutorial.markdown b/examples/hakyll/tutorial.markdown index 3b80db2..5c8a0c0 100644 --- a/examples/hakyll/tutorial.markdown +++ b/examples/hakyll/tutorial.markdown @@ -65,16 +65,18 @@ import Hakyll main :: IO () main = hakyll $ do - route "css/*" idRoute - compile "css/*" compressCssCompiler - - compile "templates/*" templateCompiler - - forM_ ["about.rst", "index.markdown", "code.lhs"] $ \page -> do - route page $ setExtension "html" - compile page $ pageCompiler - >>> applyTemplateCompiler "templates/default.html" - >>> relativizeUrlsCompiler + match "css/*" $ do + route idRoute + compile compressCssCompiler + + match "templates/*" $ compile templateCompiler + + forM_ ["about.rst", "index.markdown", "code.lhs"] $ \page -> + match page $ do + route $ setExtension "html" + compile $ pageCompiler + >>> applyTemplateCompiler "templates/default.html" + >>> relativizeUrlsCompiler ~~~~~ This is enough code to create a small brochure site! You can find all code @@ -111,12 +113,11 @@ main :: IO () main = hakyll $ do ~~~~~ -The `RulesM` monad is composed of a few functions. A first important one is -`route`: this creates a new rule for routing items. This rule is applied to all -items it matches -- and matching is done using the `"css/*"` [pattern]. -`idRoute` simply means that an item will be routed to it's own filename. For -example, `css/screen.css` will be routed to `css/screen.css` -- not very -exciting. +The `RulesM` monad is composed of a few functions. Seldomly, you want to apply a +compiler to *all* resources. You want to apply a compiler to certain files +instead. That's why the `match` function exists. First, let's handle the CSS of +our file. We use a `"css/*"` [Pattern] to match all files in the `css/` +directory. Note that a [Pattern] matches an [Identifier], it doesn't match filenames. @@ -124,7 +125,16 @@ Note that a [Pattern] matches an [Identifier], it doesn't match filenames. [Identifier]: /reference/Hakyll-Core-Identifier.html ~~~~~{.haskell} -route "css/*" idRoute +match "css/*" $ do +~~~~~ + +`route` creates a new rule for routing items. This rule is applied to all items +that are currently matched -- in this case, `"css/*"`. `idRoute` simply means +that an item will be routed to it's own filename. For example, `css/screen.css` +will be routed to `css/screen.css` -- not very exciting. + +~~~~~{.haskell} +route idRoute ~~~~~ Apart from specifying where the items should go (using `route`), we also have to @@ -135,12 +145,12 @@ good default compilers. The `compressCssCompiler` compiler will simply compress the CSS found in the files. ~~~~~{.haskell} -compile "css/*" compressCssCompiler +compile compressCssCompiler ~~~~~ Next, we're going to render some pages. We're going to style the results a little, so we're going to need a [Template]. We simply compile a template using -the `defaultTemplateRead` compiler, it's good enough in most cases. +the `templateCompiler` compiler, it's good enough in most cases. [Template]: /reference/Hakyll-Web-Template.html @@ -148,7 +158,7 @@ We don't use a route for these templates, after all, we don't want to route them anywhere, we just want to use them to style our pages a little. ~~~~~{.haskell} -compile "templates/*" templateCompiler +match "templates/*" $ compile templateCompiler ~~~~~ We can conclude that some rules do not *directly* add an output page on our @@ -164,13 +174,14 @@ manually). ~~~~~{.haskell} forM_ ["about.rst", "index.markdown", "code.lhs"] $ \page -> do + match page $ do ~~~~~ The pages all have different extensions. In our website, we only want to see `.html` files. Hakyll provides a route to do just that: ~~~~~{.haskell} -route page $ setExtension "html" +route setExtension "html" ~~~~~ The [Rules] reference page has a complete listing of the API used. @@ -189,7 +200,7 @@ reference page has some more readable information on this subject. [Compiler]: /reference/Hakyll-Core-Compiler.html ~~~~~{.haskell} -compile page $ pageCompiler +compile pageCompiler >>> applyTemplateCompiler "templates/default.html" >>> relativizeUrlsCompiler ~~~~~ diff --git a/examples/morepages/hakyll.hs b/examples/morepages/hakyll.hs index d62f8a8..c1b96e6 100644 --- a/examples/morepages/hakyll.hs +++ b/examples/morepages/hakyll.hs @@ -9,20 +9,21 @@ import Hakyll main :: IO () main = hakyll $ do -- Compress CSS - route "css/*" idRoute - compile "css/*" compressCssCompiler + match "css/*" $ do + route idRoute + compile compressCssCompiler -- Render static pages - forM_ ["about.markdown", "index.markdown", "products.markdown"] $ \p -> do - route p $ setExtension ".html" - compile p $ - pageCompiler - >>> requireA "footer.markdown" (setFieldA "footer" $ arr pageBody) - >>> applyTemplateCompiler "templates/default.html" - >>> relativizeUrlsCompiler + forM_ ["about.markdown", "index.markdown", "products.markdown"] $ \p -> + match p $ do + route $ setExtension ".html" + compile $ pageCompiler + >>> requireA "footer.markdown" (setFieldA "footer" $ arr pageBody) + >>> applyTemplateCompiler "templates/default.html" + >>> relativizeUrlsCompiler -- Compile footer - compile "footer.markdown" pageCompiler + match "footer.markdown" $ compile pageCompiler -- Read templates - compile "templates/*" templateCompiler + match "templates/*" $ compile templateCompiler diff --git a/examples/simpleblog/hakyll.hs b/examples/simpleblog/hakyll.hs index db4230f..270c3e3 100644 --- a/examples/simpleblog/hakyll.hs +++ b/examples/simpleblog/hakyll.hs @@ -11,42 +11,38 @@ import Hakyll main :: IO () main = hakyll $ do -- Compress CSS - route "css/*" idRoute - compile "css/*" compressCssCompiler + match "css/*" $ do + route idRoute + compile compressCssCompiler -- Render posts - route "posts/*" $ setExtension ".html" - compile "posts/*" $ - pageCompiler + match "posts/*" $ do + route $ setExtension ".html" + compile $ pageCompiler >>> applyTemplateCompiler "templates/post.html" >>> applyTemplateCompiler "templates/default.html" >>> relativizeUrlsCompiler -- Render posts list - route "posts.html" $ idRoute - create "posts.html" $ - constA mempty - >>> arr (setField "title" "All posts") - >>> requireAllA "posts/*" addPostList - >>> applyTemplateCompiler "templates/posts.html" - >>> applyTemplateCompiler "templates/default.html" - >>> relativizeUrlsCompiler + match "posts.html" $ route idRoute + create "posts.html" $ constA mempty + >>> arr (setField "title" "All posts") + >>> requireAllA "posts/*" addPostList + >>> applyTemplateCompiler "templates/posts.html" + >>> applyTemplateCompiler "templates/default.html" + >>> relativizeUrlsCompiler -- Index - route "index.html" idRoute - create "index.html" $ - constA mempty - >>> arr (setField "title" "Home") - >>> requireAllA "posts/*" (id *** arr (take 3 . reverse . sortByBaseName) >>> addPostList) - >>> applyTemplateCompiler "templates/index.html" - >>> applyTemplateCompiler "templates/default.html" - >>> relativizeUrlsCompiler + match "index.html" $ route idRoute + create "index.html" $ constA mempty + >>> arr (setField "title" "Home") + >>> requireAllA "posts/*" (id *** arr (take 3 . reverse . sortByBaseName) >>> addPostList) + >>> applyTemplateCompiler "templates/index.html" + >>> applyTemplateCompiler "templates/default.html" + >>> relativizeUrlsCompiler -- Read templates - compile "templates/*" templateCompiler - - -- End - return () + match "templates/*" $ compile templateCompiler -- | Auxiliary compiler: generate a post list from a list of given posts, and -- add it to the current page under @$posts@ diff --git a/examples/tagblog/hakyll.hs b/examples/tagblog/hakyll.hs index 976a017..53e635f 100644 --- a/examples/tagblog/hakyll.hs +++ b/examples/tagblog/hakyll.hs @@ -12,13 +12,14 @@ import Hakyll main :: IO () main = hakyll $ do -- Compress CSS - route "css/*" idRoute - compile "css/*" compressCssCompiler + match "css/*" $ do + route idRoute + compile compressCssCompiler -- Render posts - route "posts/*" $ setExtension ".html" - compile "posts/*" $ - pageCompiler + match "posts/*" $ do + route $ setExtension ".html" + compile $ pageCompiler >>> arr (renderDateField "date" "%B %e, %Y" "Date unknown") >>> renderTagsField "prettytags" (fromCaptureString "tags/*") >>> applyTemplateCompiler "templates/post.html" @@ -26,48 +27,43 @@ main = hakyll $ do >>> relativizeUrlsCompiler -- Render posts list - route "posts.html" $ idRoute - create "posts.html" $ - constA mempty - >>> arr (setField "title" "All posts") - >>> requireAllA "posts/*" addPostList - >>> applyTemplateCompiler "templates/posts.html" - >>> applyTemplateCompiler "templates/default.html" - >>> relativizeUrlsCompiler + match "posts.html" $ route idRoute + create "posts.html" $ constA mempty + >>> arr (setField "title" "All posts") + >>> requireAllA "posts/*" addPostList + >>> applyTemplateCompiler "templates/posts.html" + >>> applyTemplateCompiler "templates/default.html" + >>> relativizeUrlsCompiler -- Index - route "index.html" $ idRoute - create "index.html" $ - constA mempty - >>> arr (setField "title" "Home") - >>> requireA "tags" (setFieldA "tagcloud" (renderTagCloud')) - >>> requireAllA "posts/*" (id *** arr (take 3 . reverse . sortByBaseName) >>> addPostList) - >>> applyTemplateCompiler "templates/index.html" - >>> applyTemplateCompiler "templates/default.html" - >>> relativizeUrlsCompiler + match "index.html" $ route idRoute + create "index.html" $ constA mempty + >>> arr (setField "title" "Home") + >>> requireA "tags" (setFieldA "tagcloud" (renderTagCloud')) + >>> requireAllA "posts/*" (id *** arr (take 3 . reverse . sortByBaseName) >>> addPostList) + >>> applyTemplateCompiler "templates/index.html" + >>> applyTemplateCompiler "templates/default.html" + >>> relativizeUrlsCompiler -- Tags create "tags" $ requireAll "posts/*" (\_ ps -> readTags ps :: Tags String) -- Add a tag list compiler for every tag - route "tags/*" $ setExtension ".html" + match "tags/*" $ route $ setExtension ".html" metaCompile $ require_ "tags" >>> arr (M.toList . tagsMap) >>> arr (map (\(t, p) -> (tagIdentifier t, makeTagList t p))) -- Render RSS feed - route "rss.xml" $ idRoute + match "rss.xml" $ route idRoute create "rss.xml" $ requireAll_ "posts/*" >>> mapCompiler (arr $ copyBodyToField "description") >>> renderRss feedConfiguration -- Read templates - compile "templates/*" templateCompiler - - -- End - return () + match "templates/*" $ compile templateCompiler where renderTagCloud' :: Compiler (Tags String) String renderTagCloud' = renderTagCloud tagIdentifier 100 120 diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index bd78adf..7fe1754 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -245,7 +245,7 @@ requireAll_ :: (Binary a, Typeable a, Writable a) -> Compiler b [a] requireAll_ pattern = fromDependencies (const getDeps) >>> fromJob requireAll_' where - getDeps = matches pattern . map unResource . resourceList + getDeps = filterMatches pattern . map unResource . resourceList requireAll_' = const $ CompilerM $ do deps <- getDeps . compilerResourceProvider <$> ask mapM (unCompilerM . getDependency) deps diff --git a/src/Hakyll/Core/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs index a1e36df..28e23ad 100644 --- a/src/Hakyll/Core/Identifier/Pattern.hs +++ b/src/Hakyll/Core/Identifier/Pattern.hs @@ -1,4 +1,12 @@ -- | Module providing pattern matching and capturing on 'Identifier's. +-- 'Pattern's come in two kinds: +-- +-- * Simple glob patterns, like @foo\/*@; +-- +-- * Custom, arbitrary predicates of the type @Identifier -> Bool@. +-- +-- They both have advantages and disadvantages. By default, globs are used, +-- unless you construct your 'Pattern' using the 'predicate' function. -- -- A very simple pattern could be, for example, @foo\/bar@. This pattern will -- only match the exact @foo\/bar@ identifier. @@ -20,15 +28,16 @@ -- -- * @foo\/*.html@ will match all HTML files in the @foo\/@ directory. -- --- The 'match' function allows the user to get access to the elements captured +-- The 'capture' function allows the user to get access to the elements captured -- by the capture elements in the pattern. -- module Hakyll.Core.Identifier.Pattern ( Pattern - , parsePattern - , match - , doesMatch + , parseGlob + , predicate , matches + , filterMatches + , capture , fromCapture , fromCaptureString , fromCaptures @@ -38,7 +47,7 @@ import Data.List (isPrefixOf, inits, tails) import Control.Arrow ((&&&), (>>>)) import Control.Monad (msum) import Data.Maybe (isJust) -import Data.Monoid (mempty, mappend) +import Data.Monoid (Monoid, mempty, mappend) import GHC.Exts (IsString, fromString) @@ -46,23 +55,29 @@ import Hakyll.Core.Identifier -- | One base element of a pattern -- -data PatternComponent = Capture - | CaptureMany - | Literal String - deriving (Eq, Show) +data GlobComponent = Capture + | CaptureMany + | Literal String + deriving (Eq, Show) -- | Type that allows matching on identifiers -- -newtype Pattern = Pattern {unPattern :: [PatternComponent]} - deriving (Eq, Show) +data Pattern = Glob [GlobComponent] + | Predicate (Identifier -> Bool) instance IsString Pattern where - fromString = parsePattern + fromString = parseGlob + +instance Monoid Pattern where + mempty = Predicate (const True) + g@(Glob _) `mappend` x = Predicate (matches g) `mappend` x + x `mappend` g@(Glob _) = x `mappend` Predicate (matches g) + Predicate f `mappend` Predicate g = Predicate $ \i -> f i && g i -- | Parse a pattern from a string -- -parsePattern :: String -> Pattern -parsePattern = Pattern . parse' -- undefined -- Pattern . map toPattern . unIdentifier . parseIdentifier +parseGlob :: String -> Pattern +parseGlob = Glob . parse' where parse' str = let (chunk, rest) = break (`elem` "\\*") str @@ -72,20 +87,25 @@ parsePattern = Pattern . parse' -- undefined -- Pattern . map toPattern . unIden ('*' : xs) -> Literal chunk : Capture : parse' xs xs -> Literal chunk : Literal xs : [] --- | Match an identifier against a pattern, generating a list of captures +-- | Create a 'Pattern' from an arbitrary predicate +-- +-- Example: -- -match :: Pattern -> Identifier -> Maybe [Identifier] -match p (Identifier i) = fmap (map Identifier) $ match' (unPattern p) i +-- > predicate (\i -> matches "foo/*" i && not (matches "foo/bar" i)) +-- +predicate :: (Identifier -> Bool) -> Pattern +predicate = Predicate -- | Check if an identifier matches a pattern -- -doesMatch :: Pattern -> Identifier -> Bool -doesMatch p = isJust . match p +matches :: Pattern -> Identifier -> Bool +matches (Glob p) = isJust . capture (Glob p) +matches (Predicate p) = (p $) -- | Given a list of identifiers, retain only those who match the given pattern -- -matches :: Pattern -> [Identifier] -> [Identifier] -matches p = filter (doesMatch p) +filterMatches :: Pattern -> [Identifier] -> [Identifier] +filterMatches = filter . matches -- | Split a list at every possible point, generate a list of (init, tail) -- cases. The result is sorted with inits decreasing in length. @@ -93,30 +113,35 @@ matches p = filter (doesMatch p) splits :: [a] -> [([a], [a])] splits = inits &&& tails >>> uncurry zip >>> reverse --- | Internal verion of 'match' +-- | Match a glob against a pattern, generating a list of captures +-- +capture :: Pattern -> Identifier -> Maybe [Identifier] +capture (Glob p) (Identifier i) = fmap (map Identifier) $ capture' p i +capture (Predicate _) _ = Nothing + +-- | Internal verion of 'capture' -- -match' :: [PatternComponent] -> String -> Maybe [String] -match' [] [] = Just [] -- An empty match -match' [] _ = Nothing -- No match --- match' _ [] = Nothing -- No match -match' (Literal l : ms) str +capture' :: [GlobComponent] -> String -> Maybe [String] +capture' [] [] = Just [] -- An empty match +capture' [] _ = Nothing -- No match +capture' (Literal l : ms) str -- Match the literal against the string - | l `isPrefixOf` str = match' ms $ drop (length l) str + | l `isPrefixOf` str = capture' ms $ drop (length l) str | otherwise = Nothing -match' (Capture : ms) str = +capture' (Capture : ms) str = -- Match until the next / let (chunk, rest) = break (== '/') str - in msum $ [ fmap (i :) (match' ms (t ++ rest)) | (i, t) <- splits chunk ] -match' (CaptureMany : ms) str = + in msum $ [ fmap (i :) (capture' ms (t ++ rest)) | (i, t) <- splits chunk ] +capture' (CaptureMany : ms) str = -- Match everything - msum $ [ fmap (i :) (match' ms t) | (i, t) <- splits str ] + msum $ [ fmap (i :) (capture' ms t) | (i, t) <- splits str ] -- | Create an identifier from a pattern by filling in the captures with a given -- string -- -- Example: -- --- > fromCapture (parsePattern "tags/*") (parseIdentifier "foo") +-- > fromCapture (parseGlob "tags/*") (parseIdentifier "foo") -- -- Result: -- @@ -128,7 +153,7 @@ fromCapture pattern = fromCaptures pattern . repeat -- | Simplified version of 'fromCapture' which takes a 'String' instead of an -- 'Identifier' -- --- > fromCaptureString (parsePattern "tags/*") "foo" +-- > fromCaptureString (parseGlob "tags/*") "foo" -- -- Result: -- @@ -141,11 +166,19 @@ fromCaptureString pattern = fromCapture pattern . parseIdentifier -- given list of strings -- 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: " +fromCaptures (Glob p) = fromCaptures' p +fromCaptures (Predicate _) = error $ + "Hakyll.Core.Identifier.Pattern.fromCaptures: fromCaptures called on a " ++ + "predicate instead of a glob" + +-- | Internally used version of 'fromCaptures' +-- +fromCaptures' :: [GlobComponent] -> [Identifier] -> Identifier +fromCaptures' [] _ = mempty +fromCaptures' (m : ms) [] = case m of + Literal l -> Identifier l `mappend` fromCaptures' 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 +fromCaptures' (m : ms) ids@(i : is) = case m of + Literal l -> Identifier l `mappend` fromCaptures' ms ids + _ -> i `mappend` fromCaptures' ms is diff --git a/src/Hakyll/Core/Routes.hs b/src/Hakyll/Core/Routes.hs index fcab28d..abbd0a7 100644 --- a/src/Hakyll/Core/Routes.hs +++ b/src/Hakyll/Core/Routes.hs @@ -30,7 +30,7 @@ module Hakyll.Core.Routes , runRoutes , idRoute , setExtension - , ifMatch + , matchRoute , customRoute , gsubRoute , composeRoutes @@ -85,15 +85,15 @@ setExtension :: String -> Routes setExtension extension = Routes $ fmap (`replaceExtension` extension) . unRoutes idRoute --- | Modify a route: apply the route if the identifier matches the given --- pattern, fail otherwise. +-- | Apply the route if the identifier matches the given pattern, fail +-- otherwise -- -ifMatch :: Pattern -> Routes -> Routes -ifMatch pattern (Routes route) = Routes $ \id' -> - if doesMatch pattern id' then route id' - else Nothing +matchRoute :: Pattern -> Routes -> Routes +matchRoute pattern (Routes route) = Routes $ \id' -> + if matches pattern id' then route id' else Nothing --- | Create a custom route. This should almost always be used with 'ifMatch'. +-- | Create a custom route. This should almost always be used with +-- 'matchRoute' -- customRoute :: (Identifier -> FilePath) -> Routes customRoute f = Routes $ Just . f diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index eba3fb9..19df85e 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -7,13 +7,18 @@ -- A typical usage example would be: -- -- > main = hakyll $ do --- > route "posts/*" (setExtension "html") --- > compile "posts/*" someCompiler +-- > match "posts/*" $ do +-- > route (setExtension "html") +-- > compile someCompiler +-- > match "css/*" $ do +-- > route idRoute +-- > compile compressCssCompiler -- {-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-} module Hakyll.Core.Rules ( RulesM , Rules + , match , compile , create , route @@ -23,10 +28,10 @@ module Hakyll.Core.Rules import Control.Applicative ((<$>)) import Control.Monad.Writer (tell) -import Control.Monad.Reader (ask) +import Control.Monad.Reader (ask, local) import Control.Arrow (second, (>>>), arr, (>>^)) import Control.Monad.State (get, put) -import Data.Monoid (mempty) +import Data.Monoid (mempty, mappend) import qualified Data.Set as S import Data.Typeable (Typeable) @@ -63,21 +68,32 @@ tellResources :: [Resource] -> Rules tellResources resources = RulesM $ tell $ RuleSet mempty mempty $ S.fromList resources +-- | Only compile/route items satisfying the given predicate +-- +match :: Pattern -> Rules -> Rules +match pattern = RulesM . local addPredicate . unRulesM + where + addPredicate env = env + { rulesPattern = rulesPattern env `mappend` pattern + } + -- | Add a compilation rule to the rules. -- --- This instructs all resources matching the given pattern to be compiled using --- the given compiler. When no resources match the given pattern, nothing will --- happen. In this case, you might want to have a look at 'create'. +-- This instructs all resources to be compiled using the given compiler. When +-- no resources match the current selection, nothing will happen. In this case, +-- you might want to have a look at 'create'. -- compile :: (Binary a, Typeable a, Writable a) - => Pattern -> Compiler Resource a -> Rules -compile pattern compiler = RulesM $ do - identifiers <- matches pattern . map unResource . resourceList <$> ask + => Compiler Resource a -> Rules +compile compiler = RulesM $ do + pattern <- rulesPattern <$> ask + provider <- rulesResourceProvider <$> ask + let ids = filterMatches pattern $ map unResource $ resourceList provider unRulesM $ do - tellCompilers $ flip map identifiers $ \identifier -> + tellCompilers $ flip map ids $ \identifier -> (identifier, constA (Resource identifier) >>> compiler) - tellResources $ map Resource identifiers - + tellResources $ map Resource ids + -- | Add a compilation rule -- -- This sets a compiler for the given identifier. No resource is needed, since @@ -91,10 +107,12 @@ create identifier compiler = tellCompilers [(identifier, compiler)] -- | Add a route. -- --- This adds a route for all items matching the given pattern. +-- This adds a route for all items matching the current pattern. -- -route :: Pattern -> Routes -> Rules -route pattern route' = tellRoute $ ifMatch pattern route' +route :: Routes -> Rules +route route' = RulesM $ do + pattern <- rulesPattern <$> ask + unRulesM $ tellRoute $ matchRoute pattern route' -- | Apart from regular compilers, one is also able to specify metacompilers. -- Metacompilers are a special class of compilers: they are compilers which diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs index 2895257..592194d 100644 --- a/src/Hakyll/Core/Rules/Internal.hs +++ b/src/Hakyll/Core/Rules/Internal.hs @@ -5,6 +5,7 @@ module Hakyll.Core.Rules.Internal ( CompileRule (..) , RuleSet (..) , RuleState (..) + , RuleEnvironment (..) , RulesM (..) , Rules , runRules @@ -19,6 +20,7 @@ import Data.Set (Set) import Hakyll.Core.ResourceProvider import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Compiler.Internal import Hakyll.Core.Routes import Hakyll.Core.CompiledItem @@ -55,10 +57,17 @@ data RuleState = RuleState { rulesMetaCompilerIndex :: Int } deriving (Show) +-- | Rule environment +-- +data RuleEnvironment = RuleEnvironment + { rulesResourceProvider :: ResourceProvider + , rulesPattern :: Pattern + } + -- | The monad used to compose rules -- newtype RulesM a = RulesM - { unRulesM :: ReaderT ResourceProvider (WriterT RuleSet (State RuleState)) a + { unRulesM :: ReaderT RuleEnvironment (WriterT RuleSet (State RuleState)) a } deriving (Monad, Functor, Applicative) -- | Simplification of the RulesM type; usually, it will not return any @@ -70,6 +79,9 @@ type Rules = RulesM () -- runRules :: Rules -> ResourceProvider -> RuleSet runRules rules provider = - evalState (execWriterT $ runReaderT (unRulesM rules) provider) state + evalState (execWriterT $ runReaderT (unRulesM rules) env) state where state = RuleState {rulesMetaCompilerIndex = 0} + env = RuleEnvironment { rulesResourceProvider = provider + , rulesPattern = mempty + } diff --git a/tests/Hakyll/Core/Identifier/Tests.hs b/tests/Hakyll/Core/Identifier/Tests.hs index 64b5abc..5b5d34d 100644 --- a/tests/Hakyll/Core/Identifier/Tests.hs +++ b/tests/Hakyll/Core/Identifier/Tests.hs @@ -10,18 +10,18 @@ import Hakyll.Core.Identifier.Pattern import TestSuite.Util tests :: [Test] -tests = fromAssertions "match" - [ Just ["bar"] @=? match "foo/**" "foo/bar" - , Just ["foo/bar"] @=? match "**" "foo/bar" - , Nothing @=? match "*" "foo/bar" - , Just [] @=? match "foo" "foo" - , Just ["foo"] @=? match "*/bar" "foo/bar" - , Just ["foo/bar"] @=? match "**/qux" "foo/bar/qux" - , Just ["foo/bar", "qux"] @=? match "**/*" "foo/bar/qux" - , Just ["foo", "bar/qux"] @=? match "*/**" "foo/bar/qux" - , Just ["foo"] @=? match "*.html" "foo.html" - , Nothing @=? match "*.html" "foo/bar.html" - , Just ["foo/bar"] @=? match "**.html" "foo/bar.html" - , Just ["foo/bar", "wut"] @=? match "**/qux/*" "foo/bar/qux/wut" - , Just ["lol", "fun/large"] @=? match "*cat/**.jpg" "lolcat/fun/large.jpg" +tests = fromAssertions "capture" + [ Just ["bar"] @=? capture "foo/**" "foo/bar" + , Just ["foo/bar"] @=? capture "**" "foo/bar" + , Nothing @=? capture "*" "foo/bar" + , Just [] @=? capture "foo" "foo" + , Just ["foo"] @=? capture "*/bar" "foo/bar" + , Just ["foo/bar"] @=? capture "**/qux" "foo/bar/qux" + , Just ["foo/bar", "qux"] @=? capture "**/*" "foo/bar/qux" + , Just ["foo", "bar/qux"] @=? capture "*/**" "foo/bar/qux" + , Just ["foo"] @=? capture "*.html" "foo.html" + , Nothing @=? capture "*.html" "foo/bar.html" + , Just ["foo/bar"] @=? capture "**.html" "foo/bar.html" + , Just ["foo/bar", "wut"] @=? capture "**/qux/*" "foo/bar/qux/wut" + , Just ["lol", "fun/large"] @=? capture "*cat/**.jpg" "lolcat/fun/large.jpg" ] |