yogsototh/hakyll
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'nested-rules'

Browse source
This commit is contained in:
Jasper Van der Jeugt 2011-04-05 22:02:40 +02:00
commit 433f36e6f3
13 changed files with 283 additions and 216 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
examples/brochure/hakyll.hs
View file

@ -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

48
examples/feedblog/hakyll.hs
View file

@ -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@

34
examples/hakyll/hakyll.hs
View file

@ -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

51
examples/hakyll/tutorial.markdown
View file

@ -65,16 +65,18 @@ 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
~~~~~
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
~~~~~

23
examples/morepages/hakyll.hs
View file

@ -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

46
examples/simpleblog/hakyll.hs
View file

@ -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@

52
examples/tagblog/hakyll.hs
View file

@ -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

2
src/Hakyll/Core/Compiler.hs
View file

@ -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

115
src/Hakyll/Core/Identifier/Pattern.hs
View file

@ -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
--
match :: Pattern -> Identifier -> Maybe [Identifier]
match p (Identifier i) = fmap (map Identifier) $ match' (unPattern p) i
-- Example:
--
-- > 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
--
match' :: [PatternComponent] -> String -> Maybe [String]
match' [] [] = Just [] -- An empty match
match' [] _ = Nothing -- No match
-- match' _ [] = Nothing -- No match
match' (Literal l : ms) str
capture :: Pattern -> Identifier -> Maybe [Identifier]
capture (Glob p) (Identifier i) = fmap (map Identifier) $ capture' p i
capture (Predicate _) _ = Nothing
-- | Internal verion of 'capture'
--
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

16
src/Hakyll/Core/Routes.hs
View file

@ -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

50
src/Hakyll/Core/Rules.hs
View file

@ -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

16
src/Hakyll/Core/Rules/Internal.hs
View file

@ -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
}

28
tests/Hakyll/Core/Identifier/Tests.hs
View file

@ -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"
]