summaryrefslogtreecommitdiff
path: root/src/Hakyll/Core
diff options
context:
space:
mode:
Diffstat (limited to 'src/Hakyll/Core')
-rw-r--r--src/Hakyll/Core/Compiler.hs4
-rw-r--r--src/Hakyll/Core/Compiler/Internal.hs42
-rw-r--r--src/Hakyll/Core/Compiler/Require.hs8
-rw-r--r--src/Hakyll/Core/Runtime.hs40
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 11:25:27 +0000