hakyll 4.12.5.2 → 4.13.0.0

raw patch · 21 files changed

+597/−232 lines, 21 filesdep +template-haskelldep ~QuickCheckPVP ok

version bump matches the API change (PVP)

Dependencies added: template-haskell

Dependency ranges changed: QuickCheck

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• hakyll.cabal +7/−5
• lib/Hakyll/Core/Compiler.hs +35/−2
• lib/Hakyll/Core/Compiler/Internal.hs +126/−41
• lib/Hakyll/Core/Compiler/Require.hs +2/−0
• lib/Hakyll/Core/Logger.hs +9/−3
• lib/Hakyll/Core/Provider/Metadata.hs +3/−2
• lib/Hakyll/Core/Runtime.hs +3/−3
• lib/Hakyll/Core/Store.hs +20/−20
• lib/Hakyll/Web/Feed.hs +24/−31
• lib/Hakyll/Web/Tags.hs +1/−1
• lib/Hakyll/Web/Template.hs +24/−2
• lib/Hakyll/Web/Template/Context.hs +108/−31
• lib/Hakyll/Web/Template/Internal.hs +99/−41
• lib/Hakyll/Web/Template/Internal/Element.hs +7/−14
• tests/Hakyll/Core/UnixFilter/Tests.hs +6/−16
• tests/Hakyll/Web/Tags/Tests.hs +42/−0
• tests/Hakyll/Web/Template/Context/Tests.hs +7/−2
• tests/Hakyll/Web/Template/Tests.hs +48/−16
• tests/TestSuite.hs +2/−0
• tests/TestSuite/Util.hs +11/−2

@@ -4,6 +4,19 @@  # Releases +## Hakyll 4.13.0.0 (2019-08-30)++- Improved documentation in many places (contribution by Bergi)+- Significantly improve error messages when reading and applying templates+  (contribution by Bergi)+    * `empty` and `fail` for `Compiler` now fail without or with a message,+      allowing for much better debug output+    * `renderFeed`, `renderRssWithTemplates` and `renderAtomWithTemplates` now+      take `Template` rather than `String` arguments+- Add option to specify date in directory structure,e.g.+  `posts/2019/05/10/tomorrow.md` (contribution by Taeer Bar-Ya)+- Bump QuickCheck to 2.13+ ## Hakyll 4.12.5.2 (2019-05-09)  - Bump pandoc to 2.7

@@ -1,5 +1,5 @@ Name:    hakyll-Version: 4.12.5.2+Version: 4.13.0.0  Synopsis: A static website compiler library Description:@@ -172,10 +172,12 @@     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 @@     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:@@ -254,13 +255,14 @@     Hakyll.Web.CompressCss.Tests     Hakyll.Web.Html.RelativizeUrls.Tests     Hakyll.Web.Html.Tests+    Hakyll.Web.Tags.Tests     Hakyll.Web.Template.Context.Tests     Hakyll.Web.Template.Tests     TestSuite.Util    Build-Depends:     hakyll,-    QuickCheck                 >= 2.8  && < 2.13,+    QuickCheck                 >= 2.8  && < 2.14,     tasty                      >= 0.11 && < 1.3,     tasty-hunit                >= 0.9  && < 0.11,     tasty-quickcheck           >= 0.8  && < 0.11,

@@ -24,13 +24,16 @@     , 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 @@   --------------------------------------------------------------------------------+-- | 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 @@   --------------------------------------------------------------------------------+-- | 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 @@   --------------------------------------------------------------------------------+-- | 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

