diff --git a/lib/Hakyll/Core/Compiler.hs b/lib/Hakyll/Core/Compiler.hs index 42b24d68c..b7e15e799 100644 --- a/lib/Hakyll/Core/Compiler.hs +++ b/lib/Hakyll/Core/Compiler.hs @@ -24,11 +24,13 @@ module Hakyll.Core.Compiler , cached , unsafeCompiler , debugCompiler + , failBranch + , mapError ) where -------------------------------------------------------------------------------- -import Control.Monad (when, unless) +import Control.Monad (when, unless, (>=>)) import Data.Binary (Binary) import Data.ByteString.Lazy (ByteString) import Data.Typeable (Typeable) @@ -62,6 +64,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 +144,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 +184,34 @@ 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.12.0 +failBranch :: String -> Compiler a +failBranch = compilerFailBranch . return + + +-------------------------------------------------------------------------------- +-- | Map over the error list from a failed compilation. +-- Unlike @\``Control.Monad.Except.catchError`\` ('Control.Monad.Except.throwError' . f)@, +-- it keeps the distinction between 'fail' and 'failBranch'. +-- +-- @since 4.12.0 +mapError :: ([String] -> [String]) -> Compiler a -> Compiler a +mapError f = compilerTry >=> either (compilerResult . CompilerError . fmap f) return + + +-------------------------------------------------------------------------------- +-- | 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 5b6d1aacc..33ba543a7 100644 --- a/lib/Hakyll/Core/Compiler/Internal.hs +++ b/lib/Hakyll/Core/Compiler/Internal.hs @@ -4,25 +4,33 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} module Hakyll.Core.Compiler.Internal ( -- * Types Snapshot , CompilerRead (..) , CompilerWrite (..) + , Reason (..) , CompilerResult (..) , Compiler (..) , runCompiler -- * Core operations + , compilerResult , compilerTell , compilerAsk + , compilerUnsafeIO + + -- * Error operations , compilerThrow + , compilerFailBranch , compilerCatch - , compilerResult - , compilerUnsafeIO + , compilerTry + , getReason -- * Utilities + , compilerDebugEntries , compilerTellDependencies , compilerTellCacheHits ) where @@ -32,7 +40,7 @@ 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 (..)) #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup (..)) #endif @@ -45,7 +53,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 +82,7 @@ data CompilerRead = CompilerRead , -- | Compiler store compilerStore :: Store , -- | Logger - compilerLogger :: Logger + compilerLogger :: Logger.Logger } @@ -104,11 +111,28 @@ 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 Reason a + -- | An exception occured during compilation + = CompilationFailure a + -- | Absence of any result, most notably in template contexts + | NoCompilationResult a + deriving Functor + + +-- | Unwrap a `Reason` +getReason :: Reason a -> a +getReason (CompilationFailure x) = x +getReason (NoCompilationResult 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 (Reason [String]) -------------------------------------------------------------------------------- @@ -126,14 +150,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 +170,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 +194,138 @@ 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.failBranch' instance MonadError [String] Compiler where - throwError = compilerThrow - catchError = compilerCatch + throwError = compilerThrow + catchError c = compilerCatch c . (. getReason) -------------------------------------------------------------------------------- +-- | 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.failBranch'. +-- 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 = compilerFailBranch [] + x <|> y = x `compilerCatch` (\rx -> y `compilerCatch` (\ry -> + case (rx, ry) of + (CompilationFailure xs, CompilationFailure ys) -> compilerThrow $ xs ++ ys + (CompilationFailure xs, NoCompilationResult ys) -> debug ys >> compilerThrow xs + (NoCompilationResult xs, CompilationFailure ys) -> debug xs >> compilerThrow ys + (NoCompilationResult xs, NoCompilationResult ys) -> compilerFailBranch $ 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 #-} + + +-------------------------------------------------------------------------------- +-- | Put a 'CompilerError' with multiple error messages as 'CompilationFailure' compilerThrow :: [String] -> Compiler a -compilerThrow es = Compiler $ \_ -> return $ CompilerError es -{-# INLINE compilerThrow #-} +compilerThrow = compilerResult . CompilerError . CompilationFailure + + +-- | Put a 'CompilerError' with multiple messages as 'NoCompilationResult' +compilerFailBranch :: [String] -> Compiler a +compilerFailBranch = compilerResult . CompilerError . NoCompilationResult -------------------------------------------------------------------------------- -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 (Reason [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 -> (Reason [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 c9373bf79..6222eb8a1 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 6f950a6df..9b7de1748 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/Internal.hs b/lib/Hakyll/Core/Provider/Internal.hs index c298653af..a3f78fa7e 100644 --- a/lib/Hakyll/Core/Provider/Internal.hs +++ b/lib/Hakyll/Core/Provider/Internal.hs @@ -22,6 +22,7 @@ module Hakyll.Core.Provider.Internal -------------------------------------------------------------------------------- import Control.DeepSeq (NFData (..), deepseq) import Control.Monad (forM) +import Control.Applicative ((<|>)) import Data.Binary (Binary (..)) import qualified Data.ByteString.Lazy as BL import Data.Map (Map) @@ -32,7 +33,7 @@ import qualified Data.Set as S import Data.Time (Day (..), UTCTime (..)) import Data.Typeable (Typeable) import System.Directory (getModificationTime) -import System.FilePath (addExtension, ()) +import System.FilePath (stripExtension, ()) -------------------------------------------------------------------------------- @@ -106,10 +107,7 @@ newProvider :: Store -- ^ Store to use -> IO Provider -- ^ Resulting provider newProvider store ignore directory = do list <- map fromFilePath <$> getRecursiveContents ignore directory - let universe = S.fromList list - files <- fmap (maxmtime . M.fromList) $ forM list $ \identifier -> do - rInfo <- getResourceInfo directory universe identifier - return (identifier, rInfo) + files <- M.fromListWith combine <$> mapM (getResourceInfo directory) list -- Get the old files from the store, and then immediately replace them by -- the new files. @@ -120,20 +118,20 @@ newProvider store ignore directory = do where oldKey = ["Hakyll.Core.Provider.Internal.newProvider", "oldFiles"] - -- Update modified if metadata is modified - maxmtime files = flip M.map files $ \rInfo@(ResourceInfo mtime meta) -> - let metaMod = fmap resourceInfoModified $ meta >>= flip M.lookup files - in rInfo {resourceInfoModified = maybe mtime (max mtime) metaMod} + -- Combine a resource with its metadata file + combine (ResourceInfo xTime xMeta) (ResourceInfo yTime yMeta) = + ResourceInfo (xTime `max` yTime) (xMeta <|> yMeta) -------------------------------------------------------------------------------- -getResourceInfo :: FilePath -> Set Identifier -> Identifier -> IO ResourceInfo -getResourceInfo directory universe identifier = do - mtime <- fileModificationTime $ directory toFilePath identifier - return $ ResourceInfo (BinaryTime mtime) $ - if mdRsc `S.member` universe then Just mdRsc else Nothing - where - mdRsc = fromFilePath $ flip addExtension "metadata" $ toFilePath identifier +getResourceInfo :: FilePath -> Identifier -> IO (Identifier, ResourceInfo) +getResourceInfo directory identifier = do + let file = toFilePath identifier + mtime <- fileModificationTime $ directory file + let makeInfo m = ResourceInfo (BinaryTime mtime) m + return $ case stripExtension "metadata" file of + Nothing -> (identifier, makeInfo Nothing) + Just r -> (fromFilePath r, makeInfo (Just identifier)) -------------------------------------------------------------------------------- diff --git a/lib/Hakyll/Core/Provider/Metadata.hs b/lib/Hakyll/Core/Provider/Metadata.hs index 6285ce17b..ee4caaa1f 100644 --- a/lib/Hakyll/Core/Provider/Metadata.hs +++ b/lib/Hakyll/Core/Provider/Metadata.hs @@ -27,12 +27,14 @@ import Hakyll.Core.Identifier import Hakyll.Core.Metadata import Hakyll.Core.Provider.Internal import System.IO as IO +import System.IO.Error (catchIOError, modifyIOError, + ioeSetLocation) -------------------------------------------------------------------------------- loadMetadata :: Provider -> Identifier -> IO (Metadata, Maybe String) loadMetadata p identifier = do - hasHeader <- probablyHasMetadataHeader fp + hasHeader <- probablyHasMetadataHeader fp `catchIOError` \_ -> return False (md, body) <- if hasHeader then second Just <$> loadMetadataHeader fp else return (mempty, Nothing) @@ -51,7 +53,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 +62,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/Provider/MetadataCache.hs b/lib/Hakyll/Core/Provider/MetadataCache.hs index 46dbf3ed1..02f7cac35 100644 --- a/lib/Hakyll/Core/Provider/MetadataCache.hs +++ b/lib/Hakyll/Core/Provider/MetadataCache.hs @@ -18,7 +18,9 @@ import qualified Hakyll.Core.Store as Store -------------------------------------------------------------------------------- resourceMetadata :: Provider -> Identifier -> IO Metadata resourceMetadata p r - | not (resourceExists p r) = return mempty + | not (resourceExists p r) = fail $ unwords [ + "Hakyll.Core.Provider.MetadataCache.resourceMetadata:", + "cannot read metadata,", show r, "does not exist"] | otherwise = do -- TODO keep time in md cache load p r diff --git a/lib/Hakyll/Core/Runtime.hs b/lib/Hakyll/Core/Runtime.hs index 16a5d9e5f..4fb513832 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 getReason 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 fdbcf11f7..23299db5e 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 @@ -31,6 +30,8 @@ import System.Directory (createDirectoryIfMissing) import System.Directory (doesFileExist, removeFile) import System.FilePath (()) import System.IO (IOMode (..), hClose, openFile) +import System.IO.Error (catchIOError, modifyIOError, + ioeSetFileName, ioeSetLocation) import Text.Printf (printf) @@ -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 2cafe022c..248d95068 100644 --- a/lib/Hakyll/Web/Feed.hs +++ b/lib/Hakyll/Web/Feed.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- | A Module that allows easy rendering of RSS feeds. @@ -41,20 +42,20 @@ import qualified Data.Text.Encoding as T -------------------------------------------------------------------------------- -rssTemplate :: String -rssTemplate = T.unpack $ +rssTemplate :: Item String +rssTemplate = Item "templates/rss.xml" $ T.unpack $ T.decodeUtf8 $(embedFile "data/templates/rss.xml") -rssItemTemplate :: String -rssItemTemplate = T.unpack $ +rssItemTemplate :: Item String +rssItemTemplate = Item "templates/rss-item.xml" $ T.unpack $ T.decodeUtf8 $(embedFile "data/templates/rss-item.xml") -atomTemplate :: String -atomTemplate = T.unpack $ +atomTemplate :: Item String +atomTemplate = Item "templates/atom.xml" $ T.unpack $ T.decodeUtf8 $(embedFile "data/templates/atom.xml") -atomItemTemplate :: String -atomItemTemplate = T.unpack $ +atomItemTemplate :: Item String +atomItemTemplate = Item "templates/atom-item.xml" $ T.unpack $ T.decodeUtf8 $(embedFile "data/templates/atom-item.xml") @@ -76,15 +77,15 @@ data FeedConfiguration = FeedConfiguration -------------------------------------------------------------------------------- -- | Abstract function to render any feed. -renderFeed :: String -- ^ Default feed template - -> String -- ^ Default item template +renderFeed :: Item String -- ^ Default feed template + -> Item String -- ^ 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 + feedTpl <- compileTemplateItem defFeed + itemTpl <- compileTemplateItem defItem protectedItems <- mapM (applyFilter protectCDATA) items body <- makeItem =<< applyTemplateList itemTpl itemContext' protectedItems @@ -119,12 +120,8 @@ 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 with a number of items. diff --git a/lib/Hakyll/Web/Template.hs b/lib/Hakyll/Web/Template.hs index a4361069b..62690bbb4 100644 --- a/lib/Hakyll/Web/Template.hs +++ b/lib/Hakyll/Web/Template.hs @@ -140,14 +140,13 @@ -- module Hakyll.Web.Template ( Template - , template - , readTemplateElems , templateBodyCompiler , templateCompiler , applyTemplate , loadAndApplyTemplate , applyAsTemplate , readTemplate + , compileTemplateItem , unsafeReadTemplateFile ) where diff --git a/lib/Hakyll/Web/Template/Context.hs b/lib/Hakyll/Web/Template/Context.hs index dae241ca6..d985eafc7 100644 --- a/lib/Hakyll/Web/Template/Context.hs +++ b/lib/Hakyll/Web/Template/Context.hs @@ -1,15 +1,42 @@ +-- | 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 #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} + module Hakyll.Web.Template.Context ( ContextField (..) , Context (..) + , context + , functionContext + , toContextField , field , boolField , constField , listField , listFieldWith , functionField + , dataField , mapContext , defaultContext @@ -34,10 +61,17 @@ module Hakyll.Web.Template.Context -------------------------------------------------------------------------------- import Control.Applicative (Alternative (..)) import Control.Monad (msum) +import Data.Char (toUpper) +import Text.Read (readMaybe) import Data.List (intercalate) #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup (..)) #endif +import Data.Yaml (Value (..)) +import qualified Data.Text as T +import qualified Data.HashMap.Strict as H +import qualified Data.Vector as V +import Data.Yaml.Extended (toString) import Data.Time.Clock (UTCTime (..)) import Data.Time.Format (formatTime) import qualified Data.Time.Format as TF @@ -51,14 +85,16 @@ import Hakyll.Core.Provider import Hakyll.Core.Util.String (needlePrefix, splitAll) import Hakyll.Web.Html import System.FilePath (splitDirectories, takeBaseName) +import Prelude hiding (id) -------------------------------------------------------------------------------- -- | Mostly for internal usage data ContextField - = StringField String + = EmptyField + | StringField String | forall a. ListField (Context a) [Item a] - + | forall a. LexicalListField (forall b. Context b -> a -> Context b) [a] -------------------------------------------------------------------------------- -- | The 'Context' monoid. Please note that the order in which you @@ -81,6 +117,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 @@ -96,65 +134,125 @@ 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 +class ToContextField a where + toContextField :: a -> Compiler ContextField + +instance ToContextField ContextField where + toContextField = return + +instance ToContextField a => ToContextField (Compiler a) where + toContextField = (>>= toContextField) + +instance ToContextField [Char] where + toContextField = return . StringField + +instance ToContextField Bool where + toContextField True = return EmptyField + toContextField False = failBranch "False" + +instance ToContextField a => ToContextField (Maybe a) where + toContextField = maybe (failBranch "False") toContextField -------------------------------------------------------------------------------- --- | Constructs a new field in the 'Context.' +functionContext :: ToContextField c => String -> ([String] -> Item a -> c) -> Context a +functionContext key value = Context $ \k args item -> + if k == key + then mapError details $ toContextField $ value args item + else failBranch $ "Tried field " ++ key + where + details [] = ["No result at field "++key] + details ["False"] = ["Field "++key++" is False"] + details errors = ("In evaluation of field "++key) : errors + +context :: ToContextField c => String -> (Item a -> c) -> Context a +context key = functionContext key . const + + +-------------------------------------------------------------------------------- +-- | 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 'failBranch' 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) +field = context -------------------------------------------------------------------------------- -- | 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 = context -------------------------------------------------------------------------------- --- | Creates a 'field' that does not depend on the 'Item' -constField :: String -> String -> Context a -constField key = field key . const . return +-- | 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 = context key . const -------------------------------------------------------------------------------- +-- | 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 +listFieldWith key c f = context key $ fmap (ListField c) . f -------------------------------------------------------------------------------- -functionField :: String -> ([String] -> Item a -> Compiler String) -> Context a -functionField name value = Context $ \k args i -> - if k == name - then StringField <$> value args i - else empty +-- | 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 = functionContext -------------------------------------------------------------------------------- +-- | 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 +261,71 @@ 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()'" + + + +dataField :: String -> Value -> Context a +dataField key val = Context $ \f a _ -> case splitAll "\\." f of + [k] | k == get -> lookupNestedValue a val + (k:ks) | k == key -> lookupNestedValue ks val + _ -> failBranch $ "Tried field " ++ key -- and functionField get + where + get = let (h:rest) = key in "get" ++ toUpper h : rest + +makePairContext :: Context a -> (T.Text, Value) -> Context a +makePairContext c (key, value) = pairContext <> c + where + pairContext = Context $ \k a _ -> case splitAll "\\." k of + ["get"] -> lookupNestedValue a value + ["key"] -> return $ StringField $ T.unpack key + ("value":ks) -> lookupNestedValue ks value + [] -> fail "no supposted to happen" -- , right? + keys -> lookupNestedValue keys value + +makeIndexContext :: Context a -> (Int, Value) -> Context a +makeIndexContext c (index, value) = indexContext <> c + where + indexContext = Context $ \k a _ -> case splitAll "\\." k of + ["get"] -> lookupNestedValue a value + ["index"] -> return $ StringField $ show index + ("value":ks) -> lookupNestedValue ks value + [] -> fail "no supposted to happen" -- , right? + keys -> lookupNestedValue keys value + +lookupNestedValue :: [String] -> Value -> Compiler ContextField +lookupNestedValue [] (Object o) = return $ LexicalListField makePairContext $ H.toList o +lookupNestedValue [] (Array a) = return $ LexicalListField makeIndexContext $ V.toList $ V.indexed a +lookupNestedValue [] v = return $ let Just s = toString v in StringField s +lookupNestedValue (k:ks) (Object m) = case H.lookup (T.pack k) m of + Nothing -> failBranch $ "No '"++k++"' property in object" -- ++ debug m + Just v -> lookupNestedValue ks v +lookupNestedValue (k:ks) (Array v) = case readMaybe k :: Maybe Int of + Nothing -> failBranch $ "No '"++k++"' element in array" -- ++ debug v + Just n -> case v V.!? n of + Nothing -> failBranch $ "No '"++k++"' index in array of size " ++ show (length v) -- ++ debug v + Just v -> lookupNestedValue ks v +lookupNestedValue (k:_) _ = failBranch $ "no '"++k++"' in primitive value" -- ++ debug p + + + + + + + + + + + + -------------------------------------------------------------------------------- -- | A context that contains (in that order) @@ -191,8 +345,7 @@ defaultContext = metadataField `mappend` urlField "url" `mappend` pathField "path" `mappend` - titleField "title" `mappend` - missingField + titleField "title" -------------------------------------------------------------------------------- @@ -203,28 +356,33 @@ teaserSeparator = "" -------------------------------------------------------------------------------- -- | Constructs a 'field' that contains the body of the item. bodyField :: String -> Context String -bodyField key = field key $ return . itemBody +bodyField key = context key 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' = failBranch $ "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 -------------------------------------------------------------------------------- -- | Filepath of the underlying file of the item pathField :: String -> Context a -pathField key = field key $ return . toFilePath . itemIdentifier +pathField key = context key $ toFilePath . itemIdentifier -------------------------------------------------------------------------------- @@ -279,7 +437,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 @@ -333,6 +491,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 @@ -340,6 +499,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 @@ -378,10 +539,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 _ _ -> failBranch $ + "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 154cee6f8..0eea92a77 100644 --- a/lib/Hakyll/Web/Template/Internal.hs +++ b/lib/Hakyll/Web/Template/Internal.hs @@ -1,15 +1,20 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + module Hakyll.Web.Template.Internal - ( Template (..) + ( Template , template + , unTemplate + , getOrigin , templateBodyCompiler , templateCompiler , applyTemplate - , applyTemplate' , loadAndApplyTemplate , applyAsTemplate , readTemplate + , compileTemplateItem , unsafeReadTemplateFile , module Hakyll.Web.Template.Internal.Element @@ -18,16 +23,18 @@ module Hakyll.Web.Template.Internal -------------------------------------------------------------------------------- -import Control.Monad.Except (MonadError (..)) +import Data.Monoid ((<>)) import Data.Binary (Binary) import Data.List (intercalate) import Data.Typeable (Typeable) import GHC.Exts (IsString (..)) -import Prelude hiding (id) +import GHC.Generics (Generic) +import Control.Monad.Except (catchError) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler +import Hakyll.Core.Compiler.Internal import Hakyll.Core.Identifier import Hakyll.Core.Item import Hakyll.Core.Writable @@ -38,9 +45,10 @@ import Hakyll.Web.Template.Internal.Trim -------------------------------------------------------------------------------- -- | Datatype used for template substitutions. -newtype Template = Template +data Template = Template { unTemplate :: [TemplateElement] - } deriving (Show, Eq, Binary, Typeable) + , getOrigin :: FilePath + } deriving (Show, Eq, Generic, Binary, Typeable) -------------------------------------------------------------------------------- @@ -56,39 +64,67 @@ 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}" + +-------------------------------------------------------------------------------- +-- | 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' (unTemplate tpl) context item `catchError` handler return $ itemSetBody body item + where + tplName = getOrigin 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 +141,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 +151,47 @@ applyTemplate' tes context x = go tes applyElem (Chunk c) = return c - applyElem (Expr e) = applyExpr e >>= getString e + applyElem (Expr e) = applyStringExpr (evalMsg:) 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 + f = maybe (return "") go mf + handle (Right _) = go t + handle (Left (NoCompilationResult _)) = f + handle (Left (CompilationFailure es)) = debug es >> f + debug = compilerDebugEntries ("Hakyll.Web.Template.applyTemplate: " ++ + "[ERROR] in 'if' condition on expr '" ++ show e ++ "':") + + applyElem (For e b s) = do + bs <- mapError (headMsg:) (applyExpr e) >>= getList + sep <- maybe (return "") go s + return $ intercalate sep bs 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 - sep <- maybe (return "") go s - bs <- mapM (applyTemplate' b c) xs - return $ intercalate sep bs + getList EmptyField = expected "list" "boolean" typeMsg + getList (StringField _) = expected "list" "string" typeMsg + getList (ListField c xs) = mapError (bodyMsg:) $ + mapM (applyTemplate' b c) xs + getList (LexicalListField mc vs) = mapError (bodyMsg:) $ + mapM (\v -> applyTemplate' b (mc context v) x) vs + + 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 + p <- applyStringExpr (headMsg:) typeMsg e + mapError (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 +200,27 @@ 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 id (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 wrap msg expr = mapError wrap (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 +250,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 f564355f8..fc7750136 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 63d6698c2..2b8400467 100644 --- a/tests/Hakyll/Core/UnixFilter/Tests.hs +++ b/tests/Hakyll/Core/UnixFilter/Tests.hs @@ -6,7 +6,6 @@ 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 @@ -14,7 +13,6 @@ import qualified Test.Tasty.HUnit as H -------------------------------------------------------------------------------- import Hakyll.Core.Compiler -import Hakyll.Core.Compiler.Internal import Hakyll.Core.Item import Hakyll.Core.UnixFilter import Hakyll.Core.Identifier @@ -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,10 +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 ("invalid option" `isInfixOf`) es - _ -> H.assertFailure "Expecting CompilerError" + testCompilerError store provider testMarkdown compiler "option" cleanTestEnv where compiler = getResourceString >>= withItemBody (unixFilter "head" ["-#"]) diff --git a/tests/Hakyll/Web/Template/Context/Tests.hs b/tests/Hakyll/Web/Template/Context/Tests.hs index f26339184..06f983613 100644 --- a/tests/Hakyll/Web/Template/Context/Tests.hs +++ b/tests/Hakyll/Web/Template/Context/Tests.hs @@ -53,6 +53,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 b63a0dd7c..94a4ce477 100644 --- a/tests/Hakyll/Web/Template/Tests.hs +++ b/tests/Hakyll/Web/Template/Tests.hs @@ -8,8 +8,9 @@ module Hakyll.Web.Template.Tests -------------------------------------------------------------------------------- import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, testCase, (@=?), - (@?=)) + (@?=), assertBool) +import Data.Either (isLeft) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler @@ -32,13 +33,13 @@ tests = testGroup "Hakyll.Core.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 +55,37 @@ tests = testGroup "Hakyll.Core.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

foo

\n$endif$" ] ] + where + parse = parseTemplateElemsFile "" -------------------------------------------------------------------------------- diff --git a/tests/TestSuite/Util.hs b/tests/TestSuite/Util.hs index fa411f82c..fc9d59a2a 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,20 @@ testCompilerDone store provider underlying compiler = do CompilerDone x _ -> return x CompilerError e -> fail $ "TestSuite.Util.testCompilerDone: compiler " ++ show underlying ++ - " threw: " ++ intercalate "; " e + " threw: " ++ intercalate "; " (getReason 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`) (getReason e) @? + "Expecting '" ++ expectedMessage ++ "' error" + _ -> assertFailure "Expecting CompilerError" -------------------------------------------------------------------------------- testConfiguration :: Configuration