Rules will be in IO...

4 files changed, 108 insertions, 74 deletions

diff --git a/src/Hakyll/Core/Resource/Modified.hs b/src/Hakyll/Core/Resource/Modified.hs
index 1dbaf76..8492108 100644
--- a/src/Hakyll/Core/Resource/Modified.hs
+++ b/src/Hakyll/Core/Resource/Modified.hs
@@ -42,7 +42,7 @@ resourceModified rp r
                     <*> resourceModified rp (resourceMetadataResource r)
                 modifyIORef cacheRef (M.insert r m)
 
-                -- Important!
+                -- Important! (But ugly)
                 when m $ resourceInvalidateMetadataCache rp r
 
                 return m
diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs
index bef480a..ff68c56 100644
--- a/src/Hakyll/Core/Rules.hs
+++ b/src/Hakyll/Core/Rules.hs
@@ -1,3 +1,4 @@
+--------------------------------------------------------------------------------
 -- | This module provides a declarative DSL in which the user can specify the
 -- different rules used to run the compilers.
 --
@@ -13,8 +14,8 @@
 -- >     match "css/*" $ do
 -- >         route   idRoute
 -- >         compile compressCssCompiler
---
-{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
 module Hakyll.Core.Rules
     ( RulesM
     , Rules
@@ -29,35 +30,43 @@ module Hakyll.Core.Rules
     , freshIdentifier
     ) where
 
-import Control.Applicative ((<$>))
-import Control.Monad.Writer (tell)
-import Control.Monad.Reader (ask, local)
-import Control.Arrow ((>>>), arr, (>>^), (***))
-import Control.Monad.State (get, put)
-import Data.Monoid (mempty, mappend)
-import qualified Data.Set as S
-
-import Data.Typeable (Typeable)
-import Data.Binary (Binary)
-
-import Hakyll.Core.Resource
-import Hakyll.Core.Resource.Provider
-import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.Compiler.Internal
-import Hakyll.Core.Routes
-import Hakyll.Core.CompiledItem
-import Hakyll.Core.Writable
-import Hakyll.Core.Rules.Internal
-import Hakyll.Core.Util.Arrow
 
+--------------------------------------------------------------------------------
+import           Control.Applicative            ((<$>))
+import           Control.Arrow                  (arr, (***), (>>>), (>>^))
+import           Control.Monad.Reader           (ask, local)
+import           Control.Monad.State            (get, put)
+import           Control.Monad.Writer           (tell)
+import           Data.Monoid                    (mappend, mempty)
+import qualified Data.Set                       as S
+
+
+--------------------------------------------------------------------------------
+import           Data.Binary                    (Binary)
+import           Data.Typeable                  (Typeable)
+
+
+--------------------------------------------------------------------------------
+import           Hakyll.Core.CompiledItem
+import           Hakyll.Core.Compiler.Internal
+import           Hakyll.Core.Identifier
+import           Hakyll.Core.Identifier.Pattern
+import           Hakyll.Core.Resource
+import           Hakyll.Core.Resource.Provider
+import           Hakyll.Core.Routes
+import           Hakyll.Core.Rules.Internal
+import           Hakyll.Core.Util.Arrow
+import           Hakyll.Core.Writable
+
+
+--------------------------------------------------------------------------------
 -- | Add a route
---
 tellRoute :: Routes -> Rules
 tellRoute route' = RulesM $ tell $ RuleSet route' mempty mempty
 
+
+--------------------------------------------------------------------------------
 -- | Add a number of compilers
---
 tellCompilers :: (Binary a, Typeable a, Writable a)
              => [(Identifier a, Compiler () a)]
              -> Rules
@@ -68,15 +77,17 @@ tellCompilers compilers = RulesM $ do
   where
     boxCompiler = (>>> arr compiledItem >>> arr CompileRule)
 
+
+--------------------------------------------------------------------------------
 -- | Add resources
---
 tellResources :: [Resource]
               -> Rules
 tellResources resources' = RulesM $ tell $
     RuleSet mempty mempty $ S.fromList resources'
 
+
+--------------------------------------------------------------------------------
 -- | Only compile/route items satisfying the given predicate
---
 match :: Pattern a -> RulesM b -> RulesM b
 match pattern = RulesM . local addPredicate . unRulesM
   where
@@ -84,8 +95,9 @@ match pattern = RulesM . local addPredicate . unRulesM
         { rulesPattern = rulesPattern env `mappend` castPattern pattern
         }
 
+
+--------------------------------------------------------------------------------
 -- | Greate a group of compilers
---
 -- Imagine you have a page that you want to render, but you also want the raw
 -- content available on your site.
 --
@@ -114,18 +126,18 @@ match pattern = RulesM . local addPredicate . unRulesM
 --
 -- This will put the compiler for the raw content in a separate group
 -- (@\"raw\"@), which causes it to be compiled as well.
---
 group :: String -> RulesM a -> RulesM a
 group g = RulesM . local setGroup' . unRulesM
   where
     setGroup' env = env { rulesGroup = Just g }
 
+
+--------------------------------------------------------------------------------
 -- | Add a compilation rule to the rules.
 --
 -- 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)
         => Compiler Resource a -> RulesM (Pattern a)
 compile compiler = do
@@ -134,7 +146,9 @@ compile compiler = do
         (identifier, constA (fromIdentifier identifier) >>> compiler)
     tellResources $ map fromIdentifier ids
     return $ list ids
-                   
+
+
+--------------------------------------------------------------------------------
 -- | Add a compilation rule
 --
 -- This sets a compiler for the given identifier. No resource is needed, since
@@ -143,7 +157,6 @@ compile compiler = do
 -- actual content itself. Note that the group of the given identifier is
 -- replaced by the group set via 'group' (or 'Nothing', if 'group' has not been
 -- used).
---
 create :: (Binary a, Typeable a, Writable a)
        => Identifier a -> Compiler () a -> RulesM (Identifier a)
 create id' compiler = RulesM $ do
@@ -152,10 +165,11 @@ create id' compiler = RulesM $ do
     unRulesM $ tellCompilers [(id'', compiler)]
     return id''
 
+
+--------------------------------------------------------------------------------
 -- | Add a route.
 --
 -- This adds a route for all items matching the current pattern.
---
 route :: Routes -> Rules
 route route' = RulesM $ do
     -- We want the route only to be applied if we match the current pattern and
@@ -164,9 +178,10 @@ route route' = RulesM $ do
     group' <- rulesGroup <$> ask
     unRulesM $ tellRoute $ matchRoute (pattern `mappend` inGroup group') route'
 
+
+--------------------------------------------------------------------------------
 -- | Get a list of resources matching the current pattern. This will also set
 -- the correct group to the identifiers.
---
 resources :: RulesM [Identifier a]
 resources = RulesM $ do
     pattern <- rulesPattern <$> ask
@@ -176,6 +191,8 @@ resources = RulesM $ do
   where
     toId g = setGroup g . toIdentifier
 
+
+--------------------------------------------------------------------------------
 -- | 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.
@@ -205,9 +222,8 @@ resources = RulesM $ do
 -- 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.
---
 metaCompile :: (Binary a, Typeable a, Writable a)
-            => Compiler () [(Identifier a, Compiler () a)]   
+            => Compiler () [(Identifier a, Compiler () a)]
             -- ^ Compiler generating the other compilers
             -> Rules
             -- ^ Resulting rules
@@ -215,13 +231,14 @@ metaCompile compiler = do
     id' <- freshIdentifier "Hakyll.Core.Rules.metaCompile"
     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 a, Compiler () a)]   
