Add snapshots

src/Hakyll/Core/Compiler.hs

@@ -10,9 +10,16 @@ module Hakyll.Core.Compiler
     , getResourceString
     , getResourceLBS
     , getResourceWith
-    , require
+
-    , requireBody
+    , Internal.Snapshot
-    , requireAll
+    , 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
@@ -93,6 +100,14 @@ getResourceWith reader = do
         show fp ++ " not found"
 
 
+--------------------------------------------------------------------------------
+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

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 ()
+type Snapshot = String
-save store identifier x = Store.set store (key identifier) x
+
+
+--------------------------------------------------------------------------------
+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 " ++
+        "Hakyll.Core.Compiler.Require.require: " ++ show id' ++
-        "not found in the cache, the cache might be corrupted or " ++
+        " (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 " ++
+        "Hakyll.Core.Compiler.Require.require: " ++ show id' ++
-        "in the cache, but does not have the right type: expected " ++ show e ++
+        " (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
-    matching <- getMatches pattern
-    mapM require matching
 
 
 --------------------------------------------------------------------------------
-key :: Identifier -> [String]
+requireAllSnapshots :: (Binary a, Typeable a)
-key identifier = ["Hakyll.Core.Compiler.Require", show identifier]
+                    => Pattern -> Snapshot -> Compiler [Item a]
+requireAllSnapshots pattern snapshot = do
+    matching <- getMatches pattern
+    mapM (\i -> requireSnapshot i snapshot) matching
+
+
+--------------------------------------------------------------------------------
+key :: Identifier -> String -> [String]
+key identifier snapshot =
+    ["Hakyll.Core.Compiler.Require", show identifier, snapshot]
+
+
+--------------------------------------------------------------------------------
+final :: Snapshot
+final = "final"

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
+                let facts     = compilerDependencies cwrite
-                    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

src/Hakyll/Main.hs

@@ -1,39 +1,47 @@
+--------------------------------------------------------------------------------
 -- | Module providing the main hakyll function and command-line argument parsing
