@@ -1,7 +1,7 @@
11-- | This module provides a monadic DSL in which the user can specify the
22-- different rules used to run the compilers
33--
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}
55module Hakyll.Core.Rules
66 ( CompileRule (..)
77 , RuleSet (..)
@@ -11,13 +11,15 @@ module Hakyll.Core.Rules
1111 , compile
1212 , create
1313 , route
14− , addCompilers
14+ , metaCompile
15+ , metaCompileWith
1516 ) where
1617
1718import Control.Applicative (Applicative, (<$>))
1819import Control.Monad.Writer
1920import Control.Monad.Reader
2021import Control.Arrow (second, (>>>), arr, (>>^))
22+import Control.Monad.State
2123
2224import Data.Typeable (Typeable)
2325import Data.Binary (Binary)
@@ -52,10 +54,16 @@ instance Monoid RuleSet where
5254 mappend (RuleSet r1 c1) (RuleSet r2 c2) =
5355 RuleSet (mappend r1 r2) (mappend c1 c2)
5456
57+-- | Rule state
58+--
59+data RuleState = RuleState
60+ { rulesMetaCompilerIndex :: Int
61+ } deriving (Show)
62+
5563-- | The monad used to compose rules
5664--
5765newtype RulesM a = RulesM
58− { unRulesM :: ReaderT ResourceProvider (Writer RuleSet) a
66+ { unRulesM :: ReaderT ResourceProvider (WriterT RuleSet (State RuleState)) a
5967 } deriving (Monad, Functor, Applicative)
6068
6169-- | Simplification of the RulesM type; usually, it will not return any
@@ -66,7 +74,10 @@ type Rules = RulesM ()
6674-- | Run a Rules monad, resulting in a 'RuleSet'
6775--
6876runRules :: Rules -> ResourceProvider -> RuleSet
69−runRules rules provider = execWriter $ runReaderT (unRulesM rules) provider
77+runRules rules provider =
78+ evalState (execWriterT $ runReaderT (unRulesM rules) provider) state
79+ where
80+ state = RuleState {rulesMetaCompilerIndex = 0}
7081
7182-- | Add a route
7283--
@@ -109,16 +120,34 @@ route pattern route' = tellRoute $ ifMatch pattern route'
109120
110121-- | Add a compiler that produces other compilers over time
111122--
112−-- TODO: Rename to metaCompile? Auto-generate identifier?
113−--
114−addCompilers :: (Binary a, Typeable a, Writable a)
115− => Identifier
116− -- ^ Identifier for this compiler
117− -> Compiler () [(Identifier, Compiler () a)]
118− -- ^ Compiler generating the other compilers
119− -> Rules
120− -- ^ Resulting rules
121−addCompilers identifier compiler = RulesM $ tell $ RuleSet mempty
123+metaCompile :: (Binary a, Typeable a, Writable a)
124+ => Compiler () [(Identifier, Compiler () a)]
125+ -- ^ Compiler generating the other compilers
126+ -> Rules
127+ -- ^ Resulting rules
128+metaCompile compiler = RulesM $ do
129+ -- Create an identifier from the state
130+ state <- get
131+ let index = rulesMetaCompilerIndex state
132+ id' = fromCaptureString "Hakyll.Core.Rules.metaCompile/*" (show index)
133+
134+ -- Update the state with a new identifier
135+ put $ state {rulesMetaCompilerIndex = index + 1}
136+
137+ -- Fallback to 'metaCompileWith' with now known identifier
138+ unRulesM $ metaCompileWith id' compiler
139+
140+-- | Version of 'metaCompile' that allows you to specify a custom identifier for
141+-- the metacompiler.
142+--
143+metaCompileWith :: (Binary a, Typeable a, Writable a)
144+ => Identifier
145+ -- ^ Identifier for this compiler
146+ -> Compiler () [(Identifier, Compiler () a)]
147+ -- ^ Compiler generating the other compilers
148+ -> Rules
149+ -- ^ Resulting rules
150+metaCompileWith identifier compiler = RulesM $ tell $ RuleSet mempty
122151 [(identifier, compiler >>> arr makeRule )]
123152 where
124153 makeRule = MetaCompileRule . map (second box)