More arrows

4 files changed, 77 insertions, 38 deletions

diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index c4a7b06..a2875ba 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -6,10 +6,11 @@ module Hakyll.Core.Compiler
     , CompilerM
     , Compiler (..)
     , runCompiler
+    , getDependencies
     , getIdentifier
     , getResourceString
     , require
-    -- , requireAll
+    , requireAll
     -- , compileFromString
     ) where
 
@@ -17,9 +18,9 @@ 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.Reader (ReaderT, Reader, ask, runReaderT, runReader)
 import Control.Monad.Trans (liftIO)
-import Control.Monad ((<=<))
+import Control.Monad ((<=<), liftM2)
 import Data.Set (Set)
 import qualified Data.Set as S
 import Control.Category (Category, (.), id)
@@ -59,18 +60,17 @@ newtype CompilerM a = CompilerM
 -- | The compiler arrow
 --
 data Compiler a b = Compiler
-    { -- TODO: Reader ResourceProvider Dependencies
-      compilerDependencies :: Dependencies
+    { compilerDependencies :: Reader ResourceProvider Dependencies
     , compilerJob          :: a -> CompilerM b
     }
 
 instance Category Compiler where
-    id = Compiler S.empty return
+    id = Compiler (return S.empty) return
     (Compiler d1 j1) . (Compiler d2 j2) =
-        Compiler (d1 `S.union` d2) (j1 <=< j2)
+        Compiler (liftM2 S.union d1 d2) (j1 <=< j2)
 
 instance Arrow Compiler where
-    arr f = Compiler S.empty (return . f)
+    arr f = Compiler (return S.empty) (return . f)
     first (Compiler d j) = Compiler d $ \(x, y) -> do
         x' <- j x
         return (x', y)
@@ -91,13 +91,19 @@ runCompiler compiler identifier provider lookup' =
             , compilerDependencyLookup = lookup'
             }
 
-addDependency :: Identifier
-              -> Compiler b b
-addDependency id' = Compiler (S.singleton id') return
+getDependencies :: Compiler () a
+                -> ResourceProvider
+                -> Dependencies
+getDependencies compiler provider =
+    runReader (compilerDependencies compiler) provider
+
+addDependencies :: (ResourceProvider -> [Identifier])
+                -> Compiler b b
+addDependencies deps = Compiler (S.fromList . deps <$> ask) return
 
 fromCompilerM :: (a -> CompilerM b)
               -> Compiler a b
-fromCompilerM = Compiler S.empty
+fromCompilerM = Compiler (return S.empty)
 
 getIdentifier :: Compiler () Identifier
 getIdentifier = fromCompilerM $ const $ CompilerM $
@@ -115,26 +121,32 @@ getResourceString = getIdentifier >>> getResourceString'
 --
 require :: (Binary a, Typeable a, Writable a)
         => Identifier
-        -> (a -> b -> c)
+        -> (b -> a -> c)
         -> Compiler b c
-require identifier f = addDependency identifier >>> fromCompilerM require'
+require identifier f =
+    addDependencies (const [identifier]) >>> fromCompilerM require'
   where
     require' x = CompilerM $ do
         lookup' <- compilerDependencyLookup <$> ask
