2011-02-11 12:30:55 +00:00
|
|
|
-- | This module provides a declarative DSL in which the user can specify the
|
|
|
|
-- different rules used to run the compilers.
|
|
|
|
--
|
|
|
|
-- The convention is to just list all items in the 'RulesM' monad, routes and
|
|
|
|
-- compilation rules.
|
|
|
|
--
|
|
|
|
-- A typical usage example would be:
|
|
|
|
--
|
|
|
|
-- > main = hakyll $ do
|
2011-04-05 09:58:26 +00:00
|
|
|
-- > match "posts/*" $ do
|
|
|
|
-- > route (setExtension "html")
|
|
|
|
-- > compile someCompiler
|
|
|
|
-- > match "css/*" $ do
|
|
|
|
-- > route idRoute
|
|
|
|
-- > compile compressCssCompiler
|
2010-12-25 18:37:21 +00:00
|
|
|
--
|
2011-01-30 09:44:42 +00:00
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}
|
2010-12-25 18:37:21 +00:00
|
|
|
module Hakyll.Core.Rules
|
2011-02-11 12:30:55 +00:00
|
|
|
( RulesM
|
2010-12-25 18:37:21 +00:00
|
|
|
, Rules
|
2011-04-05 09:58:26 +00:00
|
|
|
, match
|
2010-12-25 18:37:21 +00:00
|
|
|
, compile
|
|
|
|
, create
|
|
|
|
, route
|
2011-01-30 09:44:42 +00:00
|
|
|
, metaCompile
|
|
|
|
, metaCompileWith
|
2010-12-25 18:37:21 +00:00
|
|
|
) where
|
|
|
|
|
2011-02-11 12:30:55 +00:00
|
|
|
import Control.Applicative ((<$>))
|
|
|
|
import Control.Monad.Writer (tell)
|
2011-04-04 18:49:22 +00:00
|
|
|
import Control.Monad.Reader (ask, local)
|
2011-01-07 11:12:13 +00:00
|
|
|
import Control.Arrow (second, (>>>), arr, (>>^))
|
2011-02-11 12:30:55 +00:00
|
|
|
import Control.Monad.State (get, put)
|
2011-04-05 09:58:26 +00:00
|
|
|
import Data.Monoid (mempty, mappend)
|
2011-02-15 17:32:55 +00:00
|
|
|
import qualified Data.Set as S
|
2010-12-28 10:12:45 +00:00
|
|
|
|
|
|
|
import Data.Typeable (Typeable)
|
|
|
|
import Data.Binary (Binary)
|
2010-12-25 18:37:21 +00:00
|
|
|
|
2011-04-05 20:14:49 +00:00
|
|
|
import Hakyll.Core.Resource
|
|
|
|
import Hakyll.Core.Resource.Provider
|
2010-12-25 18:37:21 +00:00
|
|
|
import Hakyll.Core.Identifier
|
|
|
|
import Hakyll.Core.Identifier.Pattern
|
2011-01-07 11:12:13 +00:00
|
|
|
import Hakyll.Core.Compiler.Internal
|
2011-02-03 15:07:49 +00:00
|
|
|
import Hakyll.Core.Routes
|
2010-12-28 10:12:45 +00:00
|
|
|
import Hakyll.Core.CompiledItem
|
|
|
|
import Hakyll.Core.Writable
|
2011-02-11 12:30:55 +00:00
|
|
|
import Hakyll.Core.Rules.Internal
|
2011-02-11 16:52:19 +00:00
|
|
|
import Hakyll.Core.Util.Arrow
|
2010-12-25 18:37:21 +00:00
|
|
|
|
|
|
|
-- | Add a route
|
|
|
|
--
|
2011-02-03 15:07:49 +00:00
|
|
|
tellRoute :: Routes -> Rules
|
2011-02-15 17:32:55 +00:00
|
|
|
tellRoute route' = RulesM $ tell $ RuleSet route' mempty mempty
|
2010-12-25 18:37:21 +00:00
|
|
|
|
|
|
|
-- | Add a number of compilers
|
|
|
|
--
|
2011-01-07 11:12:13 +00:00
|
|
|
tellCompilers :: (Binary a, Typeable a, Writable a)
|
2010-12-29 21:59:38 +00:00
|
|
|
=> [(Identifier, Compiler () a)]
|
2010-12-28 10:12:45 +00:00
|
|
|
-> Rules
|
2011-02-15 17:32:55 +00:00
|
|
|
tellCompilers compilers = RulesM $ tell $ RuleSet mempty compilers' mempty
|
2010-12-28 10:12:45 +00:00
|
|
|
where
|
2011-02-15 17:32:55 +00:00
|
|
|
compilers' = map (second boxCompiler) compilers
|
2011-01-07 13:34:31 +00:00
|
|
|
boxCompiler = (>>> arr compiledItem >>> arr CompileRule)
|
2010-12-25 18:37:21 +00:00
|
|
|
|
2011-02-15 17:32:55 +00:00
|
|
|
-- | Add resources
|
|
|
|
--
|
|
|
|
tellResources :: [Resource]
|
|
|
|
-> Rules
|
|
|
|
tellResources resources = RulesM $ tell $ RuleSet mempty mempty $ S.fromList resources
|
|
|
|
|
2011-04-04 18:49:22 +00:00
|
|
|
-- | Only compile/route items satisfying the given predicate
|
|
|
|
--
|
2011-04-05 09:58:26 +00:00
|
|
|
match :: Pattern -> Rules -> Rules
|
|
|
|
match pattern = RulesM . local addPredicate . unRulesM
|
2011-04-04 18:49:22 +00:00
|
|
|
where
|
|
|
|
addPredicate env = env
|
2011-04-05 09:58:26 +00:00
|
|
|
{ rulesPattern = rulesPattern env `mappend` pattern
|
2011-04-04 18:49:22 +00:00
|
|
|
}
|
|
|
|
|
2011-02-11 12:30:55 +00:00
|
|
|
-- | Add a compilation rule to the rules.
|
2010-12-25 18:37:21 +00:00
|
|
|
--
|
2011-04-04 18:49:22 +00:00
|
|
|
-- 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'.
|
2010-12-25 18:37:21 +00:00
|
|
|
--
|
2010-12-28 10:12:45 +00:00
|
|
|
compile :: (Binary a, Typeable a, Writable a)
|
2011-04-04 18:49:22 +00:00
|
|
|
=> Compiler Resource a -> Rules
|
|
|
|
compile compiler = RulesM $ do
|
2011-04-05 09:58:26 +00:00
|
|
|
pattern <- rulesPattern <$> ask
|
2011-04-04 18:49:22 +00:00
|
|
|
provider <- rulesResourceProvider <$> ask
|
2011-04-05 09:58:26 +00:00
|
|
|
let ids = filterMatches pattern $ map unResource $ resourceList provider
|
2011-02-15 17:32:55 +00:00
|
|
|
unRulesM $ do
|
2011-04-05 09:58:26 +00:00
|
|
|
tellCompilers $ flip map ids $ \identifier ->
|
2011-02-15 17:32:55 +00:00
|
|
|
(identifier, constA (Resource identifier) >>> compiler)
|
2011-04-05 09:58:26 +00:00
|
|
|
tellResources $ map Resource ids
|
2011-04-04 18:49:22 +00:00
|
|
|
|
2010-12-25 18:37:21 +00:00
|
|
|
-- | Add a compilation rule
|
|
|
|
--
|
2011-02-11 12:30:55 +00:00
|
|
|
-- This sets a compiler for the given identifier. No resource is needed, since
|
2011-02-26 10:07:46 +00:00
|
|
|
-- we are creating the item from scratch. This is useful if you want to create a
|
|
|
|
-- page on your site that just takes content from other items -- but has no
|
|
|
|
-- actual content itself.
|
2010-12-25 18:37:21 +00:00
|
|
|
--
|
2010-12-28 10:12:45 +00:00
|
|
|
create :: (Binary a, Typeable a, Writable a)
|
2010-12-29 21:59:38 +00:00
|
|
|
=> Identifier -> Compiler () a -> Rules
|
2011-01-07 11:12:13 +00:00
|
|
|
create identifier compiler = tellCompilers [(identifier, compiler)]
|
2010-12-25 18:37:21 +00:00
|
|
|
|
2011-02-11 12:30:55 +00:00
|
|
|
-- | Add a route.
|
|
|
|
--
|
2011-04-04 18:49:22 +00:00
|
|
|
-- This adds a route for all items matching the current pattern.
|
2010-12-25 18:37:21 +00:00
|
|
|
--
|
2011-04-04 18:49:22 +00:00
|
|
|
route :: Routes -> Rules
|
|
|
|
route route' = RulesM $ do
|
2011-04-05 09:58:26 +00:00
|
|
|
pattern <- rulesPattern <$> ask
|
|
|
|
unRulesM $ tellRoute $ matchRoute pattern route'
|
2011-01-07 11:12:13 +00:00
|
|
|
|
2011-02-11 12:30:55 +00:00
|
|
|
-- | Apart from regular compilers, one is also able to specify metacompilers.
|
|
|
|
-- Metacompilers are a special class of compilers: they are compilers which
|
|
|
|
-- produce other compilers.
|
|
|
|
--
|
2011-02-26 10:07:46 +00:00
|
|
|
-- This is needed when the list of compilers depends on something we cannot know
|
|
|
|
-- before actually running other compilers. The most typical example is if we
|
|
|
|
-- have a blogpost using tags.
|
|
|
|
--
|
|
|
|
-- Every post has a collection of tags. For example,
|
|
|
|
--
|
|
|
|
-- > post1: code, haskell
|
|
|
|
-- > post2: code, random
|
|
|
|
--
|
|
|
|
-- Now, we want to create a list of posts for every tag. We cannot write this
|
|
|
|
-- down in our 'Rules' DSL directly, since we don't know what tags the different
|
|
|
|
-- posts will have -- we depend on information that will only be available when
|
|
|
|
-- we are actually compiling the pages.
|
|
|
|
--
|
|
|
|
-- The solution is simple, using 'metaCompile', we can add a compiler that will
|
|
|
|
-- parse the pages and produce the compilers needed for the different tag pages.
|
|
|
|
--
|
2011-02-11 12:30:55 +00:00
|
|
|
-- And indeed, we can see that the first argument to 'metaCompile' is a
|
|
|
|
-- 'Compiler' which produces a list of ('Identifier', 'Compiler') pairs. The
|
|
|
|
-- idea is simple: 'metaCompile' produces a list of compilers, and the
|
|
|
|
-- corresponding identifiers.
|
|
|
|
--
|
|
|
|
-- For simple hakyll systems, it is no need for this construction. More
|
|
|
|
-- formally, it is only needed when the content of one or more items determines
|
|
|
|
-- which items must be rendered.
|
2011-01-07 11:12:13 +00:00
|
|
|
--
|
2011-01-30 09:44:42 +00:00
|
|
|
metaCompile :: (Binary a, Typeable a, Writable a)
|
|
|
|
=> Compiler () [(Identifier, Compiler () a)]
|
|
|
|
-- ^ Compiler generating the other compilers
|
|
|
|
-> Rules
|
|
|
|
-- ^ Resulting rules
|
|
|
|
metaCompile compiler = RulesM $ do
|
|
|
|
-- Create an identifier from the state
|
|
|
|
state <- get
|
|
|
|
let index = rulesMetaCompilerIndex state
|
|
|
|
id' = fromCaptureString "Hakyll.Core.Rules.metaCompile/*" (show index)
|
|
|
|
|
|
|
|
-- Update the state with a new identifier
|
|
|
|
put $ state {rulesMetaCompilerIndex = index + 1}
|
|
|
|
|
|
|
|
-- Fallback to 'metaCompileWith' with now known identifier
|
|
|
|
unRulesM $ metaCompileWith id' compiler
|
|
|
|
|
|
|
|
-- | Version of 'metaCompile' that allows you to specify a custom identifier for
|
|
|
|
-- the metacompiler.
|
|
|
|
--
|
|
|
|
metaCompileWith :: (Binary a, Typeable a, Writable a)
|
|
|
|
=> Identifier
|
|
|
|
-- ^ Identifier for this compiler
|
|
|
|
-> Compiler () [(Identifier, Compiler () a)]
|
|
|
|
-- ^ Compiler generating the other compilers
|
|
|
|
-> Rules
|
|
|
|
-- ^ Resulting rules
|
2011-02-15 17:32:55 +00:00
|
|
|
metaCompileWith identifier compiler = RulesM $ tell $
|
|
|
|
RuleSet mempty compilers mempty
|
2011-01-07 11:12:13 +00:00
|
|
|
where
|
2011-01-07 18:17:14 +00:00
|
|
|
makeRule = MetaCompileRule . map (second box)
|
2011-02-15 17:32:55 +00:00
|
|
|
compilers = [(identifier, compiler >>> arr makeRule )]
|
2011-01-07 18:17:14 +00:00
|
|
|
box = (>>> fromDependency identifier >>^ CompileRule . compiledItem)
|