Playing around with groups

4 files changed, 46 insertions, 20 deletions

diff --git a/src/Hakyll/Core/Identifier.hs b/src/Hakyll/Core/Identifier.hs
index 1cb625f..f644951 100644
--- a/src/Hakyll/Core/Identifier.hs
+++ b/src/Hakyll/Core/Identifier.hs
@@ -26,7 +26,6 @@ module Hakyll.Core.Identifier
     , parseIdentifier
     , toFilePath
     , setGroup
-    , hasGroup
     ) where
 
 import Control.Arrow (second)
@@ -78,10 +77,5 @@ toFilePath = identifierPath
 
 -- | Set the identifier group for some identifier
 --
-setGroup :: String -> Identifier -> Identifier
-setGroup g (Identifier _ p) = Identifier (Just g) p
-
--- | Check if an identifier belongs to a certain group
---
-hasGroup :: String -> Identifier -> Bool
-hasGroup g (Identifier g' _) = Just g == g'
+setGroup :: Maybe String -> Identifier -> Identifier
+setGroup g (Identifier _ p) = Identifier g p
diff --git a/src/Hakyll/Core/Identifier/Pattern.hs b/src/Hakyll/Core/Identifier/Pattern.hs
index 348ef46..cee4bbc 100644
--- a/src/Hakyll/Core/Identifier/Pattern.hs
+++ b/src/Hakyll/Core/Identifier/Pattern.hs
@@ -36,6 +36,7 @@ module Hakyll.Core.Identifier.Pattern
     , parseGlob
     , predicate
     , regex
+    , inGroup
     , matches
     , filterMatches
     , capture
@@ -106,6 +107,12 @@ predicate = Predicate
 regex :: String -> Pattern
 regex str = predicate $ fromMaybe False . (=~~ str) . toFilePath
 
+-- | Create a 'Pattern' which matches if the identifier is in a certain group
+-- (or in no group)
+--
+inGroup :: Maybe String -> Pattern
+inGroup group = predicate $ (== group) . identifierGroup
+
 -- | Check if an identifier matches a pattern
 --
 matches :: Pattern -> Identifier -> Bool
diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs
index 892cf7c..9f88b82 100644
--- a/src/Hakyll/Core/Rules.hs
+++ b/src/Hakyll/Core/Rules.hs
@@ -19,6 +19,7 @@ module Hakyll.Core.Rules
     ( RulesM
     , Rules
     , match
+    , group
     , compile
     , create
     , route
@@ -29,7 +30,7 @@ module Hakyll.Core.Rules
 import Control.Applicative ((<$>))
 import Control.Monad.Writer (tell)
 import Control.Monad.Reader (ask, local)
-import Control.Arrow (second, (>>>), arr, (>>^))
+import Control.Arrow (second, (>>>), arr, (>>^), (***))
 import Control.Monad.State (get, put)
 import Data.Monoid (mempty, mappend)
 import qualified Data.Set as S
@@ -58,16 +59,21 @@ tellRoute route' = RulesM $ tell $ RuleSet route' mempty mempty
 tellCompilers :: (Binary a, Typeable a, Writable a)
              => [(Identifier, Compiler () a)]
              -> Rules
-tellCompilers compilers = RulesM $ tell $ RuleSet mempty compilers' mempty
+tellCompilers compilers = RulesM $ do
+    -- We box the compilers so they have a more simple type, and we apply the
+    -- current group to the corresponding identifiers
+    group' <- rulesGroup <$> ask
+    let compilers' = map (setGroup group' *** boxCompiler) compilers
+    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
+tellResources resources = RulesM $ tell $
+    RuleSet mempty mempty $ S.fromList resources
 
 -- | Only compile/route items satisfying the given predicate
 --
@@ -78,6 +84,13 @@ match pattern = RulesM . local addPredicate . unRulesM
         { rulesPattern = rulesPattern env `mappend` pattern
         }
 
+-- | Greate a group of compilers
+--
+group :: String -> Rules -> Rules
+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
@@ -112,8 +125,11 @@ create identifier compiler = tellCompilers [(identifier, compiler)]
 --
 route :: Routes -> Rules
 route route' = RulesM $ do
+    -- We want the route only to be applied if we match the current pattern and
+    -- group
     pattern <- rulesPattern <$> ask
-    unRulesM $ tellRoute $ matchRoute pattern route'
+    group' <- rulesGroup <$> ask
+    unRulesM $ tellRoute $ matchRoute (pattern `mappend` inGroup group') route'
 
 -- | Apart from regular compilers, one is also able to specify metacompilers.
 -- Metacompilers are a special class of compilers: they are compilers which
@@ -154,7 +170,7 @@ metaCompile compiler = RulesM $ do
     -- Create an identifier from the state
     state <- get
     let index = rulesMetaCompilerIndex state
-        id' = fromCaptureString "Hakyll.Core.Rules.metaCompile/*" (show index)
+        id' = fromCapture "Hakyll.Core.Rules.metaCompile/*" (show index)
 
     -- Update the state with a new identifier
     put $ state {rulesMetaCompilerIndex = index + 1}
@@ -172,9 +188,16 @@ metaCompileWith :: (Binary a, Typeable a, Writable a)
                 -- ^ Compiler generating the other compilers
                 -> Rules
                 -- ^ Resulting rules
-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)
+metaCompileWith identifier compiler = RulesM $ do
+    group' <- rulesGroup <$> ask
+
+    let -- Set the correct group on the identifier
+        id' = setGroup group' identifier
+        -- Function to box an item into a rule
+        makeRule = MetaCompileRule . map (second box)
+        -- Entire boxing function
+        box = (>>> fromDependency id' >>^ CompileRule . compiledItem)
+        -- Resulting compiler list
+        compilers = [(id', compiler >>> arr makeRule )]
+
+    tell $ RuleSet mempty compilers mempty
diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs
index 0e117ec..bcba414 100644
--- a/src/Hakyll/Core/Rules/Internal.hs
+++ b/src/Hakyll/Core/Rules/Internal.hs
@@ -63,6 +63,7 @@ data RuleState = RuleState
 data RuleEnvironment = RuleEnvironment
     { rulesResourceProvider :: ResourceProvider
     , rulesPattern          :: Pattern
+    , rulesGroup            :: Maybe String
     }
 
 -- | The monad used to compose rules
@@ -85,4 +86,5 @@ runRules rules provider =
     state = RuleState {rulesMetaCompilerIndex = 0}
     env = RuleEnvironment { rulesResourceProvider = provider
                           , rulesPattern          = mempty
+                          , rulesGroup            = Nothing
                           }