@@ -1,6 +1,7 @@ -------------------------------------------------------------------------------- -- | Internally used compiler module {-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveFunctor              #-} {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -10,19 +11,26 @@       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 @@ 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.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 @@     , -- | Compiler store       compilerStore      :: Store     , -- | Logger-      compilerLogger     :: Logger+      compilerLogger     :: Logger.Logger     }  @@ -104,14 +113,32 @@   ---------------------------------------------------------------------------------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)+++-------------------------------------------------------------------------------- -- | A monad which lets you compile items and takes care of dependency tracking -- for you. newtype Compiler a = Compiler@@ -126,14 +153,14 @@         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 @@                     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 @@   --------------------------------------------------------------------------------+-- | 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 #-} 

@@ -91,6 +91,7 @@   --------------------------------------------------------------------------------+-- | 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 @@   --------------------------------------------------------------------------------+-- | 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

@@ -18,6 +18,7 @@ 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 @@  -------------------------------------------------------------------------------- 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 @@  -------------------------------------------------------------------------------- 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

@@ -27,6 +27,7 @@ import           Hakyll.Core.Metadata import           Hakyll.Core.Provider.Internal import           System.IO                     as IO+import           System.IO.Error               (modifyIOError, ioeSetLocation)   --------------------------------------------------------------------------------@@ -51,7 +52,7 @@ -------------------------------------------------------------------------------- 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 @@ -------------------------------------------------------------------------------- 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 

@@ -199,9 +199,9 @@         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

@@ -16,7 +16,6 @@   ---------------------------------------------------------------------------------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     (doesFileExist, removeFile) import           System.FilePath      ((</>)) import           System.IO            (IOMode (..), hClose, openFile)+import           System.IO.Error      (catchIOError, ioeSetFileName,+                                       ioeSetLocation, modifyIOError)   --------------------------------------------------------------------------------@@ -84,6 +85,14 @@   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 @@ -------------------------------------------------------------------------------- -- | 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 @@                 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 @@ -------------------------------------------------------------------------------- -- | 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   --------------------------------------------------------------------------------

@@ -1,4 +1,5 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}  -------------------------------------------------------------------------------- -- | A Module that allows easy rendering of RSS feeds.@@ -37,28 +38,27 @@   ---------------------------------------------------------------------------------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 :: String-atomItemTemplate = T.unpack $-    T.decodeUtf8 $(makeRelativeToProject "data/templates/atom-item.xml" >>= embedFile)+atomItemTemplate :: Template+atomItemTemplate =+    $(makeRelativeToProject "data/templates/atom-item.xml" >>= embedTemplate) + -------------------------------------------------------------------------------- -- | This is a data structure to keep the configuration of a feed. data FeedConfiguration = FeedConfiguration@@ -77,16 +77,13 @@  -------------------------------------------------------------------------------- -- | 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 @@     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 @@ -------------------------------------------------------------------------------- -- | 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

@@ -113,7 +113,7 @@   ----------------------------------------------------------------------------------- | Obtain categories from a page.+-- | Obtain category from a page. getCategory :: MonadMetadata m => Identifier -> m [String] getCategory = return . return . takeBaseName . takeDirectory . toFilePath 

@@ -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 |]

@@ -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 #-}@@ -34,7 +54,7 @@ -------------------------------------------------------------------------------- import           Control.Applicative           (Alternative (..)) import           Control.Monad                 (msum)-import           Data.List                     (intercalate)+import           Data.List                     (intercalate, tails) #if MIN_VERSION_base(4,9,0) import           Data.Semigroup                (Semigroup (..)) #endif@@ -50,13 +70,16 @@ 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 @@   --------------------------------------------------------------------------------+-- | 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 @@  -------------------------------------------------------------------------------- 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 @@ -- > $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 @@     metadataField            `mappend`     urlField      "url"      `mappend`     pathField     "path"     `mappend`-    titleField    "title"    `mappend`-    missingField+    titleField    "title"   --------------------------------------------------------------------------------@@ -210,15 +271,20 @@ -- | 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   --------------------------------------------------------------------------------@@ -269,6 +335,12 @@ -- that begins with @yyyy-mm-dd@ . For example: -- @folder//yyyy-mm-dd-title//dist//main.extension@ . -- In case of multiple matches, the rightmost one is used.+--+-- 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@ .+-- As above, in case of multiple matches, the rightmost one is used.  dateField :: String     -- ^ Key in which the rendered date should be placed           -> String     -- ^ Format to use on the date@@ -279,7 +351,7 @@ -------------------------------------------------------------------------------- -- | 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@@ -305,7 +377,8 @@     maybe empty' return $ msum $         [tryField "published" fmt | fmt <- formats] ++         [tryField "date"      fmt | fmt <- formats] ++-        [parseTime' "%Y-%m-%d" $ intercalate "-" $ take 3 $ splitAll "-" fnCand | fnCand <- reverse paths]+        [parseTime' "%Y-%m-%d" $ intercalate "-" $ take 3 $ splitAll "-" fnCand | fnCand <- reverse paths] +++        [parseTime' "%Y-%m-%d" $ intercalate "-" $ fnCand | fnCand <- map (take 3) $ reverse . tails $ paths]   where     empty'     = fail $ "Hakyll.Web.Template.Context.getItemUTC: " ++         "could not parse time for " ++ show id'@@ -333,6 +406,7 @@   --------------------------------------------------------------------------------+-- | Creates a field with the last modification date of the underlying item. modificationTimeField :: String     -- ^ Key                       -> String     -- ^ Format                       -> Context  a -- ^ Resulting context@@ -340,6 +414,8 @@   --------------------------------------------------------------------------------+-- | 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@@ -378,10 +454,11 @@   --------------------------------------------------------------------------------+-- | 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)

