Works-for-me implementation of nested rules

3 files changed, 52 insertions, 22 deletions

diff --git a/src/Hakyll/Core/Routes.hs b/src/Hakyll/Core/Routes.hs
index fcab28d..386635f 100644
--- a/src/Hakyll/Core/Routes.hs
+++ b/src/Hakyll/Core/Routes.hs
@@ -30,7 +30,7 @@ module Hakyll.Core.Routes
     , runRoutes
     , idRoute
     , setExtension
-    , ifMatch
+    , matchRoute
     , customRoute
     , gsubRoute
     , composeRoutes
@@ -41,7 +41,6 @@ import Control.Monad (mplus)
 import System.FilePath (replaceExtension)
 
 import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
 import Hakyll.Core.Util.String
 
 -- | Type used for a route
@@ -85,15 +84,15 @@ setExtension :: String -> Routes
 setExtension extension = Routes $ fmap (`replaceExtension` extension)
                                 . unRoutes idRoute
 
--- | Modify a route: apply the route if the identifier matches the given
--- pattern, fail otherwise.
+-- | Apply the route if the identifier matches the given predicate, fail
+-- otherwise
 --
-ifMatch :: Pattern -> Routes -> Routes
-ifMatch pattern (Routes route) = Routes $ \id' ->
-    if doesMatch pattern id' then route id'
-                             else Nothing
+matchRoute :: (Identifier -> Bool) -> Routes -> Routes
+matchRoute predicate (Routes route) = Routes $ \id' ->
+    if predicate id' then route id' else Nothing
 
--- | Create a custom route. This should almost always be used with 'ifMatch'.
+-- | Create a custom route. This should almost always be used with
+-- 'matchRoute'
 --
 customRoute :: (Identifier -> FilePath) -> Routes
 customRoute f = Routes $ Just . f
diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs
index eba3fb9..319e10b 100644
--- a/src/Hakyll/Core/Rules.hs
+++ b/src/Hakyll/Core/Rules.hs
@@ -14,6 +14,8 @@
 module Hakyll.Core.Rules
     ( RulesM
     , Rules
+    , matchPattern
+    , matchPredicate
     , compile
     , create
     , route
@@ -23,7 +25,7 @@ module Hakyll.Core.Rules
 
 import Control.Applicative ((<$>))
 import Control.Monad.Writer (tell)
-import Control.Monad.Reader (ask)
+import Control.Monad.Reader (ask, local)
 import Control.Arrow (second, (>>>), arr, (>>^))
 import Control.Monad.State (get, put)
 import Data.Monoid (mempty)
@@ -63,21 +65,37 @@ tellResources :: [Resource]
               -> Rules
 tellResources resources = RulesM $ tell $ RuleSet mempty mempty $ S.fromList resources
 
+-- | Only compile/route items matching the given pattern
+--
+matchPattern :: Pattern -> Rules -> Rules
+matchPattern pattern = matchPredicate (doesMatch pattern)
+
+-- | Only compile/route items satisfying the given predicate
+--
+matchPredicate :: (Identifier -> Bool) -> Rules -> Rules
+matchPredicate predicate = RulesM . local addPredicate . unRulesM
+  where
+    addPredicate env = env
+        { rulesMatcher = \id' -> rulesMatcher env id' && predicate id'
+        }
+
 -- | Add a compilation rule to the rules.
 --
--- This instructs all resources matching the given pattern to be compiled using
--- the given compiler. When no resources match the given pattern, nothing will
--- happen. In this case, you might want to have a look at 'create'.
+-- 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)
-        => Pattern -> Compiler Resource a -> Rules
-compile pattern compiler = RulesM $ do
-    identifiers <- matches pattern . map unResource . resourceList <$> ask
+        => Compiler Resource a -> Rules
+compile compiler = RulesM $ do
+    matcher <- rulesMatcher <$> ask
+    provider <- rulesResourceProvider <$> ask
+    let identifiers = filter matcher $ map unResource $ resourceList provider
     unRulesM $ do
         tellCompilers $ flip map identifiers $ \identifier ->
             (identifier, constA (Resource identifier) >>> compiler)
         tellResources $ map Resource identifiers
-
+                   
 -- | Add a compilation rule
 --
 -- This sets a compiler for the given identifier. No resource is needed, since
@@ -91,10 +109,12 @@ create identifier compiler = tellCompilers [(identifier, compiler)]
 
 -- | Add a route.
 --
--- This adds a route for all items matching the given pattern.
+-- This adds a route for all items matching the current pattern.
 --
-route :: Pattern -> Routes -> Rules
-route pattern route' = tellRoute $ ifMatch pattern route'
+route :: Routes -> Rules
+route route' = RulesM $ do
+    matcher <- rulesMatcher <$> ask
+    unRulesM $ tellRoute $ matchRoute matcher route'
 
 -- | Apart from regular compilers, one is also able to specify metacompilers.
 -- Metacompilers are a special class of compilers: they are compilers which
diff --git a/src/Hakyll/Core/Rules/Internal.hs b/src/Hakyll/Core/Rules/Internal.hs
index 2895257..dc669c1 100644
--- a/src/Hakyll/Core/Rules/Internal.hs
+++ b/src/Hakyll/Core/Rules/Internal.hs
@@ -5,6 +5,7 @@ module Hakyll.Core.Rules.Internal
     ( CompileRule (..)
     , RuleSet (..)
     , RuleState (..)
+    , RuleEnvironment (..)
     , RulesM (..)
     , Rules
     , runRules
@@ -55,10 +56,17 @@ data RuleState = RuleState
     { rulesMetaCompilerIndex :: Int
     } deriving (Show)
 
+-- | Rule environment
+--
+data RuleEnvironment = RuleEnvironment
+    { rulesResourceProvider :: ResourceProvider
+    , rulesMatcher          :: Identifier -> Bool
+    }
+
 -- | The monad used to compose rules
 --
 newtype RulesM a = RulesM
-    { unRulesM :: ReaderT ResourceProvider (WriterT RuleSet (State RuleState)) a
+    { unRulesM :: ReaderT RuleEnvironment (WriterT RuleSet (State RuleState)) a
     } deriving (Monad, Functor, Applicative)
 
 -- | Simplification of the RulesM type; usually, it will not return any
@@ -70,6 +78,9 @@ type Rules = RulesM ()
 --
 runRules :: Rules -> ResourceProvider -> RuleSet
 runRules rules provider =
-    evalState (execWriterT $ runReaderT (unRulesM rules) provider) state
+    evalState (execWriterT $ runReaderT (unRulesM rules) env) state
   where
     state = RuleState {rulesMetaCompilerIndex = 0}
+    env = RuleEnvironment { rulesResourceProvider = provider
+                          , rulesMatcher          = const True
+                          }