Add snapshots

3 files changed, 77 insertions, 22 deletions

diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index c542ce7..94f1ef2 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -10,9 +10,16 @@ module Hakyll.Core.Compiler
     , getResourceString
     , getResourceLBS
     , getResourceWith
-    , require
-    , requireBody
-    , requireAll
+
+    , Internal.Snapshot
+    , saveSnapshot
+    , Internal.require
+    , Internal.requireSnapshot
+    , Internal.requireBody
+    , Internal.requireSnapshotBody
+    , Internal.requireAll
+    , Internal.requireAllSnapshots
+
     , cached
     , unsafeCompiler
     , debugCompiler
@@ -30,7 +37,7 @@ import           System.Environment            (getProgName)
 
 --------------------------------------------------------------------------------
 import           Hakyll.Core.Compiler.Internal
-import           Hakyll.Core.Compiler.Require
+import qualified Hakyll.Core.Compiler.Require  as Internal
 import           Hakyll.Core.Identifier
 import           Hakyll.Core.Item
 import           Hakyll.Core.Logger            as Logger
@@ -94,6 +101,14 @@ getResourceWith reader = do
 
 
 --------------------------------------------------------------------------------
+saveSnapshot :: (Binary a, Typeable a)
+             => Internal.Snapshot -> Item a -> Compiler ()
+saveSnapshot snapshot item = do
+    store <- compilerStore <$> compilerAsk
+    compilerUnsafeIO $ Internal.saveSnapshot store snapshot item
+
+
+--------------------------------------------------------------------------------
 cached :: (Binary a, Typeable a)
        => String
        -> Compiler a
diff --git a/src/Hakyll/Core/Compiler/Require.hs b/src/Hakyll/Core/Compiler/Require.hs
index b9e0cc7..3c6ddfc 100644
--- a/src/Hakyll/Core/Compiler/Require.hs
+++ b/src/Hakyll/Core/Compiler/Require.hs
@@ -1,9 +1,14 @@
 --------------------------------------------------------------------------------
 module Hakyll.Core.Compiler.Require
-    ( save
+    ( Snapshot
+    , save
+    , saveSnapshot
     , require
+    , requireSnapshot
     , requireBody
+    , requireSnapshotBody
     , requireAll
+    , requireAllSnapshots
     ) where
 
 
@@ -25,45 +30,82 @@ import qualified Hakyll.Core.Store              as Store
 
 
 --------------------------------------------------------------------------------
-save :: (Binary a, Typeable a) => Store -> Identifier -> a -> IO ()
-save store identifier x = Store.set store (key identifier) x
+type Snapshot = String
+
+
+--------------------------------------------------------------------------------
+save :: (Binary a, Typeable a) => Store -> Item a -> IO ()
+save store item = saveSnapshot store final item
+
+
+--------------------------------------------------------------------------------
+saveSnapshot :: (Binary a, Typeable a)
+             => Store -> Snapshot -> Item a -> IO ()
+saveSnapshot store snapshot item =
+    Store.set store (key (itemIdentifier item) snapshot) (itemBody item)
 
 
 --------------------------------------------------------------------------------
 require :: (Binary a, Typeable a) => Identifier -> Compiler (Item a)
-require id' = do
+require id' = requireSnapshot id' final
+
+
+--------------------------------------------------------------------------------
+requireSnapshot :: (Binary a, Typeable a)
+                => Identifier -> Snapshot -> Compiler (Item a)
+requireSnapshot id' snapshot = do
     store <- compilerStore <$> compilerAsk
 
     compilerTellDependencies [IdentifierDependency id']
     compilerResult $ CompilerRequire id' $ do
-        result <- compilerUnsafeIO $ Store.get store (key id')
+        result <- compilerUnsafeIO $ Store.get store (key id' snapshot)
         case result of
             Store.NotFound      -> compilerThrow notFound
             Store.WrongType e r -> compilerThrow $ wrongType e r
             Store.Found x       -> return $ Item id' x
   where
     notFound =
-        "Hakyll.Core.Compiler.Require.require: " ++ show id' ++ " was " ++
-        "not found in the cache, the cache might be corrupted or " ++
+        "Hakyll.Core.Compiler.Require.require: " ++ show id' ++
+        " (snapshot " ++ snapshot ++ ") was not found in the cache, " ++
+        "the cache might be corrupted or " ++
         "the item you are referring to might not exist"
     wrongType e r =
-        "Hakyll.Core.Compiler.Require.require: " ++ show id' ++ " was found " ++
-        "in the cache, but does not have the right type: expected " ++ show e ++
+        "Hakyll.Core.Compiler.Require.require: " ++ show id' ++
+        " (snapshot " ++ snapshot ++ ") was found in the cache, " ++
+        "but does not have the right type: expected " ++ show e ++
         " but got " ++ show r
 
 
 --------------------------------------------------------------------------------
 requireBody :: (Binary a, Typeable a) => Identifier -> Compiler a
-requireBody = fmap itemBody . require
+requireBody id' = requireSnapshotBody id' final
+
+
+--------------------------------------------------------------------------------
+requireSnapshotBody :: (Binary a, Typeable a)
+                    => Identifier -> Snapshot -> Compiler a
+requireSnapshotBody id' snapshot = fmap itemBody $ requireSnapshot id' snapshot
 
 
 --------------------------------------------------------------------------------
 requireAll :: (Binary a, Typeable a) => Pattern -> Compiler [Item a]
-requireAll pattern = do
+requireAll pattern = requireAllSnapshots pattern final
+
+
+--------------------------------------------------------------------------------
+requireAllSnapshots :: (Binary a, Typeable a)
+                    => Pattern -> Snapshot -> Compiler [Item a]
+requireAllSnapshots pattern snapshot = do
     matching <- getMatches pattern
-    mapM require matching
+    mapM (\i -> requireSnapshot i snapshot) matching
+
+
+--------------------------------------------------------------------------------
+key :: Identifier -> String -> [String]
+key identifier snapshot =
+    ["Hakyll.Core.Compiler.Require", show identifier, snapshot]
 
 
 --------------------------------------------------------------------------------
-key :: Identifier -> [String]
-key identifier = ["Hakyll.Core.Compiler.Require", show identifier]
+final :: Snapshot
+final = "final"
diff --git a/src/Hakyll/Core/Runtime.hs b/src/Hakyll/Core/Runtime.hs
index 96b21cd..cdc7fdb 100644
--- a/src/Hakyll/Core/Runtime.hs
+++ b/src/Hakyll/Core/Runtime.hs
@@ -27,7 +27,6 @@ import           Hakyll.Core.Compiler.Require
 import           Hakyll.Core.Configuration
 import           Hakyll.Core.Dependencies
 import           Hakyll.Core.Identifier
-import           Hakyll.Core.Item
 import           Hakyll.Core.Item.SomeItem
 import           Hakyll.Core.Logger            (Logger)
 import qualified Hakyll.Core.Logger            as Logger
@@ -194,8 +193,7 @@ chase trail id'
             -- Huge success
             CompilerDone (SomeItem item) cwrite -> do
                 -- TODO: Sanity check on itemIdentifier?
-                let body      = itemBody item
-                    facts     = compilerDependencies cwrite
+                let facts     = compilerDependencies cwrite
                     cacheHits
                         | compilerCacheHits cwrite <= 0 = "updated"
                         | otherwise                     = "cached "
@@ -213,7 +211,7 @@ chase trail id'
                         Logger.debug logger $ "Routed to " ++ path
 
                 -- Save! (For require)
-                liftIO $ save store id' body
+                liftIO $ save store item
 
                 -- Update state
                 modify $ \s -> s