1 files changed, 109 insertions, 0 deletions
diff --git a/lib/Hakyll/Core/Rules/Internal.hs b/lib/Hakyll/Core/Rules/Internal.hs
new file mode 100644
index 0000000..0641dcf
--- /dev/null
+++ b/lib/Hakyll/Core/Rules/Internal.hs
@@ -0,0 +1,109 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE Rank2Types                 #-}
+module Hakyll.Core.Rules.Internal
+    ( RulesRead (..)
+    , RuleSet (..)
+    , RulesState (..)
+    , emptyRulesState
+    , Rules (..)
+    , runRules
+    ) where
+
+
+--------------------------------------------------------------------------------
+import           Control.Monad.Reader           (ask)
+import           Control.Monad.RWS              (RWST, runRWST)
+import           Control.Monad.Trans            (liftIO)
+import qualified Data.Map                       as M
+import           Data.Set                       (Set)
+
+
+--------------------------------------------------------------------------------
+import           Hakyll.Core.Compiler.Internal
+import           Hakyll.Core.Identifier
+import           Hakyll.Core.Identifier.Pattern
+import           Hakyll.Core.Item.SomeItem
+import           Hakyll.Core.Metadata
+import           Hakyll.Core.Provider
+import           Hakyll.Core.Routes
+
+
+--------------------------------------------------------------------------------
+data RulesRead = RulesRead
+    { rulesProvider :: Provider
+    , rulesMatches  :: [Identifier]
+    , rulesVersion  :: Maybe String
+    }
+
+
+--------------------------------------------------------------------------------
+data RuleSet = RuleSet
+    { -- | Accumulated routes
+      rulesRoutes    :: Routes
+    , -- | Accumulated compilers
+      rulesCompilers :: [(Identifier, Compiler SomeItem)]
+    , -- | A set of the actually used files
+      rulesResources :: Set Identifier
+    , -- | A pattern we can use to check if a file *would* be used. This is
+      -- needed for the preview server.
+      rulesPattern   :: Pattern
+    }
+
+
+--------------------------------------------------------------------------------
+instance Monoid RuleSet where
+    mempty = RuleSet mempty mempty mempty mempty
+    mappend (RuleSet r1 c1 s1 p1) (RuleSet r2 c2 s2 p2) =
+        RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2) (p1 .||. p2)
+
+
+--------------------------------------------------------------------------------
+data RulesState = RulesState
+    { rulesRoute    :: Maybe Routes
+    , rulesCompiler :: Maybe (Compiler SomeItem)
+    }
+
+
+--------------------------------------------------------------------------------
+emptyRulesState :: RulesState
+emptyRulesState = RulesState Nothing Nothing
+
+
+--------------------------------------------------------------------------------
+-- | The monad used to compose rules
+newtype Rules a = Rules
+    { unRules :: RWST RulesRead RuleSet RulesState IO a
+    } deriving (Monad, Functor, Applicative)
+
+
+--------------------------------------------------------------------------------
+instance MonadMetadata Rules where
+    getMetadata identifier = Rules $ do
+        provider <- rulesProvider <$> ask
+        liftIO $ resourceMetadata provider identifier
+
+    getMatches pattern = Rules $ do
+        provider <- rulesProvider <$> ask
+        return $ filterMatches pattern $ resourceList provider
+
+
+--------------------------------------------------------------------------------
+-- | Run a Rules monad, resulting in a 'RuleSet'
+runRules :: Rules a -> Provider -> IO RuleSet
+runRules rules provider = do
+    (_, _, ruleSet) <- runRWST (unRules rules) env emptyRulesState
+
+    -- Ensure compiler uniqueness
+    let ruleSet' = ruleSet
+            { rulesCompilers = M.toList $
+                M.fromListWith (flip const) (rulesCompilers ruleSet)
+            }
+
+    return ruleSet'
+  where
+    env = RulesRead
+        { rulesProvider = provider
+        , rulesMatches  = []
+        , rulesVersion  = Nothing
+        }