Prototype of the 'cached' arrow transformer

5 files changed, 50 insertions, 22 deletions

diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index 5678b0a..67724bd 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -8,6 +8,7 @@ module Hakyll.Core.Compiler
     , getResourceString
     , require
     , requireAll
+    , cached
     ) where
 
 import Prelude hiding ((.), id)
@@ -26,6 +27,7 @@ import Hakyll.Core.CompiledItem
 import Hakyll.Core.Writable
 import Hakyll.Core.ResourceProvider
 import Hakyll.Core.Compiler.Internal
+import Hakyll.Core.Store
 
 -- | Get the identifier of the item that is currently being compiled
 --
@@ -75,3 +77,24 @@ requireAll pattern f =
         deps <- getDeps . compilerResourceProvider <$> ask
         lookup' <- compilerDependencyLookup <$> ask
         return $ f x $ map (unCompiledItem . lookup') deps
+
+cached :: (Binary a)
+       => String
+       -> Compiler () a
+       -> Compiler () a
+cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do
+    provider <- compilerResourceProvider <$> ask
+    identifier <- compilerIdentifier <$> ask
+    store <- compilerStore <$> ask
+    modified <- liftIO $ resourceModified provider identifier store
+    liftIO $ putStrLn $
+        show identifier ++ ": " ++ if modified then "MODIFIED" else "OK"
+    if modified
+        then do v <- unCompilerM $ j ()
+                liftIO $ storeSet store name identifier v
+                return v
+        else do v <- liftIO $ storeGet store name identifier
+                case v of Just v' -> return v'
+                          Nothing -> error'
+  where
+    error' = error "Hakyll.Core.Compiler.cached: Cache corrupt!"
diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs
index eee67ef..4209bdc 100644
--- a/src/Hakyll/Core/Compiler/Internal.hs
+++ b/src/Hakyll/Core/Compiler/Internal.hs
@@ -24,6 +24,7 @@ import Control.Arrow (Arrow, arr, first)
 import Hakyll.Core.Identifier
 import Hakyll.Core.CompiledItem
 import Hakyll.Core.ResourceProvider
+import Hakyll.Core.Store
 
 -- | A set of dependencies
 --
@@ -40,6 +41,7 @@ data CompilerEnvironment = CompilerEnvironment
     , compilerResourceProvider :: ResourceProvider  -- ^ Resource provider
     , compilerDependencyLookup :: DependencyLookup  -- ^ Dependency lookup
     , compilerRoute            :: Maybe FilePath    -- ^ Site route
+    , compilerStore            :: Store             -- ^ Compiler store
     }
 
 -- | The compiler monad
@@ -73,8 +75,9 @@ runCompilerJob :: Compiler () a     -- ^ Compiler to run
                -> ResourceProvider  -- ^ Resource provider
                -> DependencyLookup  -- ^ Dependency lookup table
                -> Maybe FilePath    -- ^ Route
+               -> Store             -- ^ Store
                -> IO a
-runCompilerJob compiler identifier provider lookup' route =
+runCompilerJob compiler identifier provider lookup' route store =
     runReaderT (unCompilerM $ compilerJob compiler ()) env
   where
     env = CompilerEnvironment
@@ -82,6 +85,7 @@ runCompilerJob compiler identifier provider lookup' route =
             , compilerResourceProvider = provider
             , compilerDependencyLookup = lookup'
             , compilerRoute            = route
+            , compilerStore            = store
             }
 
 runCompilerDependencies :: Compiler () a
diff --git a/src/Hakyll/Core/ResourceProvider.hs b/src/Hakyll/Core/ResourceProvider.hs
index ba249ca..c522ab6 100644
--- a/src/Hakyll/Core/ResourceProvider.hs
+++ b/src/Hakyll/Core/ResourceProvider.hs
@@ -5,6 +5,7 @@
 module Hakyll.Core.ResourceProvider
     ( ResourceProvider (..)
     , resourceDigest
+    , resourceModified
     ) where
 
 import Control.Monad ((<=<))
@@ -15,6 +16,7 @@ import OpenSSL.Digest.ByteString.Lazy (digest)
 import OpenSSL.Digest (MessageDigest (MD5))
 
 import Hakyll.Core.Identifier
+import Hakyll.Core.Store
 
 -- | A value responsible for retrieving and listing resources
 --
@@ -31,3 +33,21 @@ data ResourceProvider = ResourceProvider
 --
 resourceDigest :: ResourceProvider -> Identifier -> IO [Word8]
 resourceDigest provider = digest MD5 <=< resourceLazyByteString provider
+
+-- | Check if a resource was modified
+--
+resourceModified :: ResourceProvider -> Identifier -> Store -> IO Bool
+resourceModified provider identifier store = do
+    -- Get the latest seen digest from the store
+    lastDigest <- storeGet store itemName identifier
+    -- Calculate the digest for the resource
+    newDigest <- resourceDigest provider identifier
+    -- Check digests
+    if Just newDigest == lastDigest
+        -- All is fine, not modified
+        then return False
+        -- Resource modified; store new digest
+        else do storeSet store itemName identifier newDigest
+                return True
+  where
+    itemName = "Hakyll.Core.ResourceProvider.resourceModified"
diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs
index ccb731c..636f9e4 100644
--- a/src/Hakyll/Core/Run.hs
+++ b/src/Hakyll/Core/Run.hs
@@ -67,7 +67,8 @@ hakyllWith rules provider store = do
   where
     addTarget route' map' (id', comp) = do
         let url = runRoute route' id'
-        compiled <- runCompilerJob comp id' provider (dependencyLookup map') url
+        compiled <- runCompilerJob comp id' provider (dependencyLookup map')
+                                   url store
         putStrLn $ "Generated target: " ++ show id'
 
         case url of
diff --git a/src/Hakyll/Core/Store.hs b/src/Hakyll/Core/Store.hs
index 7e57df2..02b9b4e 100644
--- a/src/Hakyll/Core/Store.hs
+++ b/src/Hakyll/Core/Store.hs
@@ -5,7 +5,6 @@ module Hakyll.Core.Store
     , makeStore
     , storeSet
     , storeGet
-    , wasModified
     ) where
 
 import Control.Applicative ((<$>))
@@ -16,7 +15,6 @@ import Data.Binary (Binary, encodeFile, decodeFile)
 
 import Hakyll.Core.Identifier
 import Hakyll.Core.Util.File
-import Hakyll.Core.ResourceProvider
 
 -- | Data structure used for the store
 --
@@ -53,21 +51,3 @@ storeGet store name identifier = do
               else return Nothing
   where
     path = makePath store name identifier
-
--- | Check if a resource was modified
---
-wasModified :: Store -> ResourceProvider -> Identifier -> IO Bool
-wasModified store provider identifier = do
-    -- Get the latest seen digest from the store
-    lastDigest <- storeGet store itemName identifier
-    -- Calculate the digest for the resource
-    newDigest <- resourceDigest provider identifier
-    -- Check digests
-    if Just newDigest == lastDigest
-        -- All is fine, not modified
-        then return False
-        -- Resource modified; store new digest
-        else do storeSet store itemName identifier newDigest
-                return True
-  where
-    itemName = "Hakyll.Core.Store.wasModified"