diff options
| -rw-r--r-- | src/Hakyll/Core/Compiler.hs | 23 | ||||
| -rw-r--r-- | src/Hakyll/Core/Compiler/Require.hs | 70 | ||||
| -rw-r--r-- | src/Hakyll/Core/Runtime.hs | 6 | ||||
| -rw-r--r-- | src/Hakyll/Main.hs | 68 | ||||
| -rw-r--r-- | tests/Hakyll/Core/Runtime/Tests.hs | 28 | ||||
| -rw-r--r-- | tests/Hakyll/Core/Store/Tests.hs | 1 |
6 files changed, 137 insertions, 59 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 diff --git a/src/Hakyll/Main.hs b/src/Hakyll/Main.hs index e0f5b93..37dc0fa 100644 --- a/src/Hakyll/Main.hs +++ b/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 Hakyll.Core.Runtime -import Hakyll.Core.Rules +-------------------------------------------------------------------------------- +import Control.Monad (when) +import System.Directory (doesDirectoryExist, + removeDirectoryRecursive) +import System.Environment (getArgs, getProgName) +import System.Process (system) -#ifdef PREVIEW_SERVER -import Control.Applicative ((<$>)) -import Control.Concurrent (forkIO) -import qualified Data.Set as S -import Hakyll.Core.Rules.Internal -import Hakyll.Web.Preview.Poll -import Hakyll.Web.Preview.Server +-------------------------------------------------------------------------------- +import Hakyll.Core.Configuration +import Hakyll.Core.Rules +import Hakyll.Core.Runtime + + +-------------------------------------------------------------------------------- +#ifdef PREVIEW_SERVER +import Control.Applicative ((<$>)) +import Control.Concurrent (forkIO) +import qualified Data.Set as S +import Hakyll.Core.Identifier +import Hakyll.Core.Rules.Internal +import Hakyll.Web.Preview.Poll +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 = diff --git a/tests/Hakyll/Core/Runtime/Tests.hs b/tests/Hakyll/Core/Runtime/Tests.hs index bb39a5f..0d202c7 100644 --- a/tests/Hakyll/Core/Runtime/Tests.hs +++ b/tests/Hakyll/Core/Runtime/Tests.hs @@ -6,17 +6,14 @@ module Hakyll.Core.Runtime.Tests -------------------------------------------------------------------------------- -import System.FilePath ((</>)) -import Test.Framework (Test, testGroup) -import Test.HUnit (Assertion, (@?=)) +import System.FilePath ((</>)) +import Test.Framework (Test, testGroup) +import Test.HUnit (Assertion, (@?=)) -------------------------------------------------------------------------------- -import Hakyll.Core.Configuration -import Hakyll.Core.Routes -import Hakyll.Core.Rules +import Hakyll 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" - lines out @?= ["<p>This is an example.</p>"] + match "bodies.txt" $ route idRoute + 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." diff --git a/tests/Hakyll/Core/Store/Tests.hs b/tests/Hakyll/Core/Store/Tests.hs index bd6cba2..11a1a63 100644 --- a/tests/Hakyll/Core/Store/Tests.hs +++ b/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) && |