+                -> Compiler () [(Identifier a, Compiler () a)]
                 -- ^ Compiler generating the other compilers
                 -> Rules
                 -- ^ Resulting rules
@@ -239,6 +256,8 @@ metaCompileWith identifier compiler = RulesM $ do
 
     tell $ RuleSet mempty compilers mempty
 
+
+--------------------------------------------------------------------------------
 -- | Generate a fresh Identifier with a given prefix
 freshIdentifier :: String                 -- ^ Prefix
                 -> RulesM (Identifier a)  -- ^ Fresh identifier
diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs
index 55c4446..9d6a979 100644
--- a/src/Hakyll/Core/Rules/Internal.hs
+++ b/src/Hakyll/Core/Rules/Internal.hs
@@ -1,6 +1,7 @@
+--------------------------------------------------------------------------------
 -- | Internal rules module for types which are not exposed to the user
---
-{-# LANGUAGE GeneralizedNewtypeDeriving, Rank2Types #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE Rank2Types                 #-}
 module Hakyll.Core.Rules.Internal
     ( CompileRule (..)
     , RuleSet (..)
@@ -11,34 +12,38 @@ module Hakyll.Core.Rules.Internal
     , runRules
     ) where
 
-import Control.Applicative (Applicative)
-import Control.Monad.Writer (WriterT, execWriterT)
-import Control.Monad.Reader (ReaderT, runReaderT)
-import Control.Monad.State (State, evalState)
-import Data.Monoid (Monoid, mempty, mappend)
-import Data.Set (Set)
-import qualified Data.Map as M
-
-import Hakyll.Core.Resource
-import Hakyll.Core.Resource.Provider
-import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.Compiler.Internal
-import Hakyll.Core.Routes
-import Hakyll.Core.CompiledItem
 
+--------------------------------------------------------------------------------
+import           Control.Applicative            (Applicative)
+import           Control.Monad.RWS              (RWST, runRWST)
+import qualified Data.Map                       as M
+import           Data.Monoid                    (Monoid, mappend, mempty)
+import           Data.Set                       (Set)
+
+
+--------------------------------------------------------------------------------
+import           Hakyll.Core.CompiledItem
+import           Hakyll.Core.Compiler.Internal
+import           Hakyll.Core.Identifier
+import           Hakyll.Core.Identifier.Pattern
+import           Hakyll.Core.Resource
+import           Hakyll.Core.Resource.Provider
+import           Hakyll.Core.Routes
+
+
+--------------------------------------------------------------------------------
 -- | Output of a compiler rule
 --
 -- * The compiler will produce a simple item. This is the most common case.
 --
 -- * The compiler will produce more compilers. These new compilers need to be
 --   added to the runtime if possible, since other items might depend upon them.
---
 data CompileRule = CompileRule CompiledItem
                  | MetaCompileRule [(Identifier (), Compiler () CompileRule)]
 
+
+--------------------------------------------------------------------------------
 -- | A collection of rules for the compilation process
---
 data RuleSet = RuleSet
     { -- | Routes used in the compilation structure
       rulesRoutes    :: Routes
@@ -48,51 +53,61 @@ data RuleSet = RuleSet
       rulesResources :: Set Resource
     }
 
+
+--------------------------------------------------------------------------------
 instance Monoid RuleSet where
     mempty = RuleSet mempty mempty mempty
     mappend (RuleSet r1 c1 s1) (RuleSet r2 c2 s2) =
         RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2)
 
