diff options
Diffstat (limited to 'lib/Hakyll/Web/Template/Internal.hs')
| -rw-r--r-- | lib/Hakyll/Web/Template/Internal.hs | 144 |
1 files changed, 101 insertions, 43 deletions
diff --git a/lib/Hakyll/Web/Template/Internal.hs b/lib/Hakyll/Web/Template/Internal.hs index 154cee6..c369560 100644 --- a/lib/Hakyll/Web/Template/Internal.hs +++ b/lib/Hakyll/Web/Template/Internal.hs @@ -1,15 +1,18 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} + module Hakyll.Web.Template.Internal ( Template (..) , template , templateBodyCompiler , templateCompiler , applyTemplate - , applyTemplate' , loadAndApplyTemplate , applyAsTemplate , readTemplate + , compileTemplateItem , unsafeReadTemplateFile , module Hakyll.Web.Template.Internal.Element @@ -18,16 +21,18 @@ module Hakyll.Web.Template.Internal -------------------------------------------------------------------------------- -import Control.Monad.Except (MonadError (..)) +import Control.Monad.Except (catchError) import Data.Binary (Binary) import Data.List (intercalate) +import qualified Data.List.NonEmpty as NonEmpty import Data.Typeable (Typeable) import GHC.Exts (IsString (..)) -import Prelude hiding (id) +import GHC.Generics (Generic) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler +import Hakyll.Core.Compiler.Internal import Hakyll.Core.Identifier import Hakyll.Core.Item import Hakyll.Core.Writable @@ -38,9 +43,10 @@ import Hakyll.Web.Template.Internal.Trim -------------------------------------------------------------------------------- -- | Datatype used for template substitutions. -newtype Template = Template - { unTemplate :: [TemplateElement] - } deriving (Show, Eq, Binary, Typeable) +data Template = Template + { tplElements :: [TemplateElement] + , tplOrigin :: FilePath -- Only for error messages. + } deriving (Show, Eq, Generic, Binary, Typeable) -------------------------------------------------------------------------------- @@ -56,39 +62,68 @@ instance IsString Template where -------------------------------------------------------------------------------- -- | Wrap the constructor to ensure trim is called. -template :: [TemplateElement] -> Template -template = Template . trim +template :: FilePath -> [TemplateElement] -> Template +template p = flip Template p . trim -------------------------------------------------------------------------------- +-- | Parse a string into a template. +-- You should prefer 'compileTemplateItem' over this. readTemplate :: String -> Template -readTemplate = Template . trim . readTemplateElems +readTemplate = either error (template origin) . parseTemplateElemsFile origin + where + origin = "{literal}" +{-# DEPRECATED readTemplate "Use templateCompiler instead" #-} + +-------------------------------------------------------------------------------- +-- | Parse an item body into a template. +-- Provides useful error messages in the 'Compiler' monad. +compileTemplateItem :: Item String -> Compiler Template +compileTemplateItem item = let file = itemIdentifier item + in compileTemplateFile file (itemBody item) + +-------------------------------------------------------------------------------- +compileTemplateFile :: Identifier -> String -> Compiler Template +compileTemplateFile file = either fail (return . template origin) + . parseTemplateElemsFile origin + where + origin = show file -------------------------------------------------------------------------------- -- | Read a template, without metadata header templateBodyCompiler :: Compiler (Item Template) templateBodyCompiler = cached "Hakyll.Web.Template.templateBodyCompiler" $ do item <- getResourceBody - file <- getResourceFilePath - return $ fmap (template . readTemplateElemsFile file) item + file <- getUnderlying + withItemBody (compileTemplateFile file) item -------------------------------------------------------------------------------- -- | Read complete file contents as a template templateCompiler :: Compiler (Item Template) templateCompiler = cached "Hakyll.Web.Template.templateCompiler" $ do item <- getResourceString - file <- getResourceFilePath - return $ fmap (template . readTemplateElemsFile file) item + file <- getUnderlying + withItemBody (compileTemplateFile file) item -------------------------------------------------------------------------------- +-- | Interpolate template expressions from context values in a page applyTemplate :: Template -- ^ Template -> Context a -- ^ Context -> Item a -- ^ Page -> Compiler (Item String) -- ^ Resulting item applyTemplate tpl context item = do - body <- applyTemplate' (unTemplate tpl) context item + body <- applyTemplate' (tplElements tpl) context item `catchError` handler return $ itemSetBody body item + where + tplName = tplOrigin tpl + itemName = show $ itemIdentifier item + handler es = fail $ "Hakyll.Web.Template.applyTemplate: Failed to " ++ + (if tplName == itemName + then "interpolate template in item " ++ itemName + else "apply template " ++ tplName ++ " to item " ++ itemName) ++ + ":\n" ++ intercalate ",\n" es + -------------------------------------------------------------------------------- @@ -105,9 +140,6 @@ applyTemplate' tes context x = go tes go = fmap concat . mapM applyElem - trimError = error $ "Hakyll.Web.Template.applyTemplate: template not " ++ - "fully trimmed." - --------------------------------------------------------------------------- applyElem :: TemplateElement -> Compiler String @@ -118,29 +150,43 @@ applyTemplate' tes context x = go tes applyElem (Chunk c) = return c - applyElem (Expr e) = applyExpr e >>= getString e + applyElem (Expr e) = withErrorMessage evalMsg (applyStringExpr typeMsg e) + where + evalMsg = "In expr '$" ++ show e ++ "$'" + typeMsg = "expr '$" ++ show e ++ "$'" applyElem Escaped = return "$" - applyElem (If e t mf) = (applyExpr e >> go t) `catchError` handler + applyElem (If e t mf) = compilerTry (applyExpr e) >>= handle where - handler _ = case mf of - Nothing -> return "" - Just f -> go f - - applyElem (For e b s) = applyExpr e >>= \cf -> case cf of - StringField _ -> fail $ - "Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++ - "got StringField for expr " ++ show e - ListField c xs -> do + f = maybe (return "") go mf + handle (Right _) = go t + handle (Left (CompilationNoResult _)) = f + handle (Left (CompilationFailure es)) = debug (NonEmpty.toList es) >> f + debug = compilerDebugEntries ("Hakyll.Web.Template.applyTemplate: " ++ + "[ERROR] in 'if' condition on expr '" ++ show e ++ "':") + + applyElem (For e b s) = withErrorMessage headMsg (applyExpr e) >>= \cf -> case cf of + EmptyField -> expected "list" "boolean" typeMsg + StringField _ -> expected "list" "string" typeMsg + ListField c xs -> withErrorMessage bodyMsg $ do sep <- maybe (return "") go s bs <- mapM (applyTemplate' b c) xs return $ intercalate sep bs - - applyElem (Partial e) = do - p <- applyExpr e >>= getString e - Template tpl' <- loadBody (fromFilePath p) - applyTemplate' tpl' context x + where + headMsg = "In expr '$for(" ++ show e ++ ")$'" + typeMsg = "loop expr '" ++ show e ++ "'" + bodyMsg = "In loop context of '$for(" ++ show e ++ ")$'" + + applyElem (Partial e) = withErrorMessage headMsg $ + applyStringExpr typeMsg e >>= \p -> + withErrorMessage inclMsg $ do + tpl' <- loadBody (fromFilePath p) + itemBody <$> applyTemplate tpl' context x + where + headMsg = "In expr '$partial(" ++ show e ++ ")$'" + typeMsg = "partial expr '" ++ show e ++ "'" + inclMsg = "In inclusion of '$partial(" ++ show e ++ ")$'" --------------------------------------------------------------------------- @@ -149,17 +195,29 @@ applyTemplate' tes context x = go tes applyExpr (Ident (TemplateKey k)) = context' k [] x applyExpr (Call (TemplateKey k) args) = do - args' <- mapM (\e -> applyExpr e >>= getString e) args + args' <- mapM (\e -> applyStringExpr (typeMsg e) e) args context' k args' x + where + typeMsg e = "argument '" ++ show e ++ "'" applyExpr (StringLiteral s) = return (StringField s) ---------------------------------------------------------------------------- - getString _ (StringField s) = return s - getString e (ListField _ _) = fail $ - "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++ - "got ListField for expr " ++ show e + applyStringExpr :: String -> TemplateExpr -> Compiler String + applyStringExpr msg expr = + applyExpr expr >>= getString + where + getString EmptyField = expected "string" "boolean" msg + getString (StringField s) = return s + getString (ListField _ _) = expected "string" "list" msg + + expected typ act expr = fail $ unwords ["Hakyll.Web.Template.applyTemplate:", + "expected", typ, "but got", act, "for", expr] + + -- expected to never happen with all templates constructed by 'template' + trimError = fail $ + "Hakyll.Web.Template.applyTemplate: template not fully trimmed." -------------------------------------------------------------------------------- @@ -189,14 +247,14 @@ loadAndApplyTemplate identifier context item = do applyAsTemplate :: Context String -- ^ Context -> Item String -- ^ Item and template -> Compiler (Item String) -- ^ Resulting item -applyAsTemplate context item = - let tpl = template $ readTemplateElemsFile file (itemBody item) - file = toFilePath $ itemIdentifier item - in applyTemplate tpl context item +applyAsTemplate context item = do + tpl <- compileTemplateItem item + applyTemplate tpl context item -------------------------------------------------------------------------------- unsafeReadTemplateFile :: FilePath -> Compiler Template unsafeReadTemplateFile file = do tpl <- unsafeCompiler $ readFile file - pure $ template $ readTemplateElemsFile file tpl + compileTemplateFile (fromFilePath file) tpl +{-# DEPRECATED unsafeReadTemplateFile "Use templateCompiler" #-} |