Experimental arrow-based approach

7 files changed, 98 insertions, 159 deletions

diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index 8a87fef..c4a7b06 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -4,26 +4,32 @@
 module Hakyll.Core.Compiler
     ( Dependencies
     , CompilerM
-    , Compiler
+    , Compiler (..)
     , runCompiler
+    , getIdentifier
+    , getResourceString
     , require
-    , requireAll
-    , compileFromString
+    -- , requireAll
+    -- , compileFromString
     ) where
 
-import Control.Arrow (second)
+import Prelude hiding ((.), id)
+import Control.Arrow (second, (>>>))
 import Control.Applicative (Applicative, (<$>))
 import Control.Monad.State (State, modify, runState)
 import Control.Monad.Reader (ReaderT, ask, runReaderT)
+import Control.Monad.Trans (liftIO)
+import Control.Monad ((<=<))
 import Data.Set (Set)
 import qualified Data.Set as S
-import Data.Typeable (Typeable)
+import Control.Category (Category, (.), id)
+import Control.Arrow (Arrow, arr, first)
+
 import Data.Binary (Binary)
+import Data.Typeable (Typeable)
 
 import Hakyll.Core.Identifier
 import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.Target
-import Hakyll.Core.Target.Internal
 import Hakyll.Core.CompiledItem
 import Hakyll.Core.Writable
 import Hakyll.Core.ResourceProvider
@@ -32,65 +38,92 @@ import Hakyll.Core.ResourceProvider
 --
 type Dependencies = Set Identifier
 
--- | Add one dependency
+-- | A lookup with which we can get dependencies
 --
-addDependency :: Identifier -> CompilerM ()
-addDependency dependency = CompilerM $ modify $ addDependency'
-  where
-    addDependency' x = x
-        { compilerDependencies = S.insert dependency $ compilerDependencies x
-        }
+type DependencyLookup = Identifier -> CompiledItem
 
 -- | Environment in which a compiler runs
 --
 data CompilerEnvironment = CompilerEnvironment
     { compilerIdentifier       :: Identifier        -- ^ Target identifier
     , compilerResourceProvider :: ResourceProvider  -- ^ Resource provider
-    }
-
--- | State carried along by a compiler
---
-data CompilerState = CompilerState
-    { compilerDependencies :: Dependencies
+    , compilerDependencyLookup :: DependencyLookup  -- ^ Dependency lookup
     }
 
 -- | The compiler monad
 --
 newtype CompilerM a = CompilerM