+
+--------------------------------------------------------------------------------
 -- | Rule state
---
 data RuleState = RuleState
     { rulesNextIdentifier :: Int
     } deriving (Show)
 
+
+--------------------------------------------------------------------------------
 -- | Rule environment
---
 data RuleEnvironment = RuleEnvironment
     { rulesResourceProvider :: ResourceProvider
     , rulesPattern          :: forall a. Pattern a
     , rulesGroup            :: Maybe String
     }
 
+
+--------------------------------------------------------------------------------
 -- | The monad used to compose rules
---
 newtype RulesM a = RulesM
-    { unRulesM :: ReaderT RuleEnvironment (WriterT RuleSet (State RuleState)) a
+    { unRulesM :: RWST RuleEnvironment RuleSet RuleState IO a
     } deriving (Monad, Functor, Applicative)
 
+
+--------------------------------------------------------------------------------
 -- | Simplification of the RulesM type; usually, it will not return any
 -- result.
---
 type Rules = RulesM ()
 
+
+--------------------------------------------------------------------------------
 -- | Run a Rules monad, resulting in a 'RuleSet'
---
-runRules :: RulesM a -> ResourceProvider -> RuleSet
-runRules rules provider = nubCompilers $
-    evalState (execWriterT $ runReaderT (unRulesM rules) env) state
+runRules :: RulesM a -> ResourceProvider -> IO RuleSet
+runRules rules provider = do
+    (_, _, ruleSet) <- runRWST (unRulesM rules) env state
+    return $ nubCompilers ruleSet
   where
     state = RuleState {rulesNextIdentifier = 0}
-    env = RuleEnvironment { rulesResourceProvider = provider
-                          , rulesPattern          = mempty
-                          , rulesGroup            = Nothing
-                          }
+    env   = RuleEnvironment
+        { rulesResourceProvider = provider
+        , rulesPattern          = mempty
+        , rulesGroup            = Nothing
+        }
 
+
+--------------------------------------------------------------------------------
 -- | Remove duplicate compilers from the 'RuleSet'. When two compilers match an
 -- item, we prefer the first one
---
 nubCompilers :: RuleSet -> RuleSet
 nubCompilers set = set { rulesCompilers = nubCompilers' (rulesCompilers set) }
   where
diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs
index a777d0a..4842ea7 100644
--- a/src/Hakyll/Core/Run.hs
+++ b/src/Hakyll/Core/Run.hs
@@ -52,8 +52,8 @@ run configuration rules = do
     let (firstRun, oldGraph) = case graph of Store.Found g -> (False, g)
                                              _             -> (True, mempty)
 
-    let ruleSet = runRules rules provider
-        compilers = rulesCompilers ruleSet
+    ruleSet <- timed logger "Running rules" $ runRules rules provider
+    let compilers = rulesCompilers ruleSet
 
         -- Extract the reader/state
         reader = unRuntime $ addNewCompilers compilers