Fix dependency handling for snapshots

4 files changed, 62 insertions, 32 deletions

diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index a6814f9..2fc60ce 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -135,7 +135,9 @@ saveSnapshot snapshot item = do
     compilerUnsafeIO $ do
         Logger.debug logger $ "Storing snapshot: " ++ snapshot
         Internal.saveSnapshot store snapshot item
-        return item
+
+    -- Signal that we saved the snapshot.
+    Compiler $ \_ -> return $ CompilerSnapshot snapshot (return item)
 
 
 --------------------------------------------------------------------------------
diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs
index 8424d69..ed7880f 100644
--- a/src/Hakyll/Core/Compiler/Internal.hs
+++ b/src/Hakyll/Core/Compiler/Internal.hs
@@ -6,7 +6,8 @@
 {-# LANGUAGE MultiParamTypeClasses      #-}
 module Hakyll.Core.Compiler.Internal
     ( -- * Types
-      CompilerRead (..)
+      Snapshot
+    , CompilerRead (..)
     , CompilerWrite (..)
     , CompilerResult (..)
     , Compiler (..)
@@ -51,6 +52,12 @@ import           Hakyll.Core.Store
 
 
 --------------------------------------------------------------------------------
+-- | Whilst compiling an item, it possible to save multiple snapshots of it, and
+-- not just the final result.
+type Snapshot = String
+
+
+--------------------------------------------------------------------------------
 -- | Environment in which a compiler runs
 data CompilerRead = CompilerRead
     { -- | Main configuration
@@ -86,9 +93,10 @@ instance Monoid CompilerWrite where
 
 --------------------------------------------------------------------------------
 data CompilerResult a where
-    CompilerDone    :: a -> CompilerWrite -> CompilerResult a
-    CompilerError   :: [String] -> CompilerResult a
-    CompilerRequire :: Identifier -> Compiler a -> CompilerResult a
+    CompilerDone     :: a -> CompilerWrite -> CompilerResult a
+    CompilerSnapshot :: Snapshot -> Compiler a -> CompilerResult a
+    CompilerError    :: [String] -> CompilerResult a
+    CompilerRequire  :: (Identifier, Snapshot) -> Compiler a -> CompilerResult a
 
 
 --------------------------------------------------------------------------------
@@ -104,9 +112,10 @@ instance Functor Compiler where
     fmap f (Compiler c) = Compiler $ \r -> do
         res <- c r
         return $ case res of
-            CompilerDone x w     -> CompilerDone (f x) w
-            CompilerError e      -> CompilerError e
-            CompilerRequire i c' -> CompilerRequire i (fmap f c')
+            CompilerDone x w      -> CompilerDone (f x) w
+            CompilerSnapshot s c' -> CompilerSnapshot s (fmap f c')
+            CompilerError e       -> CompilerError e
+            CompilerRequire i c'  -> CompilerRequire i (fmap f c')
     {-# INLINE fmap #-}
 
 
@@ -121,14 +130,16 @@ instance Monad Compiler where
             CompilerDone x w    -> do
                 res' <- unCompiler (f x) r
                 return $ case res' of
-                    CompilerDone y w'    -> CompilerDone y (w `mappend` w')
-                    CompilerError e      -> CompilerError e
-                    CompilerRequire i c' -> CompilerRequire i $ do
+                    CompilerDone y w'     -> CompilerDone y (w `mappend` w')
+                    CompilerSnapshot s c' -> CompilerSnapshot s c'
+                    CompilerError e       -> CompilerError e
+                    CompilerRequire i c'  -> CompilerRequire i $ do
                         compilerTell w  -- Save dependencies!
                         c'
 