@@ -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 @@   ---------------------------------------------------------------------------------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 @@  -------------------------------------------------------------------------------- -- | 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,41 +62,70 @@  -------------------------------------------------------------------------------- -- | 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  + -------------------------------------------------------------------------------- applyTemplate'     :: forall a.@@ -105,9 +140,6 @@      go = fmap concat . mapM applyElem -    trimError = error $ "Hakyll.Web.Template.applyTemplate: template not " ++-        "fully trimmed."-     ---------------------------------------------------------------------------      applyElem :: TemplateElement -> Compiler String@@ -118,29 +150,43 @@      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+        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) = 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+    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+      where+        headMsg = "In expr '$for(" ++ show e ++ ")$'"+        typeMsg = "loop expr '" ++ show e ++ "'"+        bodyMsg = "In loop context of '$for(" ++ show e ++ ")$'" -    applyElem (Partial e) = do-        p             <- applyExpr e >>= getString e-        Template tpl' <- loadBody (fromFilePath p)-        applyTemplate' tpl' context x+    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,19 +195,31 @@     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."++ -------------------------------------------------------------------------------- -- | The following pattern is so common: --@@ -189,14 +247,14 @@ 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" #-}

@@ -7,14 +7,14 @@     , 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 @@         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 @@ -------------------------------------------------------------------------------- trimClose :: P.Parser Bool trimClose = do-    trimIfR <- P.optionMaybe $ P.try (P.char '-')+    trimIfR <- P.optionMaybe $ (P.char '-')     void $ P.char '$'     pure $ isJust trimIfR 

@@ -6,18 +6,16 @@   ---------------------------------------------------------------------------------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 = 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 = 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

@@ -0,0 +1,42 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Hakyll.Web.Tags.Tests+    ( tests+    ) where++--------------------------------------------------------------------------------+import           Test.Tasty                  (TestTree, testGroup)+import           Test.Tasty.HUnit            (Assertion, testCase, (@?=))++--------------------------------------------------------------------------------+import           Hakyll.Core.Identifier+import           Hakyll.Core.Provider+import           Hakyll.Core.Store           (Store)+import           Hakyll.Web.Tags+import           TestSuite.Util++tests :: TestTree+tests = testGroup "Hakyll.Web.Tags"+    [ testCase "testGetCategory" testGetCategory+    ]++testGetCategory :: Assertion+testGetCategory = do+    store    <- newTestStore+    provider <- newTestProvider store++    noCategory <- testCategoryDone store provider "example.md"+    noCategory @?= [""]++    oneCategory1 <- testCategoryDone store provider "posts/2010-08-26-birthday.md"+    oneCategory1 @?= ["posts"]++    oneCategory2 <- testCategoryDone store provider "posts/2019/05/10/tomorrow.md"+    oneCategory2 @?= ["10"]++    cleanTestEnv++--------------------------------------------------------------------------------+testCategoryDone :: Store -> Provider -> Identifier -> IO [String]+testCategoryDone store provider identifier =+    testCompilerDone store provider identifier $ getCategory identifier

@@ -45,6 +45,11 @@         "posts/2018-09-26.md" "date" $             dateField "date" "%B %e, %Y"     date3 @=? "September 26, 2018"++    date4 <- testContextDone store provider+        "posts/2019/05/10/tomorrow.md" "date" $+            dateField "date" "%B %e, %Y"+    date4 @=? "May 10, 2019"     cleanTestEnv  @@ -57,6 +62,6 @@         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"

@@ -1,5 +1,6 @@ -------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-} module Hakyll.Web.Template.Tests     ( tests     ) where@@ -7,9 +8,10 @@  -------------------------------------------------------------------------------- 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 @@       , 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 @@                      ])           , 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 = 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 @@   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"+

@@ -28,6 +28,7 @@ #endif import qualified Hakyll.Web.Template.Context.Tests import qualified Hakyll.Web.Template.Tests+import qualified Hakyll.Web.Tags.Tests   --------------------------------------------------------------------------------@@ -49,6 +50,7 @@ #ifdef USE_PANDOC     , Hakyll.Web.Pandoc.FileType.Tests.tests #endif+    , Hakyll.Web.Tags.Tests.tests     , Hakyll.Web.Template.Context.Tests.tests     , Hakyll.Web.Template.Tests.tests     ]

@@ -6,6 +6,7 @@     , newTestProvider     , testCompiler     , testCompilerDone+    , testCompilerError     , testConfiguration     , cleanTestEnv     , renderParagraphs@@ -13,7 +14,7 @@   ---------------------------------------------------------------------------------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 @@         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