-        return $ f (unCompiledItem $ lookup' identifier) x
+        return $ f x $ unCompiledItem $ lookup' identifier
 
-{-
 -- | Require a number of targets. Using this function ensures automatic handling
 -- of dependencies
 --
 requireAll :: (Binary a, Typeable a, Writable a)
            => Pattern
-           -> Compiler [a]
-requireAll pattern = CompilerM $ do
-    provider <- compilerResourceProvider <$> ask
-    r <- unCompilerM $ mapM require $ matches pattern $ resourceList provider
-    return $ sequence r
+           -> (b -> [a] -> c)
+           -> Compiler b c
+requireAll pattern f =
+    addDependencies getDeps >>> fromCompilerM requireAll'
+  where
+    getDeps = matches pattern . resourceList
+    requireAll' x = CompilerM $ do
+        deps <- getDeps . compilerResourceProvider <$> ask
+        lookup' <- compilerDependencyLookup <$> ask
+        return $ f x $ map (unCompiledItem . lookup') deps
 
+{-
 -- | Construct a target from a string, this string being the content of the
 -- resource.
 --
diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs
index 3bd1e6b..911e2f9 100644
--- a/src/Hakyll/Core/Run.hs
+++ b/src/Hakyll/Core/Run.hs
@@ -40,7 +40,7 @@ hakyllWith rules provider store = do
 
         -- Get all dependencies
         dependencies = flip map compilers $ \(id', compiler) ->
-            let deps = compilerDependencies compiler
+            let deps = getDependencies compiler provider
             in (id', deps)
 
         -- Create a compiler map
diff --git a/src/Hakyll/Core/Util/Arrow.hs b/src/Hakyll/Core/Util/Arrow.hs
new file mode 100644
index 0000000..d25bc28
--- /dev/null
+++ b/src/Hakyll/Core/Util/Arrow.hs
@@ -0,0 +1,28 @@
+-- | Various arrow utility functions
+--
+module Hakyll.Core.Util.Arrow
+    ( sequenceArr
+    , unitArr
+    , withUnitArr
+    ) where
+
+import Prelude hiding (id)
+import Control.Arrow (Arrow, (&&&), (>>>), arr, (***))
+import Control.Category (id)
+
+sequenceArr :: Arrow a
+            => [a b c]
+            -> a b [c]
+sequenceArr = foldl reduce $ arr $ const []
+  where
+    reduce la xa = xa &&& la >>> arr (uncurry (:))
+
+unitArr :: Arrow a
+        => a b ()
+unitArr = arr (const ())
+
+withUnitArr :: Arrow a
+            => a b  c
+            -> a () d
+            -> a b  (c, d)
+withUnitArr a1 a2 = a1 &&& unitArr >>> id *** a2
diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs
index 653c711..c03c6ca 100644
--- a/src/Hakyll/Web/Pandoc.hs
+++ b/src/Hakyll/Web/Pandoc.hs
@@ -7,25 +7,27 @@ module Hakyll.Web.Pandoc
     , writePandoc
     , writePandocWith
 
-      -- * Functions working on pages/targets
-    {-
+      -- * Functions working on pages/compilers
     , pageReadPandoc
     , pageReadPandocWith
     , pageRenderPandoc
     , pageRenderPandocWith
-    -}
 
       -- * Default options
     , defaultParserState
     , defaultWriterOptions
     ) where
 
+import Prelude hiding (id)
 import Control.Applicative ((<$>))
+import Control.Arrow ((>>>), arr)
+import Control.Category (id)
 
 import Text.Pandoc (Pandoc)
 import qualified Text.Pandoc as P
 
 import Hakyll.Core.Compiler
+import Hakyll.Core.Util.Arrow
 import Hakyll.Web.FileType
 import Hakyll.Web.Page
 
@@ -64,34 +66,31 @@ writePandocWith :: P.WriterOptions  -- ^ Writer options for pandoc
                 -> String           -- ^ Resulting HTML
 writePandocWith = P.writeHtmlString
 
-{-
 -- | Read the resource using pandoc
 --
-pageReadPandoc :: Page String -> TargetM (Page Pandoc)
+pageReadPandoc :: Compiler (Page String) (Page Pandoc)
 pageReadPandoc = pageReadPandocWith defaultParserState
 
 -- | Read the resource using pandoc
 --
-pageReadPandocWith :: P.ParserState -> Page String -> TargetM (Page Pandoc)
-pageReadPandocWith state page = do
-    fileType' <- getFileType
-    return $ readPandocWith state fileType' <$> page
+pageReadPandocWith :: P.ParserState -> Compiler (Page String) (Page Pandoc)
+pageReadPandocWith state =
+    withUnitArr id getFileType >>> arr pageReadPandocWith'
+  where
+    pageReadPandocWith' (p, t) = readPandocWith state t <$> p
 
 -- | Render the resource using pandoc
 --
-pageRenderPandoc :: Page String -> TargetM (Page String)
+pageRenderPandoc :: Compiler (Page String) (Page String)
 pageRenderPandoc = pageRenderPandocWith defaultParserState defaultWriterOptions
 
 -- | Render the resource using pandoc
 --
 pageRenderPandocWith :: P.ParserState
                      -> P.WriterOptions
-                     -> Page String
-                     -> TargetM (Page String)
-pageRenderPandocWith state options page = do
-    pandoc <- pageReadPandocWith state page
-    return $ writePandocWith options <$> pandoc
--}
+                     -> Compiler (Page String) (Page String)
+pageRenderPandocWith state options =
+    pageReadPandocWith state >>> arr (fmap $ writePandocWith options)
 
 -- | The default reader options for pandoc parsing in hakyll
 --