From 5a591ee24c50ed25702c06f8f811189984e443ea Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <jaspervdj@gmail.com>
Date: Tue, 15 Feb 2011 18:32:55 +0100
Subject: Rules DSL tracks resources used

---
 src/Hakyll/Core/Rules.hs          | 24 +++++++++++++++++-------
 src/Hakyll/Core/Rules/Internal.hs | 15 ++++++++++-----
 2 files changed, 27 insertions(+), 12 deletions(-)

(limited to 'src/Hakyll')

diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs
index 137dc2c..1aa3ad3 100644
--- a/src/Hakyll/Core/Rules.hs
+++ b/src/Hakyll/Core/Rules.hs
@@ -27,6 +27,7 @@ import Control.Monad.Reader (ask)
 import Control.Arrow (second, (>>>), arr, (>>^))
 import Control.Monad.State (get, put)
 import Data.Monoid (mempty)
+import qualified Data.Set as S
 
 import Data.Typeable (Typeable)
 import Data.Binary (Binary)
@@ -44,18 +45,24 @@ import Hakyll.Core.Util.Arrow
 -- | Add a route
 --
 tellRoute :: Routes -> Rules
-tellRoute route' = RulesM $ tell $ RuleSet route' mempty
+tellRoute route' = RulesM $ tell $ RuleSet route' mempty mempty
 
 -- | Add a number of compilers
 --
 tellCompilers :: (Binary a, Typeable a, Writable a)
              => [(Identifier, Compiler () a)]
              -> Rules
-tellCompilers compilers = RulesM $ tell $ RuleSet mempty $
-    map (second boxCompiler) compilers
+tellCompilers compilers = RulesM $ tell $ RuleSet mempty compilers' mempty
   where
+    compilers' = map (second boxCompiler) compilers
     boxCompiler = (>>> arr compiledItem >>> arr CompileRule)
 
+-- | Add resources
+--
+tellResources :: [Resource]
+              -> Rules
+tellResources resources = RulesM $ tell $ RuleSet mempty mempty $ S.fromList resources
+
 -- | Add a compilation rule to the rules.
 --
 -- This instructs all resources matching the given pattern to be compiled using
@@ -66,8 +73,10 @@ compile :: (Binary a, Typeable a, Writable a)
         => Pattern -> Compiler Resource a -> Rules
 compile pattern compiler = RulesM $ do
     identifiers <- matches pattern . map unResource . resourceList <$> ask
-    unRulesM $ tellCompilers $ flip map identifiers $ \identifier ->
-        (identifier, constA (Resource identifier) >>> compiler)
+    unRulesM $ do
+        tellCompilers $ flip map identifiers $ \identifier ->
+            (identifier, constA (Resource identifier) >>> compiler)
+        tellResources $ map Resource identifiers
 
 -- | Add a compilation rule
 --
@@ -125,8 +134,9 @@ metaCompileWith :: (Binary a, Typeable a, Writable a)
                 -- ^ Compiler generating the other compilers
                 -> Rules
                 -- ^ Resulting rules
-metaCompileWith identifier compiler = RulesM $ tell $ RuleSet mempty
-    [(identifier, compiler >>> arr makeRule )]
+metaCompileWith identifier compiler = RulesM $ tell $
+    RuleSet mempty compilers mempty
   where
     makeRule = MetaCompileRule . map (second box)
+    compilers = [(identifier, compiler >>> arr makeRule )]
     box = (>>> fromDependency identifier >>^ CompileRule . compiledItem)
diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs
index bedc67a..2895257 100644
--- a/src/Hakyll/Core/Rules/Internal.hs
+++ b/src/Hakyll/Core/Rules/Internal.hs
@@ -15,6 +15,7 @@ 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 Hakyll.Core.ResourceProvider
 import Hakyll.Core.Identifier
@@ -35,14 +36,18 @@ data CompileRule = CompileRule CompiledItem
 -- | A collection of rules for the compilation process
 --
 data RuleSet = RuleSet
-    { rulesRoutes    :: Routes
-    , rulesCompilers :: [(Identifier, Compiler () CompileRule)]
+    { -- | Routes used in the compilation structure
+      rulesRoutes    :: Routes
+    , -- | Compilation rules
+      rulesCompilers :: [(Identifier, Compiler () CompileRule)]
+    , -- | A list of the used resources
+      rulesResources :: Set Resource
     }
 
 instance Monoid RuleSet where
-    mempty = RuleSet mempty mempty
-    mappend (RuleSet r1 c1) (RuleSet r2 c2) =
-        RuleSet (mappend r1 r2) (mappend c1 c2)
+    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
 --
-- 
cgit v1.2.3