-    { unCompilerM :: ReaderT CompilerEnvironment (State CompilerState) a
+    { unCompilerM :: ReaderT CompilerEnvironment IO a
     } deriving (Monad, Functor, Applicative)
 
--- | Simplified type for a compiler generating a target (which covers most
--- cases)
+-- | The compiler arrow
 --
-type Compiler a = CompilerM (TargetM a)
+data Compiler a b = Compiler
+    { -- TODO: Reader ResourceProvider Dependencies
+      compilerDependencies :: Dependencies
+    , compilerJob          :: a -> CompilerM b
+    }
+
+instance Category Compiler where
+    id = Compiler S.empty return
+    (Compiler d1 j1) . (Compiler d2 j2) =
+        Compiler (d1 `S.union` d2) (j1 <=< j2)
+
+instance Arrow Compiler where
+    arr f = Compiler S.empty (return . f)
+    first (Compiler d j) = Compiler d $ \(x, y) -> do
+        x' <- j x
+        return (x', y)
 
 -- | Run a compiler, yielding the resulting target and it's dependencies
 --
-runCompiler :: Compiler a -> Identifier -> ResourceProvider
-            -> (TargetM a, Dependencies)
-runCompiler compiler identifier provider = second compilerDependencies $
-    runState (runReaderT (unCompilerM compiler) env) state
+runCompiler :: Compiler () a
+            -> Identifier
+            -> ResourceProvider
+            -> DependencyLookup
+            -> IO a
+runCompiler compiler identifier provider lookup' =
+    runReaderT (unCompilerM $ compilerJob compiler ()) env
   where
-    state = CompilerState S.empty
     env = CompilerEnvironment
             { compilerIdentifier       = identifier
             , compilerResourceProvider = provider
+            , compilerDependencyLookup = lookup'
             }
 
+addDependency :: Identifier
+              -> Compiler b b
+addDependency id' = Compiler (S.singleton id') return
+
+fromCompilerM :: (a -> CompilerM b)
+              -> Compiler a b
+fromCompilerM = Compiler S.empty
+
+getIdentifier :: Compiler () Identifier
+getIdentifier = fromCompilerM $ const $ CompilerM $
+    compilerIdentifier <$> ask
+
+getResourceString :: Compiler () String
+getResourceString = getIdentifier >>> getResourceString'
+  where
+    getResourceString' = fromCompilerM $ \id' -> CompilerM $ do
+        provider <- compilerResourceProvider <$> ask
+        liftIO $ resourceString provider id'
 
 -- | Require another target. Using this function ensures automatic handling of
 -- dependencies
 --
 require :: (Binary a, Typeable a, Writable a)
         => Identifier
-        -> Compiler a
-require identifier = do
-    addDependency identifier
-    return $ TargetM $ do
-        lookup' <- targetDependencyLookup <$> ask
-        return $ unCompiledItem $ lookup' identifier
+        -> (a -> b -> c)
+        -> Compiler b c
+require identifier f = addDependency identifier >>> fromCompilerM require'
+  where
+    require' x = CompilerM $ do
+        lookup' <- compilerDependencyLookup <$> ask
+        return $ f (unCompiledItem $ lookup' identifier) x
 
+{-
 -- | Require a number of targets. Using this function ensures automatic handling
 -- of dependencies
 --
@@ -108,3 +141,4 @@ requireAll pattern = CompilerM $ do
 compileFromString :: (String -> TargetM a)  -- ^ Function to create the target
                   -> Compiler a             -- ^ Resulting compiler
 compileFromString = return . (getResourceString >>=)
+-}
diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs
index 021af5d..de7f6d4 100644
--- a/src/Hakyll/Core/Rules.hs
+++ b/src/Hakyll/Core/Rules.hs
@@ -15,7 +15,7 @@ module Hakyll.Core.Rules
 import Control.Applicative (Applicative, (<$>))
 import Control.Monad.Writer
 import Control.Monad.Reader
-import Control.Arrow (second)
+import Control.Arrow (second, (>>>), arr)
 
 import Data.Typeable (Typeable)
 import Data.Binary (Binary)
@@ -32,7 +32,7 @@ import Hakyll.Core.Writable
 --
 data RuleSet = RuleSet
     { rulesRoute     :: Route
-    , rulesCompilers :: [(Identifier, Compiler CompiledItem)]
+    , rulesCompilers :: [(Identifier, Compiler () CompiledItem)]
     }
 
 instance Monoid RuleSet where
@@ -64,12 +64,12 @@ addRoute route' = RulesM $ tell $ RuleSet route' mempty
 -- | Add a number of compilers
 --
 addCompilers :: (Binary a, Typeable a, Writable a)
-             => [(Identifier, Compiler a)]
+             => [(Identifier, Compiler () a)]
              -> Rules
 addCompilers compilers = RulesM $ tell $ RuleSet mempty $
     map (second boxCompiler) compilers
   where
-    boxCompiler = fmap (fmap compiledItem)
+    boxCompiler = (>>> arr compiledItem)
 
 -- | Add a compilation rule
 --
@@ -77,7 +77,7 @@ addCompilers compilers = RulesM $ tell $ RuleSet mempty $
 -- the given compiler
 --
 compile :: (Binary a, Typeable a, Writable a)
-        => Pattern -> Compiler a -> Rules
+        => Pattern -> Compiler () a -> Rules
 compile pattern compiler = RulesM $ do
     identifiers <- matches pattern . resourceList <$> ask
     unRulesM $ addCompilers $ zip identifiers (repeat compiler)
@@ -87,7 +87,7 @@ compile pattern compiler = RulesM $ do
 -- This sets a compiler for the given identifier
 --
 create :: (Binary a, Typeable a, Writable a)
-       => Identifier -> Compiler a -> Rules
+       => Identifier -> Compiler () a -> Rules
 create identifier compiler = addCompilers [(identifier, compiler)]
 
 -- | Add a route
diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs
index 1a79aa9..3bd1e6b 100644
--- a/src/Hakyll/Core/Run.hs
+++ b/src/Hakyll/Core/Run.hs
@@ -11,12 +11,12 @@ import Data.Binary (Binary)
 import System.FilePath ((</>))
 
 import Hakyll.Core.Route
+import Hakyll.Core.Identifier
 import Hakyll.Core.Util.File
 import Hakyll.Core.Compiler
 import Hakyll.Core.ResourceProvider
 import Hakyll.Core.ResourceProvider.FileResourceProvider
 import Hakyll.Core.Rules
-import Hakyll.Core.Target
 import Hakyll.Core.DirectedGraph
 import Hakyll.Core.DirectedGraph.Dot
 import Hakyll.Core.DirectedGraph.DependencySolver
@@ -38,22 +38,20 @@ hakyllWith rules provider store = do
         -- Get all identifiers and compilers
         compilers = rulesCompilers ruleSet
 
-        -- Get all targets
-        targets = flip map compilers $ \(id', compiler) ->
-            let (targ, deps) = runCompiler compiler id' provider
-            in (id', targ, deps)
+        -- Get all dependencies
+        dependencies = flip map compilers $ \(id', compiler) ->
+            let deps = compilerDependencies compiler
+            in (id', deps)
 
-        -- Map mapping every identifier to it's target
-        targetMap = M.fromList $ map (\(i, t, _) -> (i, t)) targets
+        -- Create a compiler map
+        compilerMap = M.fromList compilers
 
-        -- Create a dependency graph
-        graph = fromList $ map (\(i, _, d) -> (i, d)) targets
-
-        -- Solve the graph, creating a target order
+        -- Create and solve the graph, creating a compiler order
+        graph = fromList dependencies
         ordered = solveDependencies graph
 
-        -- Join the order with the targets again
-        orderedTargets = map (id &&& (targetMap M.!)) ordered
+        -- Join the order with the compilers again
+        orderedCompilers = map (id &&& (compilerMap M.!)) ordered
 
         -- Fetch the routes
         route' = rulesRoute ruleSet
@@ -62,12 +60,12 @@ hakyllWith rules provider store = do
     writeDot "dependencies.dot" show graph
 
     -- Generate all the targets in order
-    _ <- foldM (addTarget route') M.empty orderedTargets
+    _ <- foldM (addTarget route') M.empty orderedCompilers
 
     putStrLn "DONE."
   where
-    addTarget route' map' (id', targ) = do
-        compiled <- runTarget targ id' (dependencyLookup map') provider store
+    addTarget route' map' (id', comp) = do
+        compiled <- runCompiler comp id' provider (dependencyLookup map')
         putStrLn $ "Generated target: " ++ show id'
 
         case runRoute route' id' of
diff --git a/src/Hakyll/Core/Target.hs b/src/Hakyll/Core/Target.hs
deleted file mode 100644
index 452fb57..0000000
--- a/src/Hakyll/Core/Target.hs
+++ /dev/null
@@ -1,31 +0,0 @@
--- | A target represents one compilation unit, e.g. a blog post, a CSS file...
---
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Hakyll.Core.Target
-    ( DependencyLookup
-    , TargetM
-    , runTarget
-    , getIdentifier
-    , getResourceString
-    ) where
-
-import Control.Applicative ((<$>))
-import Control.Monad.Reader (ask)
-import Control.Monad.Trans (liftIO)
-
-import Hakyll.Core.Identifier
-import Hakyll.Core.Target.Internal
-import Hakyll.Core.ResourceProvider
-
--- | Get the current identifier
---
-getIdentifier :: TargetM Identifier
-getIdentifier = TargetM $ targetIdentifier <$> ask
-
--- | Get the resource content as a string
---
-getResourceString :: TargetM String
-getResourceString = TargetM $ do
-    provider <- targetResourceProvider <$> ask
-    identifier <- unTargetM getIdentifier
-    liftIO $ resourceString provider identifier
diff --git a/src/Hakyll/Core/Target/Internal.hs b/src/Hakyll/Core/Target/Internal.hs
deleted file mode 100644
index 62fb4fc..0000000
--- a/src/Hakyll/Core/Target/Internal.hs
+++ /dev/null
@@ -1,66 +0,0 @@
--- | Internal structure of a Target, not exported outside of the library
---
-{-# LANGUAGE GeneralizedNewtypeDeriving, Rank2Types #-}
-module Hakyll.Core.Target.Internal
-    ( DependencyLookup
-    , TargetEnvironment (..)
-    , TargetM (..)
-    , runTarget
-    ) where
-
-import Control.Applicative (Applicative)
-import Control.Monad.Trans (MonadIO)
-import Control.Monad.Reader (ReaderT, runReaderT)
-import Control.Monad.State (StateT, evalStateT)
-
-import Hakyll.Core.Identifier
-import Hakyll.Core.ResourceProvider
-import Hakyll.Core.Store
-import Hakyll.Core.CompiledItem
-
--- | A lookup with which we can get dependencies
---
-type DependencyLookup = Identifier -> CompiledItem
-
--- | Environment for the target monad
---
-data TargetEnvironment = TargetEnvironment
-    { targetIdentifier       :: Identifier        -- ^ Identifier
-    , targetDependencyLookup :: DependencyLookup  -- ^ Dependency lookup
-    , targetResourceProvider :: ResourceProvider  -- ^ To get resources
-    , targetStore            :: Store             -- ^ Store for caching
-    }
-
--- | State for the target monad
---
-data TargetState = TargetState
-    { targetSnapshot :: Int  -- ^ Snapshot ID
-    }
-
--- | Monad for targets. In this monad, the user can compose targets and describe
--- how they should be created.
---
-newtype TargetM a = TargetM
-    { unTargetM :: ReaderT TargetEnvironment (StateT TargetState IO) a
-    } deriving (Monad, Functor, Applicative, MonadIO)
-
--- | Run a target, yielding an actual result.
---
-runTarget :: TargetM a
-          -> Identifier
-          -> DependencyLookup
-          -> ResourceProvider
-          -> Store
-          -> IO a
-runTarget target id' lookup' provider store =
-    evalStateT (runReaderT (unTargetM target) env) state
-  where
-    env = TargetEnvironment
-        { targetIdentifier       = id'
-        , targetDependencyLookup = lookup'
-        , targetResourceProvider = provider
-        , targetStore            = store
-        }
-    state = TargetState
-        { targetSnapshot = 0
-        }
diff --git a/src/Hakyll/Web/FileType.hs b/src/Hakyll/Web/FileType.hs
index a958fed..d5a9c56 100644
--- a/src/Hakyll/Web/FileType.hs
+++ b/src/Hakyll/Web/FileType.hs
@@ -7,10 +7,10 @@ module Hakyll.Web.FileType
     ) where
 
 import System.FilePath (takeExtension)
-import Control.Applicative ((<$>))
+import Control.Arrow ((>>>), arr)
 
 import Hakyll.Core.Identifier
-import Hakyll.Core.Target
+import Hakyll.Core.Compiler
 
 -- | Datatype to represent the different file types Hakyll can deal with by
 -- default
@@ -51,5 +51,5 @@ fileType = fileType' . takeExtension
 
 -- | Get the file type for the current file
 --
-getFileType :: TargetM FileType
-getFileType = fileType . toFilePath <$> getIdentifier
+getFileType :: Compiler () FileType
+getFileType = getIdentifier >>> arr (fileType . toFilePath)
diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs
index 17cac81..653c711 100644
--- a/src/Hakyll/Web/Pandoc.hs
+++ b/src/Hakyll/Web/Pandoc.hs
@@ -8,10 +8,12 @@ module Hakyll.Web.Pandoc
     , writePandocWith
 
       -- * Functions working on pages/targets
+    {-
     , pageReadPandoc
     , pageReadPandocWith
     , pageRenderPandoc
     , pageRenderPandocWith
+    -}
 
       -- * Default options
     , defaultParserState
@@ -23,7 +25,7 @@ import Control.Applicative ((<$>))
 import Text.Pandoc (Pandoc)
 import qualified Text.Pandoc as P
 
-import Hakyll.Core.Target
+import Hakyll.Core.Compiler
 import Hakyll.Web.FileType
 import Hakyll.Web.Page
 
@@ -62,6 +64,7 @@ writePandocWith :: P.WriterOptions  -- ^ Writer options for pandoc
                 -> String           -- ^ Resulting HTML
 writePandocWith = P.writeHtmlString
 
+{-
 -- | Read the resource using pandoc
 --
 pageReadPandoc :: Page String -> TargetM (Page Pandoc)
@@ -88,6 +91,7 @@ pageRenderPandocWith :: P.ParserState
 pageRenderPandocWith state options page = do
     pandoc <- pageReadPandocWith state page
     return $ writePandocWith options <$> pandoc
+-}
 
 -- | The default reader options for pandoc parsing in hakyll
 --