summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--hakyll.cabal7
-rw-r--r--lib/Hakyll/Core/Compiler.hs37
-rw-r--r--lib/Hakyll/Core/Compiler/Internal.hs167
-rw-r--r--lib/Hakyll/Core/Compiler/Require.hs2
-rw-r--r--lib/Hakyll/Core/Logger.hs12
-rw-r--r--lib/Hakyll/Core/Provider/Metadata.hs5
-rw-r--r--lib/Hakyll/Core/Runtime.hs6
-rw-r--r--lib/Hakyll/Core/Store.hs40
-rw-r--r--lib/Hakyll/Web/Feed.hs55
-rw-r--r--lib/Hakyll/Web/Template.hs26
-rw-r--r--lib/Hakyll/Web/Template/Context.hs132
-rw-r--r--lib/Hakyll/Web/Template/Internal.hs144
-rw-r--r--lib/Hakyll/Web/Template/Internal/Element.hs21
-rw-r--r--tests/Hakyll/Core/UnixFilter/Tests.hs22
-rw-r--r--tests/Hakyll/Web/Template/Context/Tests.hs4
-rw-r--r--tests/Hakyll/Web/Template/Tests.hs64
-rw-r--r--tests/TestSuite/Util.hs13
-rw-r--r--tests/data/embed.html1
18 files changed, 527 insertions, 231 deletions
diff --git a/hakyll.cabal b/hakyll.cabal
index 94405a8..48cf5c0 100644
--- a/hakyll.cabal
+++ b/hakyll.cabal
@@ -172,10 +172,12 @@ Library
data-default >= 0.4 && < 0.8,
deepseq >= 1.3 && < 1.5,
directory >= 1.0 && < 1.4,
+ file-embed >= 0.0.10.1 && < 0.0.12,
filepath >= 1.0 && < 1.5,
lrucache >= 1.1.1 && < 1.3,
mtl >= 1 && < 2.3,
network-uri >= 2.6 && < 2.7,
+ optparse-applicative >= 0.12 && < 0.15,
parsec >= 3.0 && < 3.2,
process >= 1.6 && < 1.7,
random >= 1.0 && < 1.2,
@@ -183,14 +185,13 @@ Library
resourcet >= 1.1 && < 1.3,
scientific >= 0.3.4 && < 0.4,
tagsoup >= 0.13.1 && < 0.15,
+ template-haskell >= 2.14 && < 2.15,
text >= 0.11 && < 1.3,
time >= 1.8 && < 1.10,
time-locale-compat >= 0.1 && < 0.2,
unordered-containers >= 0.2 && < 0.3,
vector >= 0.11 && < 0.13,
- yaml >= 0.8.11 && < 0.12,
- optparse-applicative >= 0.12 && < 0.15,
- file-embed >= 0.0.10.1 && < 0.0.12
+ yaml >= 0.8.11 && < 0.12
If flag(previewServer)
Build-depends:
diff --git a/lib/Hakyll/Core/Compiler.hs b/lib/Hakyll/Core/Compiler.hs
index 42b24d6..870d0af 100644
--- a/lib/Hakyll/Core/Compiler.hs
+++ b/lib/Hakyll/Core/Compiler.hs
@@ -24,13 +24,16 @@ module Hakyll.Core.Compiler
, cached
, unsafeCompiler
, debugCompiler
+ , noResult
+ , withErrorMessage
) where
--------------------------------------------------------------------------------
-import Control.Monad (when, unless)
+import Control.Monad (unless, when, (>=>))
import Data.Binary (Binary)
import Data.ByteString.Lazy (ByteString)
+import qualified Data.List.NonEmpty as NonEmpty
import Data.Typeable (Typeable)
import System.Environment (getProgName)
import System.FilePath (takeExtension)
@@ -62,6 +65,7 @@ getUnderlyingExtension = takeExtension . toFilePath <$> getUnderlying
--------------------------------------------------------------------------------
+-- | Create an item from the underlying identifier and a given value.
makeItem :: a -> Compiler (Item a)
makeItem x = do
identifier <- getUnderlying
@@ -141,6 +145,10 @@ saveSnapshot snapshot item = do
--------------------------------------------------------------------------------
+-- | Turn on caching for a compilation value to avoid recomputing it
+-- on subsequent Hakyll runs.
+-- The storage key consists of the underlying identifier of the compiled
+-- ressource and the given name.
cached :: (Binary a, Typeable a)
=> String
-> Compiler a
@@ -177,12 +185,37 @@ cached name compiler = do
--------------------------------------------------------------------------------
+-- | Run an IO computation without dependencies in a Compiler
unsafeCompiler :: IO a -> Compiler a
unsafeCompiler = compilerUnsafeIO
--------------------------------------------------------------------------------
--- | Compiler for debugging purposes
+-- | Fail so that it is treated as non-defined in an @\$if()\$@ branching
+-- "Hakyll.Web.Template" macro, and alternative
+-- 'Hakyll.Web.Template.Context.Context's are tried
+--
+-- @since 4.13.0
+noResult :: String -> Compiler a
+noResult = compilerNoResult . return
+
+
+--------------------------------------------------------------------------------
+-- | Prepend an error line to the error, if there is one. This allows you to
+-- add helpful context to error messages.
+--
+-- @since 4.13.0
+withErrorMessage :: String -> Compiler a -> Compiler a
+withErrorMessage x = do
+ compilerTry >=> either (compilerResult . CompilerError . prepend) return
+ where
+ prepend (CompilationFailure es) = CompilationFailure (x `NonEmpty.cons` es)
+ prepend (CompilationNoResult es) = CompilationNoResult (x : es)
+
+
+--------------------------------------------------------------------------------
+-- | Compiler for debugging purposes.
+-- Passes a message to the debug logger that is printed in verbose mode.
debugCompiler :: String -> Compiler ()
debugCompiler msg = do
logger <- compilerLogger <$> compilerAsk
diff --git a/lib/Hakyll/Core/Compiler/Internal.hs b/lib/Hakyll/Core/Compiler/Internal.hs
index 5b6d1aa..762630c 100644
--- a/lib/Hakyll/Core/Compiler/Internal.hs
+++ b/lib/Hakyll/Core/Compiler/Internal.hs
@@ -1,6 +1,7 @@
--------------------------------------------------------------------------------
-- | Internally used compiler module
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -10,19 +11,26 @@ module Hakyll.Core.Compiler.Internal
Snapshot
, CompilerRead (..)
, CompilerWrite (..)
+ , CompilerErrors (..)
, CompilerResult (..)
, Compiler (..)
, runCompiler
-- * Core operations
+ , compilerResult
, compilerTell
, compilerAsk
+ , compilerUnsafeIO
+
+ -- * Error operations
, compilerThrow
+ , compilerNoResult
, compilerCatch
- , compilerResult
- , compilerUnsafeIO
+ , compilerTry
+ , compilerErrorMessages
-- * Utilities
+ , compilerDebugEntries
, compilerTellDependencies
, compilerTellCacheHits
) where
@@ -32,7 +40,9 @@ module Hakyll.Core.Compiler.Internal
import Control.Applicative (Alternative (..))
import Control.Exception (SomeException, handle)
import Control.Monad (forM_)
-import Control.Monad.Except (MonadError (..))
+import Control.Monad.Except (MonadError (..))
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as NonEmpty
#if MIN_VERSION_base(4,9,0)
import Data.Semigroup (Semigroup (..))
#endif
@@ -45,7 +55,6 @@ import Hakyll.Core.Configuration
import Hakyll.Core.Dependencies
import Hakyll.Core.Identifier
import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.Logger (Logger)
import qualified Hakyll.Core.Logger as Logger
import Hakyll.Core.Metadata
import Hakyll.Core.Provider
@@ -75,7 +84,7 @@ data CompilerRead = CompilerRead
, -- | Compiler store
compilerStore :: Store
, -- | Logger
- compilerLogger :: Logger
+ compilerLogger :: Logger.Logger
}
@@ -104,11 +113,29 @@ instance Monoid CompilerWrite where
--------------------------------------------------------------------------------
-data CompilerResult a where
- CompilerDone :: a -> CompilerWrite -> CompilerResult a
- CompilerSnapshot :: Snapshot -> Compiler a -> CompilerResult a
- CompilerError :: [String] -> CompilerResult a
- CompilerRequire :: (Identifier, Snapshot) -> Compiler a -> CompilerResult a
+-- | Distinguishes reasons in a 'CompilerError'
+data CompilerErrors a
+ -- | One or more exceptions occured during compilation
+ = CompilationFailure (NonEmpty a)
+ -- | Absence of any result, most notably in template contexts. May still
+ -- have error messages.
+ | CompilationNoResult [a]
+ deriving Functor
+
+
+-- | Unwrap a `CompilerErrors`
+compilerErrorMessages :: CompilerErrors a -> [a]
+compilerErrorMessages (CompilationFailure x) = NonEmpty.toList x
+compilerErrorMessages (CompilationNoResult x) = x
+
+
+--------------------------------------------------------------------------------
+-- | An intermediate result of a compilation step
+data CompilerResult a
+ = CompilerDone a CompilerWrite
+ | CompilerSnapshot Snapshot (Compiler a)
+ | CompilerRequire (Identifier, Snapshot) (Compiler a)
+ | CompilerError (CompilerErrors String)
--------------------------------------------------------------------------------
@@ -126,14 +153,14 @@ instance Functor Compiler where
return $ case res of
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')
+ CompilerError e -> CompilerError e
{-# INLINE fmap #-}
--------------------------------------------------------------------------------
instance Monad Compiler where
- return x = Compiler $ \_ -> return $ CompilerDone x mempty
+ return x = compilerResult $ CompilerDone x mempty
{-# INLINE return #-}
Compiler c >>= f = Compiler $ \r -> do
@@ -146,14 +173,14 @@ instance Monad Compiler where
CompilerSnapshot s c' -> CompilerSnapshot s $ do
compilerTell w -- Save dependencies!
c'
- CompilerError e -> CompilerError e
CompilerRequire i c' -> CompilerRequire i $ do
compilerTell w -- Save dependencies!
c'
+ CompilerError e -> CompilerError e
CompilerSnapshot s c' -> return $ CompilerSnapshot s (c' >>= f)
- CompilerError e -> return $ CompilerError e
CompilerRequire i c' -> return $ CompilerRequire i (c' >>= f)
+ CompilerError e -> return $ CompilerError e
{-# INLINE (>>=) #-}
fail = compilerThrow . return
@@ -170,87 +197,145 @@ instance Applicative Compiler where
--------------------------------------------------------------------------------
+-- | Access provided metadata from anywhere
instance MonadMetadata Compiler where
getMetadata = compilerGetMetadata
getMatches = compilerGetMatches
--------------------------------------------------------------------------------
+-- | Compilation may fail with multiple error messages.
+-- 'catchError' handles errors from 'throwError', 'fail' and 'Hakyll.Core.Compiler.noResult'
instance MonadError [String] Compiler where
- throwError = compilerThrow
- catchError = compilerCatch
+ throwError = compilerThrow
+ catchError c = compilerCatch c . (. compilerErrorMessages)
--------------------------------------------------------------------------------
+-- | Like 'unCompiler' but treating IO exceptions as 'CompilerError's
runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)
runCompiler compiler read' = handle handler $ unCompiler compiler read'
where
handler :: SomeException -> IO (CompilerResult a)
- handler e = return $ CompilerError [show e]
+ handler e = return $ CompilerError $ CompilationFailure $ show e :| []
--------------------------------------------------------------------------------
+-- | Trying alternative compilers if the first fails, regardless whether through
+-- 'fail', 'throwError' or 'Hakyll.Core.Compiler.noResult'.
+-- Aggregates error messages if all fail.
instance Alternative Compiler where
- empty = compilerThrow []
- x <|> y = compilerCatch x $ \es -> do
- logger <- compilerLogger <$> compilerAsk
- forM_ es $ \e -> compilerUnsafeIO $ Logger.debug logger $
- "Hakyll.Core.Compiler.Internal: Alternative failed: " ++ e
- y
+ empty = compilerNoResult []
+ x <|> y = x `compilerCatch` (\rx -> y `compilerCatch` (\ry ->
+ case (rx, ry) of
+ (CompilationFailure xs, CompilationFailure ys) ->
+ compilerThrow $ NonEmpty.toList xs ++ NonEmpty.toList ys
+ (CompilationFailure xs, CompilationNoResult ys) ->
+ debug ys >> compilerThrow (NonEmpty.toList xs)
+ (CompilationNoResult xs, CompilationFailure ys) ->
+ debug xs >> compilerThrow (NonEmpty.toList ys)
+ (CompilationNoResult xs, CompilationNoResult ys) -> compilerNoResult $ xs ++ ys
+ ))
+ where
+ debug = compilerDebugEntries "Hakyll.Core.Compiler.Internal: Alternative fail suppressed"
{-# INLINE (<|>) #-}
--------------------------------------------------------------------------------
+-- | Put the result back in a compiler
+compilerResult :: CompilerResult a -> Compiler a
+compilerResult x = Compiler $ \_ -> return x
+{-# INLINE compilerResult #-}
+
+
+--------------------------------------------------------------------------------
+-- | Get the current environment
compilerAsk :: Compiler CompilerRead
compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty
{-# INLINE compilerAsk #-}
--------------------------------------------------------------------------------
+-- | Put a 'CompilerWrite'
compilerTell :: CompilerWrite -> Compiler ()
-compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps
+compilerTell = compilerResult . CompilerDone ()
{-# INLINE compilerTell #-}
--------------------------------------------------------------------------------
+-- | Run an IO computation without dependencies in a Compiler
+compilerUnsafeIO :: IO a -> Compiler a
+compilerUnsafeIO io = Compiler $ \_ -> do
+ x <- io
+ return $ CompilerDone x mempty
+{-# INLINE compilerUnsafeIO #-}
+
+
+--------------------------------------------------------------------------------
+-- | Throw errors in the 'Compiler'.
+--
+-- If no messages are given, this is considered a 'CompilationNoResult' error.
+-- Otherwise, it is treated as a proper compilation failure.
compilerThrow :: [String] -> Compiler a
-compilerThrow es = Compiler $ \_ -> return $ CompilerError es
-{-# INLINE compilerThrow #-}
+compilerThrow = compilerResult . CompilerError .
+ maybe (CompilationNoResult []) CompilationFailure .
+ NonEmpty.nonEmpty
+
+-- | Put a 'CompilerError' with multiple messages as 'CompilationNoResult'
+compilerNoResult :: [String] -> Compiler a
+compilerNoResult = compilerResult . CompilerError . CompilationNoResult
--------------------------------------------------------------------------------
-compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a
+-- | Allows to distinguish 'CompilerError's and branch on them with 'Either'
+--
+-- prop> compilerTry = (`compilerCatch` return . Left) . fmap Right
+compilerTry :: Compiler a -> Compiler (Either (CompilerErrors String) a)
+compilerTry (Compiler x) = Compiler $ \r -> do
+ res <- x r
+ case res of
+ CompilerDone res' w -> return (CompilerDone (Right res') w)
+ CompilerSnapshot s c -> return (CompilerSnapshot s (compilerTry c))
+ CompilerRequire i c -> return (CompilerRequire i (compilerTry c))
+ CompilerError e -> return (CompilerDone (Left e) mempty)
+{-# INLINE compilerTry #-}
+
+
+--------------------------------------------------------------------------------
+-- | Allows you to recover from 'CompilerError's.
+-- Uses the same parameter order as 'catchError' so that it can be used infix.
+--
+-- prop> c `compilerCatch` f = compilerTry c >>= either f return
+compilerCatch :: Compiler a -> (CompilerErrors 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)
CompilerSnapshot s c -> return (CompilerSnapshot s (compilerCatch c f))
- CompilerError e -> unCompiler (f e) r
CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))
+ CompilerError e -> unCompiler (f e) r
{-# INLINE compilerCatch #-}
--------------------------------------------------------------------------------
--- | Put the result back in a compiler
-compilerResult :: CompilerResult a -> Compiler a
-compilerResult x = Compiler $ \_ -> return x
-{-# INLINE compilerResult #-}
-
+compilerDebugLog :: [String] -> Compiler ()
+compilerDebugLog ms = do
+ logger <- compilerLogger <$> compilerAsk
+ compilerUnsafeIO $ forM_ ms $ Logger.debug logger
--------------------------------------------------------------------------------
-compilerUnsafeIO :: IO a -> Compiler a
-compilerUnsafeIO io = Compiler $ \_ -> do
- x <- io
- return $ CompilerDone x mempty
-{-# INLINE compilerUnsafeIO #-}
+-- | Pass a list of messages with a heading to the debug logger
+compilerDebugEntries :: String -> [String] -> Compiler ()
+compilerDebugEntries msg = compilerDebugLog . (msg:) . map indent
+ where
+ indent = unlines . map (" "++) . lines
--------------------------------------------------------------------------------
compilerTellDependencies :: [Dependency] -> Compiler ()
compilerTellDependencies ds = do
- logger <- compilerLogger <$> compilerAsk
- forM_ ds $ \d -> compilerUnsafeIO $ Logger.debug logger $
- "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d
+ compilerDebugLog $ map (\d ->
+ "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d) ds
compilerTell mempty {compilerDependencies = ds}
{-# INLINE compilerTellDependencies #-}
diff --git a/lib/Hakyll/Core/Compiler/Require.hs b/lib/Hakyll/Core/Compiler/Require.hs
index c9373bf..6222eb8 100644
--- a/lib/Hakyll/Core/Compiler/Require.hs
+++ b/lib/Hakyll/Core/Compiler/Require.hs
@@ -91,6 +91,7 @@ loadBody id' = loadSnapshotBody id' final
--------------------------------------------------------------------------------
+-- | A shortcut for only requiring the body for a specific snapshot of an item
loadSnapshotBody :: (Binary a, Typeable a)
=> Identifier -> Snapshot -> Compiler a
loadSnapshotBody id' snapshot = fmap itemBody $ loadSnapshot id' snapshot
@@ -103,6 +104,7 @@ loadAll pattern = loadAllSnapshots pattern final
--------------------------------------------------------------------------------
+-- | Load a specific snapshot for each of dynamic list of items
loadAllSnapshots :: (Binary a, Typeable a)
=> Pattern -> Snapshot -> Compiler [Item a]
loadAllSnapshots pattern snapshot = do
diff --git a/lib/Hakyll/Core/Logger.hs b/lib/Hakyll/Core/Logger.hs
index 6f950a6..9b7de17 100644
--- a/lib/Hakyll/Core/Logger.hs
+++ b/lib/Hakyll/Core/Logger.hs
@@ -18,6 +18,7 @@ import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
import Control.Monad (forever)
import Control.Monad.Trans (MonadIO, liftIO)
+import Data.List (intercalate)
import Prelude hiding (error)
@@ -79,7 +80,7 @@ string l v m
--------------------------------------------------------------------------------
error :: MonadIO m => Logger -> String -> m ()
-error l m = string l Error $ " [ERROR] " ++ m
+error l m = string l Error $ " [ERROR] " ++ indent m
--------------------------------------------------------------------------------
@@ -89,9 +90,14 @@ header l = string l Message
--------------------------------------------------------------------------------
message :: MonadIO m => Logger -> String -> m ()
-message l m = string l Message $ " " ++ m
+message l m = string l Message $ " " ++ indent m
--------------------------------------------------------------------------------
debug :: MonadIO m => Logger -> String -> m ()
-debug l m = string l Debug $ " [DEBUG] " ++ m
+debug l m = string l Debug $ " [DEBUG] " ++ indent m
+
+
+--------------------------------------------------------------------------------
+indent :: String -> String
+indent = intercalate "\n " . lines
diff --git a/lib/Hakyll/Core/Provider/Metadata.hs b/lib/Hakyll/Core/Provider/Metadata.hs
index 6285ce1..c74627b 100644
--- a/lib/Hakyll/Core/Provider/Metadata.hs
+++ b/lib/Hakyll/Core/Provider/Metadata.hs
@@ -27,6 +27,7 @@ import Hakyll.Core.Identifier
import Hakyll.Core.Metadata
import Hakyll.Core.Provider.Internal
import System.IO as IO
+import System.IO.Error (modifyIOError, ioeSetLocation)
--------------------------------------------------------------------------------
@@ -51,7 +52,7 @@ loadMetadata p identifier = do
--------------------------------------------------------------------------------
loadMetadataHeader :: FilePath -> IO (Metadata, String)
loadMetadataHeader fp = do
- fileContent <- readFile fp
+ fileContent <- modifyIOError (`ioeSetLocation` "loadMetadataHeader") $ readFile fp
case parsePage fileContent of
Right x -> return x
Left err -> throwIO $ MetadataException fp err
@@ -60,7 +61,7 @@ loadMetadataHeader fp = do
--------------------------------------------------------------------------------
loadMetadataFile :: FilePath -> IO Metadata
loadMetadataFile fp = do
- fileContent <- B.readFile fp
+ fileContent <- modifyIOError (`ioeSetLocation` "loadMetadataFile") $ B.readFile fp
let errOrMeta = Yaml.decodeEither' fileContent
either (fail . show) return errOrMeta
diff --git a/lib/Hakyll/Core/Runtime.hs b/lib/Hakyll/Core/Runtime.hs
index 16a5d9e..922b676 100644
--- a/lib/Hakyll/Core/Runtime.hs
+++ b/lib/Hakyll/Core/Runtime.hs
@@ -199,9 +199,9 @@ chase trail id'
result <- liftIO $ runCompiler compiler read'
case result of
-- Rethrow error
- CompilerError [] -> throwError
- "Compiler failed but no info given, try running with -v?"
- CompilerError es -> throwError $ intercalate "; " es
+ CompilerError e -> throwError $ case compilerErrorMessages e of
+ [] -> "Compiler failed but no info given, try running with -v?"
+ es -> intercalate "; " es
-- Signal that a snapshot was saved ->
CompilerSnapshot snapshot c -> do
diff --git a/lib/Hakyll/Core/Store.hs b/lib/Hakyll/Core/Store.hs
index 89d6047..f65a00b 100644
--- a/lib/Hakyll/Core/Store.hs
+++ b/lib/Hakyll/Core/Store.hs
@@ -16,7 +16,6 @@ module Hakyll.Core.Store
--------------------------------------------------------------------------------
-import Control.Exception (IOException, handle)
import qualified Crypto.Hash.MD5 as MD5
import Data.Binary (Binary, decode, encodeFile)
import qualified Data.ByteString as B
@@ -32,6 +31,8 @@ import System.Directory (createDirectoryIfMissing)
import System.Directory (doesFileExist, removeFile)
import System.FilePath ((</>))
import System.IO (IOMode (..), hClose, openFile)
+import System.IO.Error (catchIOError, ioeSetFileName,
+ ioeSetLocation, modifyIOError)
--------------------------------------------------------------------------------
@@ -84,6 +85,14 @@ new inMemory directory = do
where
csize = Just 500
+--------------------------------------------------------------------------------
+withStore :: Store -> String -> (String -> FilePath -> IO a) -> [String] -> IO a
+withStore store loc run identifier = modifyIOError handle $ run key path
+ where
+ key = hash identifier
+ path = storeDirectory store </> key
+ handle e = e `ioeSetFileName` (path ++ " for " ++ intercalate "/" identifier)
+ `ioeSetLocation` ("Store." ++ loc)
--------------------------------------------------------------------------------
-- | Auxiliary: add an item to the in-memory cache
@@ -124,17 +133,16 @@ cacheDelete (Store _ (Just lru)) key = do
--------------------------------------------------------------------------------
-- | Store an item
set :: (Binary a, Typeable a) => Store -> [String] -> a -> IO ()
-set store identifier value = do
- encodeFile (storeDirectory store </> key) value
+set store identifier value = withStore store "set" (\key path -> do
+ encodeFile path value
cacheInsert store key value
- where
- key = hash identifier
+ ) identifier
--------------------------------------------------------------------------------
-- | Load an item
get :: (Binary a, Typeable a) => Store -> [String] -> IO (Result a)
-get store identifier = do
+get store = withStore store "get" $ \key path -> do
-- First check the in-memory map
ref <- cacheLookup store key
case ref of
@@ -146,17 +154,14 @@ get store identifier = do
then return NotFound
-- Found in the filesystem
else do
- v <- decodeClose
+ v <- decodeClose path
cacheInsert store key v
return $ Found v
-- Found in the in-memory map (or wrong type), just return
s -> return s
where
- key = hash identifier
- path = storeDirectory store </> key
-
-- 'decodeFile' from Data.Binary which closes the file ASAP
- decodeClose = do
+ decodeClose path = do
h <- openFile path ReadMode
lbs <- BL.hGetContents h
BL.length lbs `seq` hClose h
@@ -166,28 +171,23 @@ get store identifier = do
--------------------------------------------------------------------------------
-- | Strict function
isMember :: Store -> [String] -> IO Bool
-isMember store identifier = do
+isMember store = withStore store "isMember" $ \key path -> do
inCache <- cacheIsMember store key
if inCache then return True else doesFileExist path
- where
- key = hash identifier
- path = storeDirectory store </> key
--------------------------------------------------------------------------------
-- | Delete an item
delete :: Store -> [String] -> IO ()
-delete store identifier = do
+delete store = withStore store "delete" $ \key path -> do
cacheDelete store key
- deleteFile $ storeDirectory store </> key
- where
- key = hash identifier
+ deleteFile path
--------------------------------------------------------------------------------
-- | Delete a file unless it doesn't exist...
deleteFile :: FilePath -> IO ()
-deleteFile = handle (\(_ :: IOException) -> return ()) . removeFile
+deleteFile = (`catchIOError` \_ -> return ()) . removeFile
--------------------------------------------------------------------------------
diff --git a/lib/Hakyll/Web/Feed.hs b/lib/Hakyll/Web/Feed.hs
index 6f6d699..468453b 100644
--- a/lib/Hakyll/Web/Feed.hs
+++ b/lib/Hakyll/Web/Feed.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- | A Module that allows easy rendering of RSS feeds.
@@ -37,27 +38,26 @@ import Hakyll.Web.Template.List
--------------------------------------------------------------------------------
-import Data.FileEmbed (makeRelativeToProject, embedFile)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
+import Data.FileEmbed (makeRelativeToProject)
--------------------------------------------------------------------------------
-rssTemplate :: String
-rssTemplate = T.unpack $
- T.decodeUtf8 $(makeRelativeToProject "data/templates/rss.xml" >>= embedFile)
+rssTemplate :: Template
+rssTemplate =
+ $(makeRelativeToProject "data/templates/rss.xml" >>= embedTemplate)
-rssItemTemplate :: String
-rssItemTemplate = T.unpack $
- T.decodeUtf8 $(makeRelativeToProject "data/templates/rss-item.xml" >>= embedFile)
+rssItemTemplate :: Template
+rssItemTemplate =
+ $(makeRelativeToProject "data/templates/rss-item.xml" >>= embedTemplate)
-atomTemplate :: String
-atomTemplate = T.unpack $
- T.decodeUtf8 $(makeRelativeToProject "data/templates/atom.xml" >>= embedFile)
+atomTemplate :: Template
+atomTemplate =
+ $(makeRelativeToProject "data/templates/atom.xml" >>= embedTemplate)
+
+atomItemTemplate :: Template
+atomItemTemplate =
+ $(makeRelativeToProject "data/templates/atom-item.xml" >>= embedTemplate)
-atomItemTemplate :: String
-atomItemTemplate = T.unpack $
- T.decodeUtf8 $(makeRelativeToProject "data/templates/atom-item.xml" >>= embedFile)
--------------------------------------------------------------------------------
-- | This is a data structure to keep the configuration of a feed.
@@ -77,16 +77,13 @@ data FeedConfiguration = FeedConfiguration
--------------------------------------------------------------------------------
-- | Abstract function to render any feed.
-renderFeed :: String -- ^ Default feed template
- -> String -- ^ Default item template
+renderFeed :: Template -- ^ Default feed template
+ -> Template -- ^ Default item template
-> FeedConfiguration -- ^ Feed configuration
-> Context String -- ^ Context for the items
-> [Item String] -- ^ Input items
-> Compiler (Item String) -- ^ Resulting item
-renderFeed defFeed defItem config itemContext items = do
- feedTpl <- readTemplateFile defFeed
- itemTpl <- readTemplateFile defItem
-
+renderFeed feedTpl itemTpl config itemContext items = do
protectedItems <- mapM (applyFilter protectCDATA) items
body <- makeItem =<< applyTemplateList itemTpl itemContext' protectedItems
applyTemplate feedTpl feedContext body
@@ -120,18 +117,14 @@ renderFeed defFeed defItem config itemContext items = do
updatedField = field "updated" $ \_ -> case items of
[] -> return "Unknown"
(x : _) -> unContext itemContext' "updated" [] x >>= \cf -> case cf of
- ListField _ _ -> fail "Hakyll.Web.Feed.renderFeed: Internal error"
StringField s -> return s
-
- readTemplateFile :: String -> Compiler Template
- readTemplateFile value = pure $ template $ readTemplateElems value
-
+ _ -> fail "Hakyll.Web.Feed.renderFeed: Internal error"
--------------------------------------------------------------------------------
-- | Render an RSS feed using given templates with a number of items.
renderRssWithTemplates ::
- String -- ^ Feed template
- -> String -- ^ Item template
+ Template -- ^ Feed template
+ -> Template -- ^ Item template
-> FeedConfiguration -- ^ Feed configuration
-> Context String -- ^ Item context
-> [Item String] -- ^ Feed items
@@ -144,8 +137,8 @@ renderRssWithTemplates feedTemplate itemTemplate config context = renderFeed
--------------------------------------------------------------------------------
-- | Render an Atom feed using given templates with a number of items.
renderAtomWithTemplates ::
- String -- ^ Feed template
- -> String -- ^ Item template
+ Template -- ^ Feed template
+ -> Template -- ^ Item template
-> FeedConfiguration -- ^ Feed configuration
-> Context String -- ^ Item context
-> [Item String] -- ^ Feed items
diff --git a/lib/Hakyll/Web/Template.hs b/lib/Hakyll/Web/Template.hs
index a436106..3ef79f9 100644
--- a/lib/Hakyll/Web/Template.hs
+++ b/lib/Hakyll/Web/Template.hs
@@ -138,19 +138,41 @@
-- > 3...2...1
-- > </p>
--
+{-# LANGUAGE TemplateHaskell #-}
module Hakyll.Web.Template
( Template
- , template
- , readTemplateElems
, templateBodyCompiler
, templateCompiler
, applyTemplate
, loadAndApplyTemplate
, applyAsTemplate
, readTemplate
+ , compileTemplateItem
, unsafeReadTemplateFile
+ , embedTemplate
) where
--------------------------------------------------------------------------------
import Hakyll.Web.Template.Internal
+
+
+--------------------------------------------------------------------------------
+import Data.FileEmbed (embedFile)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Language.Haskell.TH (Exp, Q)
+
+
+--------------------------------------------------------------------------------
+-- | Embed template allows you embed a template within the Haskell binary.
+-- Example:
+--
+-- > myTemplate :: Template
+-- > myTemplate = $(embedTemplate "test.html")
+embedTemplate :: FilePath -> Q Exp
+embedTemplate filePath = [|
+ let source = T.unpack $ T.decodeUtf8 $(embedFile filePath) in
+ case parseTemplateElemsFile filePath source of
+ Left err -> error err
+ Right tpl -> template filePath tpl |]
diff --git a/lib/Hakyll/Web/Template/Context.hs b/lib/Hakyll/Web/Template/Context.hs
index 8038253..9cd1426 100644
--- a/lib/Hakyll/Web/Template/Context.hs
+++ b/lib/Hakyll/Web/Template/Context.hs
@@ -1,3 +1,23 @@
+-- | This module provides 'Context's which are used to expand expressions in
+-- templates and allow for arbitrary customisation.
+--
+-- 'Template's define a small expression DSL which consists of strings,
+-- identifiers and function application. There is no type system, every value is
+-- a string and on the top level they get substituted verbatim into the page.
+--
+-- For example, you can build a context that contains
+--
+-- > … <> functionField "concat" (const . concat) <> …
+--
+-- which will allow you to use the @concat@ identifier as a function that takes
+-- arbitrarily many stings and concatenates them to a new string:
+--
+-- > $partial(concat("templates/categories/", category))$
+--
+-- This will evaluate the @category@ field in the context, then prepend he path,
+-- and include the referenced file as a template.
+
+
--------------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
@@ -50,13 +70,16 @@ import Hakyll.Core.Metadata
import Hakyll.Core.Provider
import Hakyll.Core.Util.String (needlePrefix, splitAll)
import Hakyll.Web.Html
-import System.FilePath (splitDirectories, takeBaseName, dropExtension)
+import Prelude hiding (id)
+import System.FilePath (dropExtension, splitDirectories,
+ takeBaseName)
--------------------------------------------------------------------------------
-- | Mostly for internal usage
data ContextField
- = StringField String
+ = EmptyField
+ | StringField String
| forall a. ListField (Context a) [Item a]
@@ -81,6 +104,8 @@ newtype Context a = Context
--------------------------------------------------------------------------------
+-- | Tries to find a key in the left context,
+-- or when that fails in the right context.
#if MIN_VERSION_base(4,9,0)
instance Semigroup (Context a) where
(<>) (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i
@@ -97,64 +122,101 @@ instance Monoid (Context a) where
--------------------------------------------------------------------------------
field' :: String -> (Item a -> Compiler ContextField) -> Context a
-field' key value = Context $ \k _ i -> if k == key then value i else empty
+field' key value = Context $ \k _ i ->
+ if k == key
+ then value i
+ else noResult $ "Tried field " ++ key
--------------------------------------------------------------------------------
--- | Constructs a new field in the 'Context.'
+-- | Constructs a new field for a 'Context'.
+-- If the key matches, the compiler is run and its result is substituted in the
+-- template.
+--
+-- If the compiler fails, the field will be considered non-existent
+-- in an @$if()$@ macro or ultimately break the template application
+-- (unless the key is found in another context when using '<>').
+-- Use 'empty' or 'noResult' for intentional failures of fields used in
+-- @$if()$@, to distinguish them from exceptions thrown with 'fail'.
field
:: String -- ^ Key
-> (Item a -> Compiler String) -- ^ Function that constructs a value based
- -- on the item
+ -- on the item (e.g. accessing metadata)
-> Context a
field key value = field' key (fmap StringField . value)
--------------------------------------------------------------------------------
-- | Creates a 'field' to use with the @$if()$@ template macro.
+-- Attempting to substitute the field into the template will cause an error.
boolField
:: String
-> (Item a -> Bool)
-> Context a
-boolField name f = field name (\i -> if f i
- then pure (error $ unwords ["no string value for bool field:",name])
- else empty)
+boolField name f = field' name (\i -> if f i
+ then return EmptyField
+ else noResult $ "Field " ++ name ++ " is false")
--------------------------------------------------------------------------------
--- | Creates a 'field' that does not depend on the 'Item'
-constField :: String -> String -> Context a
+-- | Creates a 'field' that does not depend on the 'Item' but always yields
+-- the same string
+constField :: String -- ^ Key
+ -> String -- ^ Value
+ -> Context a
constField key = field key . const . return
--------------------------------------------------------------------------------
+-- | Creates a list field to be consumed by a @$for(…)$@ expression.
+-- The compiler returns multiple items which are rendered in the loop body
+-- with the supplied context.
listField :: String -> Context a -> Compiler [Item a] -> Context b
listField key c xs = listFieldWith key c (const xs)
--------------------------------------------------------------------------------
+-- | Creates a list field like 'listField', but supplies the current page
+-- to the compiler.
listFieldWith
:: String -> Context a -> (Item b -> Compiler [Item a]) -> Context b
listFieldWith key c f = field' key $ fmap (ListField c) . f
--------------------------------------------------------------------------------
-functionField :: String -> ([String] -> Item a -> Compiler String) -> Context a
+-- | Creates a variadic function field.
+--
+-- The function will be called with the dynamically evaluated string arguments
+-- from the template as well as the page that is currently rendered.
+functionField :: String -- ^ Key
+ -> ([String] -> Item a -> Compiler String) -- ^ Function
+ -> Context a
functionField name value = Context $ \k args i ->
if k == name
then StringField <$> value args i
- else empty
+ else noResult $ "Tried function field " ++ name
--------------------------------------------------------------------------------
+-- | Transform the respective string results of all fields in a context.
+-- For example,
+--
+-- > mapContext (++"c") (constField "x" "a" <> constField "y" "b")
+--
+-- is equivalent to
+--
+-- > constField "x" "ac" <> constField "y" "bc"
+--
mapContext :: (String -> String) -> Context a -> Context a
mapContext f (Context c) = Context $ \k a i -> do
fld <- c k a i
case fld of
+ EmptyField -> wrongType "boolField"
StringField str -> return $ StringField (f str)
- ListField _ _ -> fail $
- "Hakyll.Web.Template.Context.mapContext: " ++
- "can't map over a ListField!"
+ _ -> wrongType "ListField"
+ where
+ wrongType typ = fail $ "Hakyll.Web.Template.Context.mapContext: " ++
+ "can't map over a " ++ typ ++ "!"
--------------------------------------------------------------------------------
-- | A context that allows snippet inclusion. In processed file, use as:
@@ -163,15 +225,15 @@ mapContext f (Context c) = Context $ \k a i -> do
-- > $snippet("path/to/snippet/")$
-- > ...
--
--- The contents of the included file will not be interpolated.
+-- The contents of the included file will not be interpolated like @partial@
+-- does it.
--
snippetField :: Context String
snippetField = functionField "snippet" f
where
f [contentsPath] _ = loadBody (fromFilePath contentsPath)
- f _ i = error $
- "Too many arguments to function 'snippet()' in item " ++
- show (itemIdentifier i)
+ f [] _ = fail "No argument to function 'snippet()'"
+ f _ _ = fail "Too many arguments to function 'snippet()'"
--------------------------------------------------------------------------------
-- | A context that contains (in that order)
@@ -191,8 +253,7 @@ defaultContext =
metadataField `mappend`
urlField "url" `mappend`
pathField "path" `mappend`
- titleField "title" `mappend`
- missingField
+ titleField "title"
--------------------------------------------------------------------------------
@@ -210,15 +271,20 @@ bodyField key = field key $ return . itemBody
-- | Map any field to its metadata value, if present
metadataField :: Context a
metadataField = Context $ \k _ i -> do
- value <- getMetadataField (itemIdentifier i) k
- maybe empty (return . StringField) value
+ let id = itemIdentifier i
+ empty' = noResult $ "No '" ++ k ++ "' field in metadata " ++
+ "of item " ++ show id
+ value <- getMetadataField id k
+ maybe empty' (return . StringField) value
--------------------------------------------------------------------------------
-- | Absolute url to the resulting item
urlField :: String -> Context a
-urlField key = field key $
- fmap (maybe empty toUrl) . getRoute . itemIdentifier
+urlField key = field key $ \i -> do
+ let id = itemIdentifier i
+ empty' = fail $ "No route url found for item " ++ show id
+ fmap (maybe empty' toUrl) $ getRoute id
--------------------------------------------------------------------------------
@@ -272,8 +338,8 @@ titleField = mapContext takeBaseName . pathField
--
-- As another alternative, if none of the above matches, and the file has a
-- path which contains nested directories specifying a date, then that date
--- will be used. In other words, if the path is of the form
--- @**//yyyy//mm//dd//**//main.extension@ .
+-- will be used. In other words, if the path is of the form
+-- @**//yyyy//mm//dd//**//main.extension@ .
-- As above, in case of multiple matches, the rightmost one is used.
dateField :: String -- ^ Key in which the rendered date should be placed
@@ -285,7 +351,7 @@ dateField = dateFieldWith defaultTimeLocale
--------------------------------------------------------------------------------
-- | This is an extended version of 'dateField' that allows you to
-- specify a time locale that is used for outputting the date. For more
--- details, see 'dateField'.
+-- details, see 'dateField' and 'formatTime'.
dateFieldWith :: TimeLocale -- ^ Output time locale
-> String -- ^ Destination key
-> String -- ^ Format to use on the date
@@ -340,6 +406,7 @@ getItemModificationTime identifier = do
--------------------------------------------------------------------------------
+-- | Creates a field with the last modification date of the underlying item.
modificationTimeField :: String -- ^ Key
-> String -- ^ Format
-> Context a -- ^ Resulting context
@@ -347,6 +414,8 @@ modificationTimeField = modificationTimeFieldWith defaultTimeLocale
--------------------------------------------------------------------------------
+-- | Creates a field with the last modification date of the underlying item
+-- in a custom localisation format (see 'formatTime').
modificationTimeFieldWith :: TimeLocale -- ^ Time output locale
-> String -- ^ Key
-> String -- ^ Format
@@ -385,10 +454,11 @@ teaserFieldWithSeparator separator key snapshot = field key $ \item -> do
--------------------------------------------------------------------------------
+-- | Constantly reports any field as missing. Mostly for internal usage,
+-- it is the last choice in every context used in a template application.
missingField :: Context a
-missingField = Context $ \k _ i -> fail $
- "Missing field $" ++ k ++ "$ in context for item " ++
- show (itemIdentifier i)
+missingField = Context $ \k _ _ -> noResult $
+ "Missing field '" ++ k ++ "' in context"
parseTimeM :: Bool -> TimeLocale -> String -> String -> Maybe UTCTime
#if MIN_VERSION_time(1,5,0)
diff --git a/lib/Hakyll/Web/Template/Internal.hs b/lib/Hakyll/Web/Template/Internal.hs
index 154cee6..c369560 100644
--- a/lib/Hakyll/Web/Template/Internal.hs
+++ b/lib/Hakyll/Web/Template/Internal.hs
@@ -1,15 +1,18 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
+
module Hakyll.Web.Template.Internal
( Template (..)
, template
, templateBodyCompiler
, templateCompiler
, applyTemplate
- , applyTemplate'
, loadAndApplyTemplate
, applyAsTemplate
, readTemplate
+ , compileTemplateItem
, unsafeReadTemplateFile
, module Hakyll.Web.Template.Internal.Element
@@ -18,16 +21,18 @@ module Hakyll.Web.Template.Internal
--------------------------------------------------------------------------------
-import Control.Monad.Except (MonadError (..))
+import Control.Monad.Except (catchError)
import Data.Binary (Binary)
import Data.List (intercalate)
+import qualified Data.List.NonEmpty as NonEmpty
import Data.Typeable (Typeable)
import GHC.Exts (IsString (..))
-import Prelude hiding (id)
+import GHC.Generics (Generic)
--------------------------------------------------------------------------------
import Hakyll.Core.Compiler
+import Hakyll.Core.Compiler.Internal
import Hakyll.Core.Identifier
import Hakyll.Core.Item
import Hakyll.Core.Writable
@@ -38,9 +43,10 @@ import Hakyll.Web.Template.Internal.Trim
--------------------------------------------------------------------------------
-- | Datatype used for template substitutions.
-newtype Template = Template
- { unTemplate :: [TemplateElement]
- } deriving (Show, Eq, Binary, Typeable)
+data Template = Template
+ { tplElements :: [TemplateElement]
+ , tplOrigin :: FilePath -- Only for error messages.
+ } deriving (Show, Eq, Generic, Binary, Typeable)
--------------------------------------------------------------------------------
@@ -56,39 +62,68 @@ instance IsString Template where
--------------------------------------------------------------------------------
-- | Wrap the constructor to ensure trim is called.
-template :: [TemplateElement] -> Template
-template = Template . trim
+template :: FilePath -> [TemplateElement] -> Template
+template p = flip Template p . trim
--------------------------------------------------------------------------------
+-- | Parse a string into a template.
+-- You should prefer 'compileTemplateItem' over this.
readTemplate :: String -> Template
-readTemplate = Template . trim . readTemplateElems
+readTemplate = either error (template origin) . parseTemplateElemsFile origin
+ where
+ origin = "{literal}"
+{-# DEPRECATED readTemplate "Use templateCompiler instead" #-}
+
+--------------------------------------------------------------------------------
+-- | Parse an item body into a template.
+-- Provides useful error messages in the 'Compiler' monad.
+compileTemplateItem :: Item String -> Compiler Template
+compileTemplateItem item = let file = itemIdentifier item
+ in compileTemplateFile file (itemBody item)
+
+--------------------------------------------------------------------------------
+compileTemplateFile :: Identifier -> String -> Compiler Template
+compileTemplateFile file = either fail (return . template origin)
+ . parseTemplateElemsFile origin
+ where
+ origin = show file
--------------------------------------------------------------------------------
-- | Read a template, without metadata header
templateBodyCompiler :: Compiler (Item Template)
templateBodyCompiler = cached "Hakyll.Web.Template.templateBodyCompiler" $ do
item <- getResourceBody
- file <- getResourceFilePath
- return $ fmap (template . readTemplateElemsFile file) item
+ file <- getUnderlying
+ withItemBody (compileTemplateFile file) item
--------------------------------------------------------------------------------
-- | Read complete file contents as a template
templateCompiler :: Compiler (Item Template)
templateCompiler = cached "Hakyll.Web.Template.templateCompiler" $ do
item <- getResourceString
- file <- getResourceFilePath
- return $ fmap (template . readTemplateElemsFile file) item
+ file <- getUnderlying
+ withItemBody (compileTemplateFile file) item
--------------------------------------------------------------------------------
+-- | Interpolate template expressions from context values in a page
applyTemplate :: Template -- ^ Template
-> Context a -- ^ Context
-> Item a -- ^ Page
-> Compiler (Item String) -- ^ Resulting item
applyTemplate tpl context item = do
- body <- applyTemplate' (unTemplate tpl) context item
+ body <- applyTemplate' (tplElements tpl) context item `catchError` handler
return $ itemSetBody body item
+ where
+ tplName = tplOrigin tpl
+ itemName = show $ itemIdentifier item
+ handler es = fail $ "Hakyll.Web.Template.applyTemplate: Failed to " ++
+ (if tplName == itemName
+ then "interpolate template in item " ++ itemName
+ else "apply template " ++ tplName ++ " to item " ++ itemName) ++
+ ":\n" ++ intercalate ",\n" es
+
--------------------------------------------------------------------------------
@@ -105,9 +140,6 @@ applyTemplate' tes context x = go tes
go = fmap concat . mapM applyElem
- trimError = error $ "Hakyll.Web.Template.applyTemplate: template not " ++
- "fully trimmed."
-
---------------------------------------------------------------------------
applyElem :: TemplateElement -> Compiler String
@@ -118,29 +150,43 @@ applyTemplate' tes context x = go tes
applyElem (Chunk c) = return c
- applyElem (Expr e) = applyExpr e >>= getString e
+ applyElem (Expr e) = withErrorMessage evalMsg (applyStringExpr typeMsg e)
+ where
+ evalMsg = "In expr '$" ++ show e ++ "$'"
+ typeMsg = "expr '$" ++ show e ++ "$'"
applyElem Escaped = return "$"
- applyElem (If e t mf) = (applyExpr e >> go t) `catchError` handler
+ applyElem (If e t mf) = compilerTry (applyExpr e) >>= handle
where
- handler _ = case mf of
- Nothing -> return ""
- Just f -> go f
-
- applyElem (For e b s) = applyExpr e >>= \cf -> case cf of
- StringField _ -> fail $
- "Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++
- "got StringField for expr " ++ show e
- ListField c xs -> do
+ f = maybe (return "") go mf
+ handle (Right _) = go t
+ handle (Left (CompilationNoResult _)) = f
+ handle (Left (CompilationFailure es)) = debug (NonEmpty.toList es) >> f
+ debug = compilerDebugEntries ("Hakyll.Web.Template.applyTemplate: " ++
+ "[ERROR] in 'if' condition on expr '" ++ show e ++ "':")
+
+ applyElem (For e b s) = withErrorMessage headMsg (applyExpr e) >>= \cf -> case cf of
+ EmptyField -> expected "list" "boolean" typeMsg
+ StringField _ -> expected "list" "string" typeMsg
+ ListField c xs -> withErrorMessage bodyMsg $ do
sep <- maybe (return "") go s
bs <- mapM (applyTemplate' b c) xs
return $ intercalate sep bs
-
- applyElem (Partial e) = do
- p <- applyExpr e >>= getString e
- Template tpl' <- loadBody (fromFilePath p)
- applyTemplate' tpl' context x
+ where
+ headMsg = "In expr '$for(" ++ show e ++ ")$'"
+ typeMsg = "loop expr '" ++ show e ++ "'"
+ bodyMsg = "In loop context of '$for(" ++ show e ++ ")$'"
+
+ applyElem (Partial e) = withErrorMessage headMsg $
+ applyStringExpr typeMsg e >>= \p ->
+ withErrorMessage inclMsg $ do
+ tpl' <- loadBody (fromFilePath p)
+ itemBody <$> applyTemplate tpl' context x
+ where
+ headMsg = "In expr '$partial(" ++ show e ++ ")$'"
+ typeMsg = "partial expr '" ++ show e ++ "'"
+ inclMsg = "In inclusion of '$partial(" ++ show e ++ ")$'"
---------------------------------------------------------------------------
@@ -149,17 +195,29 @@ applyTemplate' tes context x = go tes
applyExpr (Ident (TemplateKey k)) = context' k [] x
applyExpr (Call (TemplateKey k) args) = do
- args' <- mapM (\e -> applyExpr e >>= getString e) args
+ args' <- mapM (\e -> applyStringExpr (typeMsg e) e) args
context' k args' x
+ where
+ typeMsg e = "argument '" ++ show e ++ "'"
applyExpr (StringLiteral s) = return (StringField s)
----------------------------------------------------------------------------
- getString _ (StringField s) = return s
- getString e (ListField _ _) = fail $
- "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++
- "got ListField for expr " ++ show e
+ applyStringExpr :: String -> TemplateExpr -> Compiler String
+ applyStringExpr msg expr =
+ applyExpr expr >>= getString
+ where
+ getString EmptyField = expected "string" "boolean" msg
+ getString (StringField s) = return s
+ getString (ListField _ _) = expected "string" "list" msg
+
+ expected typ act expr = fail $ unwords ["Hakyll.Web.Template.applyTemplate:",
+ "expected", typ, "but got", act, "for", expr]
+
+ -- expected to never happen with all templates constructed by 'template'
+ trimError = fail $
+ "Hakyll.Web.Template.applyTemplate: template not fully trimmed."
--------------------------------------------------------------------------------
@@ -189,14 +247,14 @@ loadAndApplyTemplate identifier context item = do
applyAsTemplate :: Context String -- ^ Context
-> Item String -- ^ Item and template
-> Compiler (Item String) -- ^ Resulting item
-applyAsTemplate context item =
- let tpl = template $ readTemplateElemsFile file (itemBody item)
- file = toFilePath $ itemIdentifier item
- in applyTemplate tpl context item
+applyAsTemplate context item = do
+ tpl <- compileTemplateItem item
+ applyTemplate tpl context item
--------------------------------------------------------------------------------
unsafeReadTemplateFile :: FilePath -> Compiler Template
unsafeReadTemplateFile file = do
tpl <- unsafeCompiler $ readFile file
- pure $ template $ readTemplateElemsFile file tpl
+ compileTemplateFile (fromFilePath file) tpl
+{-# DEPRECATED unsafeReadTemplateFile "Use templateCompiler" #-}
diff --git a/lib/Hakyll/Web/Template/Internal/Element.hs b/lib/Hakyll/Web/Template/Internal/Element.hs
index f564355..fc77501 100644
--- a/lib/Hakyll/Web/Template/Internal/Element.hs
+++ b/lib/Hakyll/Web/Template/Internal/Element.hs
@@ -7,14 +7,14 @@ module Hakyll.Web.Template.Internal.Element
, TemplateExpr (..)
, TemplateElement (..)
, templateElems
- , readTemplateElems
- , readTemplateElemsFile
+ , parseTemplateElemsFile
) where
--------------------------------------------------------------------------------
-import Control.Applicative ((<|>))
+import Control.Applicative ((<|>), (<*))
import Control.Monad (void)
+import Control.Arrow (left)
import Data.Binary (Binary, get, getWord8, put, putWord8)
import Data.List (intercalate)
import Data.Maybe (isJust)
@@ -107,17 +107,10 @@ instance Binary TemplateExpr where
2 -> StringLiteral <$> get
_ -> error "Hakyll.Web.Template.Internal: Error reading cached template"
-
---------------------------------------------------------------------------------
-readTemplateElems :: String -> [TemplateElement]
-readTemplateElems = readTemplateElemsFile "{literal}"
-
-
--------------------------------------------------------------------------------
-readTemplateElemsFile :: FilePath -> String -> [TemplateElement]
-readTemplateElemsFile file input = case P.parse templateElems file input of
- Left err -> error $ "Cannot parse template: " ++ show err
- Right t -> t
+parseTemplateElemsFile :: FilePath -> String -> Either String [TemplateElement]
+parseTemplateElemsFile file = left (\e -> "Cannot parse template " ++ show e)
+ . P.parse (templateElems <* P.eof) file
--------------------------------------------------------------------------------
@@ -167,7 +160,7 @@ trimOpen = do
--------------------------------------------------------------------------------
trimClose :: P.Parser Bool
trimClose = do
- trimIfR <- P.optionMaybe $ P.try (P.char '-')
+ trimIfR <- P.optionMaybe $ (P.char '-')
void $ P.char '$'
pure $ isJust trimIfR
diff --git a/tests/Hakyll/Core/UnixFilter/Tests.hs b/tests/Hakyll/Core/UnixFilter/Tests.hs
index 29e2cbf..e4e0f23 100644
--- a/tests/Hakyll/Core/UnixFilter/Tests.hs
+++ b/tests/Hakyll/Core/UnixFilter/Tests.hs
@@ -6,18 +6,16 @@ module Hakyll.Core.UnixFilter.Tests
--------------------------------------------------------------------------------
-import Data.List (isInfixOf)
-import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.HUnit (testCase)
-import qualified Test.Tasty.HUnit as H
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (testCase)
+import qualified Test.Tasty.HUnit as H
--------------------------------------------------------------------------------
import Hakyll.Core.Compiler
-import Hakyll.Core.Compiler.Internal
+import Hakyll.Core.Identifier
import Hakyll.Core.Item
import Hakyll.Core.UnixFilter
-import Hakyll.Core.Identifier
import TestSuite.Util
@@ -51,10 +49,7 @@ unixFilterFalse :: H.Assertion
unixFilterFalse = do
store <- newTestStore
provider <- newTestProvider store
- result <- testCompiler store provider testMarkdown compiler
- case result of
- CompilerError es -> True H.@=? any ("exit code" `isInfixOf`) es
- _ -> H.assertFailure "Expecting CompilerError"
+ testCompilerError store provider testMarkdown compiler "exit code"
cleanTestEnv
where
compiler = getResourceString >>= withItemBody (unixFilter "false" [])
@@ -65,12 +60,7 @@ unixFilterError :: H.Assertion
unixFilterError = do
store <- newTestStore
provider <- newTestProvider store
- result <- testCompiler store provider testMarkdown compiler
- case result of
- CompilerError es -> True H.@=? any containsIncorrectOptionMessage es
- _ -> H.assertFailure "Expecting CompilerError"
+ testCompilerError store provider testMarkdown compiler "option"
cleanTestEnv
where
compiler = getResourceString >>= withItemBody (unixFilter "head" ["-#"])
- incorrectOptionMessages = ["invalid option", "illegal option"]
- containsIncorrectOptionMessage output = any (`isInfixOf` output) incorrectOptionMessages
diff --git a/tests/Hakyll/Web/Template/Context/Tests.hs b/tests/Hakyll/Web/Template/Context/Tests.hs
index 3adedd8..66460b6 100644
--- a/tests/Hakyll/Web/Template/Context/Tests.hs
+++ b/tests/Hakyll/Web/Template/Context/Tests.hs
@@ -62,6 +62,6 @@ testContextDone store provider identifier key context =
cf <- unContext context key [] item
case cf of
StringField str -> return str
- ListField _ _ -> error $
+ _ -> error $
"Hakyll.Web.Template.Context.Tests.testContextDone: " ++
- "Didn't expect ListField"
+ "expected StringField"
diff --git a/tests/Hakyll/Web/Template/Tests.hs b/tests/Hakyll/Web/Template/Tests.hs
index bd794c7..a73b92d 100644
--- a/tests/Hakyll/Web/Template/Tests.hs
+++ b/tests/Hakyll/Web/Template/Tests.hs
@@ -1,5 +1,6 @@
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
module Hakyll.Web.Template.Tests
( tests
) where
@@ -7,9 +8,10 @@ module Hakyll.Web.Template.Tests
--------------------------------------------------------------------------------
import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.HUnit (Assertion, testCase, (@=?),
- (@?=))
+import Test.Tasty.HUnit (Assertion, assertBool, testCase,
+ (@=?), (@?=))
+import Data.Either (isLeft)
--------------------------------------------------------------------------------
import Hakyll.Core.Compiler
@@ -32,13 +34,13 @@ tests = testGroup "Hakyll.Web.Template.Tests" $ concat
, testCase "applyJoinTemplateList" testApplyJoinTemplateList
]
- , fromAssertions "readTemplate"
- [ [Chunk "Hello ", Expr (Call "guest" [])]
- @=? readTemplateElems "Hello $guest()$"
- , [If (Call "a" [StringLiteral "bar"]) [Chunk "foo"] Nothing]
- @=? readTemplateElems "$if(a(\"bar\"))$foo$endif$"
+ , fromAssertions "parseTemplate"
+ [ Right [Chunk "Hello ", Expr (Call "guest" [])]
+ @=? parse "Hello $guest()$"
+ , Right [If (Call "a" [StringLiteral "bar"]) [Chunk "foo"] Nothing]
+ @=? parse "$if(a(\"bar\"))$foo$endif$"
-- 'If' trim check.
- , [ TrimL
+ , Right [ TrimL
, If (Ident (TemplateKey "body"))
[ TrimR
, Chunk "\n"
@@ -54,29 +56,39 @@ tests = testGroup "Hakyll.Web.Template.Tests" $ concat
])
, TrimR
]
- @=? readTemplateElems "$-if(body)-$\n$body$\n$-else-$\n$body$\n$-endif-$"
+ @=? parse "$-if(body)-$\n$body$\n$-else-$\n$body$\n$-endif-$"
-- 'For' trim check.
- , [ TrimL
+ , Right [ TrimL
, For (Ident (TemplateKey "authors"))
[TrimR, Chunk "\n body \n", TrimL]
Nothing
, TrimR
]
- @=? readTemplateElems "$-for(authors)-$\n body \n$-endfor-$"
+ @=? parse "$-for(authors)-$\n body \n$-endfor-$"
-- 'Partial' trim check.
- , [ TrimL
+ , Right [ TrimL
, Partial (StringLiteral "path")
, TrimR
]
- @=? readTemplateElems "$-partial(\"path\")-$"
+ @=? parse "$-partial(\"path\")-$"
-- 'Expr' trim check.
- , [ TrimL
+ , Right [ TrimL
, Expr (Ident (TemplateKey "foo"))
, TrimR
]
- @=? readTemplateElems "$-foo-$"
+ @=? parse "$-foo-$"
+ -- fail on incomplete template.
+ , assertBool "did not yield error" $ isLeft $
+ parse "a$b"
+ -- fail on mismatched template syntax.
+ , assertBool "did not fail to parse" $ isLeft $
+ parse "$for(xs)$\n <p>foo</p>\n$endif$"
]
+
+ , [testCase "embeddedTemplate" testEmbeddedTemplate]
]
+ where
+ parse = parseTemplateElemsFile ""
--------------------------------------------------------------------------------
@@ -113,6 +125,8 @@ testApplyJoinTemplateList :: Assertion
testApplyJoinTemplateList = do
store <- newTestStore
provider <- newTestProvider store
+ tpl <- testCompilerDone store provider "tpl" $
+ compileTemplateItem (Item "tpl" "<b>$body$</b>")
str <- testCompilerDone store provider "item3" $
applyJoinTemplateList ", " tpl defaultContext [i1, i2]
@@ -121,4 +135,22 @@ testApplyJoinTemplateList = do
where
i1 = Item "item1" "Hello"
i2 = Item "item2" "World"
- tpl = readTemplate "<b>$body$</b>"
+
+
+--------------------------------------------------------------------------------
+embeddedTemplate :: Template
+embeddedTemplate = $(embedTemplate "tests/data/embed.html")
+
+--------------------------------------------------------------------------------
+testEmbeddedTemplate :: Assertion
+testEmbeddedTemplate = do
+ store <- newTestStore
+ provider <- newTestProvider store
+ str <- testCompilerDone store provider "item3" $
+ applyTemplate embeddedTemplate defaultContext item
+
+ itemBody str @?= "<p>Hello, world</p>\n"
+ cleanTestEnv
+ where
+ item = Item "item1" "Hello, world"
+
diff --git a/tests/TestSuite/Util.hs b/tests/TestSuite/Util.hs
index fa411f8..2678fea 100644
--- a/tests/TestSuite/Util.hs
+++ b/tests/TestSuite/Util.hs
@@ -6,6 +6,7 @@ module TestSuite.Util
, newTestProvider
, testCompiler
, testCompilerDone
+ , testCompilerError
, testConfiguration
, cleanTestEnv
, renderParagraphs
@@ -13,7 +14,7 @@ module TestSuite.Util
--------------------------------------------------------------------------------
-import Data.List (intercalate)
+import Data.List (intercalate, isInfixOf)
import Data.Monoid (mempty)
import qualified Data.Set as S
import Test.Tasty
@@ -80,13 +81,21 @@ testCompilerDone store provider underlying compiler = do
CompilerDone x _ -> return x
CompilerError e -> fail $
"TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++
- " threw: " ++ intercalate "; " e
+ " threw: " ++ intercalate "; " (compilerErrorMessages e)
CompilerRequire i _ -> fail $
"TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++
" requires: " ++ show i
CompilerSnapshot _ _ -> fail
"TestSuite.Util.testCompilerDone: unexpected CompilerSnapshot"
+testCompilerError :: Store -> Provider -> Identifier -> Compiler a -> String -> IO ()
+testCompilerError store provider underlying compiler expectedMessage = do
+ result <- testCompiler store provider underlying compiler
+ case result of
+ CompilerError e ->
+ any (expectedMessage `isInfixOf`) (compilerErrorMessages e) @?
+ "Expecting '" ++ expectedMessage ++ "' error"
+ _ -> assertFailure "Expecting CompilerError"
--------------------------------------------------------------------------------
testConfiguration :: Configuration
diff --git a/tests/data/embed.html b/tests/data/embed.html
new file mode 100644
index 0000000..6860e73
--- /dev/null
+++ b/tests/data/embed.html
@@ -0,0 +1 @@
+<p>$body$</p>
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-22 06:10:45 +0000