-            CompilerError e      -> return $ CompilerError e
-            CompilerRequire i c' -> return $ CompilerRequire i $ c' >>= f
+            CompilerSnapshot s c' -> return $ CompilerSnapshot s (c' >>= f)
+            CompilerError e       -> return $ CompilerError e
+            CompilerRequire i c'  -> return $ CompilerRequire i (c' >>= f)
     {-# INLINE (>>=) #-}
 
     fail = compilerThrow . return
@@ -198,9 +209,10 @@ compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a
 compilerCatch (Compiler x) f = Compiler $ \r -> do
     res <- x r
     case res of
-        CompilerDone res' w -> return (CompilerDone res' w)
-        CompilerError e     -> unCompiler (f e) r
-        CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))
+        CompilerDone res' w  -> return (CompilerDone res' w)
+        CompilerSnapshot s c -> return (CompilerSnapshot s (compilerCatch c f))
+        CompilerError e      -> unCompiler (f e) r
+        CompilerRequire i c  -> return (CompilerRequire i (compilerCatch c f))
 {-# INLINE compilerCatch #-}
 
 
diff --git a/src/Hakyll/Core/Compiler/Require.hs b/src/Hakyll/Core/Compiler/Require.hs
index 0811e5d..d7635a9 100644
--- a/src/Hakyll/Core/Compiler/Require.hs
+++ b/src/Hakyll/Core/Compiler/Require.hs
@@ -32,12 +32,6 @@ import qualified Hakyll.Core.Store              as Store
 
 
 --------------------------------------------------------------------------------
--- | Whilst compiling an item, it possible to save multiple snapshots of it, and
--- not just the final result.
-type Snapshot = String
-
-
---------------------------------------------------------------------------------
 save :: (Binary a, Typeable a) => Store -> Item a -> IO ()
 save store item = saveSnapshot store final item
 
@@ -70,7 +64,7 @@ loadSnapshot id' snapshot = do
     when (id' `S.notMember` universe) $ fail notFound
 
     compilerTellDependencies [IdentifierDependency id']
-    compilerResult $ CompilerRequire id' $ do
+    compilerResult $ CompilerRequire (id', snapshot) $ do
         result <- compilerUnsafeIO $ Store.get store (key id' snapshot)
         case result of
             Store.NotFound      -> fail notFound
diff --git a/src/Hakyll/Core/Runtime.hs b/src/Hakyll/Core/Runtime.hs
index 824d11b..3809936 100644
--- a/src/Hakyll/Core/Runtime.hs
+++ b/src/Hakyll/Core/Runtime.hs
@@ -71,9 +71,10 @@ run config verbosity rules = do
             , runtimeUniverse      = M.fromList compilers
             }
         state     = RuntimeState
-            { runtimeDone  = S.empty
-            , runtimeTodo  = M.empty
-            , runtimeFacts = oldFacts
+            { runtimeDone      = S.empty
+            , runtimeSnapshots = S.empty
+            , runtimeTodo      = M.empty
+            , runtimeFacts     = oldFacts
             }
 
     -- Run the program and fetch the resulting state
@@ -109,9 +110,10 @@ data RuntimeRead = RuntimeRead
 
 --------------------------------------------------------------------------------
 data RuntimeState = RuntimeState
-    { runtimeDone  :: Set Identifier
-    , runtimeTodo  :: Map Identifier (Compiler SomeItem)
-    , runtimeFacts :: DependencyFacts
+    { runtimeDone      :: Set Identifier
+    , runtimeSnapshots :: Set (Identifier, Snapshot)
+    , runtimeTodo      :: Map Identifier (Compiler SomeItem)
+    , runtimeFacts     :: DependencyFacts
     }
 
 
@@ -204,6 +206,16 @@ chase trail id'
                 "Compiler failed but no info given, try running with -v?"
             CompilerError es -> throwError $ intercalate "; " es
 
+            -- Signal that a snapshot was saved ->
+            CompilerSnapshot snapshot c -> do
+                -- Update info and just continue.
+                modify $ \s -> s
+                    { runtimeSnapshots =
+                        S.insert (id', snapshot) (runtimeSnapshots s)
+                    , runtimeTodo      = M.insert id' c (runtimeTodo s)
+                    }
+                chase trail id'
+
             -- Huge success
             CompilerDone (SomeItem item) cwrite -> do
                 -- Print some info
@@ -243,7 +255,16 @@ chase trail id'
             -- Try something else first
             CompilerRequire dep c -> do
                 -- Update the compiler so we don't execute it twice
-                depDone <- (dep `S.member`) . runtimeDone <$> get
+                let (depId, depSnapshot) = dep
+                done      <- runtimeDone <$> get
+                snapshots <- runtimeSnapshots <$> get
+
+                -- Done if we either completed the entire item (runtimeDone) or
+                -- if we previously saved the snapshot (runtimeSnapshots).
+                let depDone =
+                        depId `S.member` done ||
+                        (depId, depSnapshot) `S.member` snapshots
+
                 modify $ \s -> s
                     { runtimeTodo = M.insert id'
                         (if depDone then c else compilerResult result)
@@ -252,6 +273,7 @@ chase trail id'
 
                 -- If the required item is already compiled, continue, or, start
                 -- chasing that
-                Logger.debug logger $ "Require " ++ show dep ++ ": " ++
+                Logger.debug logger $ "Require " ++ show depId ++
+                    " (snapshot " ++ depSnapshot ++ "): " ++
                     (if depDone then "OK" else "chasing")
-                if depDone then chase trail id' else chase (id' : trail) dep
+                if depDone then chase trail id' else chase (id' : trail) depId