---
 {-# LANGUAGE CPP #-}
 module Hakyll.Main
     ( hakyll
     , hakyllWith
     ) where
 
-import Control.Monad (when)
-import System.Directory (doesDirectoryExist, removeDirectoryRecursive)
-import System.Environment (getProgName, getArgs)
-import System.Process (system)
 
-import Hakyll.Core.Configuration
+--------------------------------------------------------------------------------
-import Hakyll.Core.Identifier
+import           Control.Monad              (when)
-import Hakyll.Core.Runtime
+import           System.Directory           (doesDirectoryExist,
-import Hakyll.Core.Rules
+                                             removeDirectoryRecursive)
+import           System.Environment         (getArgs, getProgName)
+import           System.Process             (system)
 
+
+--------------------------------------------------------------------------------
+import           Hakyll.Core.Configuration
+import           Hakyll.Core.Rules
+import           Hakyll.Core.Runtime
+
+
+--------------------------------------------------------------------------------
 #ifdef PREVIEW_SERVER
-import Control.Applicative ((<$>))
+import           Control.Applicative        ((<$>))
-import Control.Concurrent (forkIO)
+import           Control.Concurrent         (forkIO)
-import qualified Data.Set as S
+import qualified Data.Set                   as S
-
+import           Hakyll.Core.Identifier
-import Hakyll.Core.Rules.Internal
+import           Hakyll.Core.Rules.Internal
-import Hakyll.Web.Preview.Poll
+import           Hakyll.Web.Preview.Poll
-import Hakyll.Web.Preview.Server
+import           Hakyll.Web.Preview.Server
 #endif
 
+
+--------------------------------------------------------------------------------
 -- | This usualy is the function with which the user runs the hakyll compiler
---
 hakyll :: Rules a -> IO ()
 hakyll = hakyllWith defaultConfiguration
 
+
+--------------------------------------------------------------------------------
 -- | A variant of 'hakyll' which allows the user to specify a custom
 -- configuration
---
 hakyllWith :: Configuration -> Rules a -> IO ()
 hakyllWith conf rules = do
     args <- getArgs
@@ -49,15 +57,17 @@ hakyllWith conf rules = do
         ["deploy"]     -> deploy conf
         _              -> help
 
+
+--------------------------------------------------------------------------------
 -- | Build the site
---
 build :: Configuration -> Rules a -> IO ()
 build conf rules = do
     _ <- run conf rules
     return ()
 
+
+--------------------------------------------------------------------------------
 -- | Remove the output directories
---
 clean :: Configuration -> IO ()
 clean conf = do
     remove $ destinationDirectory conf
@@ -68,8 +78,9 @@ clean conf = do
         exists <- doesDirectoryExist dir
         when exists $ removeDirectoryRecursive dir
 
+
+--------------------------------------------------------------------------------
 -- | Show usage information.
---
 help :: IO ()
 help = do
     name <- getProgName
@@ -95,8 +106,9 @@ help = do
     previewServerDisabled
 #endif
 
+
+--------------------------------------------------------------------------------
 -- | Preview the site
---
 preview :: Configuration -> Rules a -> Int -> IO ()
 #ifdef PREVIEW_SERVER
 preview conf rules port = do
@@ -111,15 +123,17 @@ preview conf rules port = do
 preview _ _ _ = previewServerDisabled
 #endif
 
+
+--------------------------------------------------------------------------------
 -- | Rebuild the site
---
 rebuild :: Configuration -> Rules a -> IO ()
 rebuild conf rules = do
     clean conf
     build conf rules
 
+
+--------------------------------------------------------------------------------
 -- | Start a server
---
 server :: Configuration -> Int -> IO ()
 #ifdef PREVIEW_SERVER
 server conf port = do
@@ -131,15 +145,17 @@ server conf port = do
 server _ _ = previewServerDisabled
 #endif
 
+
+--------------------------------------------------------------------------------
 -- | Upload the site
---
 deploy :: Configuration -> IO ()
 deploy conf = do
     _ <- system $ deployCommand conf
     return ()
 
+
+--------------------------------------------------------------------------------
 -- | Print a warning message about the preview serving not being enabled
---
 #ifndef PREVIEW_SERVER
 previewServerDisabled :: IO ()
 previewServerDisabled =

tests/Hakyll/Core/Runtime/Tests.hs

@@ -6,17 +6,14 @@ module Hakyll.Core.Runtime.Tests
 
 
 --------------------------------------------------------------------------------
-import           System.FilePath           ((</>))
+import           System.FilePath     ((</>))
-import           Test.Framework            (Test, testGroup)
+import           Test.Framework      (Test, testGroup)
-import           Test.HUnit                (Assertion, (@?=))
+import           Test.HUnit          (Assertion, (@?=))
 
 
 --------------------------------------------------------------------------------
-import           Hakyll.Core.Configuration
+import           Hakyll
-import           Hakyll.Core.Routes
-import           Hakyll.Core.Rules
 import           Hakyll.Core.Runtime
-import           Hakyll.Web.Page
 import           TestSuite.Util
 
 
@@ -31,7 +28,18 @@ case01 = withTestConfiguration $ \config -> do
     _ <- run config $ do
         match "*.md" $ do
             route   $ setExtension "html"
-            compile $ pageCompiler
+            compile $ do
+                body <- getResourceBody
+                saveSnapshot "raw" body
+                return $ renderPandoc body
 
-    out <- readFile $ destinationDirectory config </> "example.html"
+        match "bodies.txt" $ route idRoute
-    lines out @?=  ["<p>This is an example.</p>"]
+        create "bodies.txt" $ do
+            items <- requireAllSnapshots "*.md" "raw" :: Compiler [Item String]
+            makeItem $ concat $ map itemBody items
+
+    example <- readFile $ destinationDirectory config </> "example.html"
+    lines example @?=  ["<p>This is an example.</p>"]
+
+    bodies <- readFile $ destinationDirectory config </> "bodies.txt"
+    head (lines bodies) @?=  "This is an example."

tests/Hakyll/Core/Store/Tests.hs

@@ -61,7 +61,6 @@ wrongType = withTestStore $ \store -> do
     -- Store a string and try to fetch an int
     Store.set store ["foo", "bar"] ("qux" :: String)
     value <- Store.get store ["foo", "bar"] :: IO (Store.Result Int)
-    print value
     H.assert $ case value of
         Store.WrongType e t ->
             e == typeOf (undefined :: Int) &&