Internal.hs

{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables        #-}

module Hakyll.Web.Template.Internal
    ( Template (..)
    , template
    , templateBodyCompiler
    , templateCompiler
    , applyTemplate
    , loadAndApplyTemplate
    , applyAsTemplate
    , readTemplate
    , compileTemplateItem
    , unsafeReadTemplateFile

    , module Hakyll.Web.Template.Internal.Element
    , module Hakyll.Web.Template.Internal.Trim
    ) where


--------------------------------------------------------------------------------
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           GHC.Generics                         (Generic)


--------------------------------------------------------------------------------
import           Hakyll.Core.Compiler
import           Hakyll.Core.Compiler.Internal
import           Hakyll.Core.Identifier
import           Hakyll.Core.Item
import           Hakyll.Core.Writable
import           Hakyll.Web.Template.Context
import           Hakyll.Web.Template.Internal.Element
import           Hakyll.Web.Template.Internal.Trim


--------------------------------------------------------------------------------
-- | Datatype used for template substitutions.
data Template = Template
    { tplElements :: [TemplateElement]
    , tplOrigin   :: FilePath  -- Only for error messages.
    } deriving (Show, Eq, Generic, Binary, Typeable)


--------------------------------------------------------------------------------
instance Writable Template where
    -- Writing a template is impossible
    write _ _ = return ()


--------------------------------------------------------------------------------
instance IsString Template where
    fromString = readTemplate


--------------------------------------------------------------------------------
-- | Wrap the constructor to ensure trim is called.
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 = 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 <- 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 <- 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' (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.
       [TemplateElement] -- ^ Unwrapped Template
    -> Context a         -- ^ Context
    -> Item a            -- ^ Page
    -> Compiler String   -- ^ Resulting item
applyTemplate' tes context x = go tes
  where
    context' :: String -> [String] -> Item a -> Compiler ContextField
    context' = unContext (context `mappend` missingField)

    go = fmap concat . mapM applyElem

    ---------------------------------------------------------------------------

    applyElem :: TemplateElement -> Compiler String

    applyElem TrimL = trimError

    applyElem TrimR = trimError

    applyElem (Chunk c) = return c

    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) = compilerTry (applyExpr e) >>= handle
      where
        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
      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 ++ ")$'"

    ---------------------------------------------------------------------------

    applyExpr :: TemplateExpr -> Compiler ContextField

    applyExpr (Ident (TemplateKey k)) = context' k [] x

    applyExpr (Call (TemplateKey k) args) = do
        args' <- mapM (\e -> applyStringExpr (typeMsg e) e) args
        context' k args' x
      where
        typeMsg e = "argument '" ++ show e ++ "'"

    applyExpr (StringLiteral s) = return (StringField s)

    ----------------------------------------------------------------------------

    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:
--
-- > tpl <- loadBody "templates/foo.html"
-- > someCompiler
-- >     >>= applyTemplate tpl context
--
-- That we have a single function which does this:
--
-- > someCompiler
-- >     >>= loadAndApplyTemplate "templates/foo.html" context
loadAndApplyTemplate :: Identifier              -- ^ Template identifier
                     -> Context a               -- ^ Context
                     -> Item a                  -- ^ Page
                     -> Compiler (Item String)  -- ^ Resulting item
loadAndApplyTemplate identifier context item = do
    tpl <- loadBody identifier
    applyTemplate tpl context item


--------------------------------------------------------------------------------
-- | It is also possible that you want to substitute @$key$@s within the body of
-- an item. This function does that by interpreting the item body as a template,
-- and then applying it to itself.
applyAsTemplate :: Context String          -- ^ Context
                -> Item String             -- ^ Item and template
                -> Compiler (Item String)  -- ^ Resulting item
applyAsTemplate context item = do
    tpl <- compileTemplateItem item
    applyTemplate tpl context item


--------------------------------------------------------------------------------
unsafeReadTemplateFile :: FilePath -> Compiler Template
unsafeReadTemplateFile file = do
    tpl <- unsafeCompiler $ readFile file
    compileTemplateFile (fromFilePath file) tpl
{-# DEPRECATED unsafeReadTemplateFile "Use templateCompiler" #-}