path: root/lib/Hakyll/Web/Template/Internal/Element.hs

--------------------------------------------------------------------------------
-- | Module containing the elements used in a template.  A template is generally
-- just a list of these elements.
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Hakyll.Web.Template.Internal.Element
    ( TemplateKey (..)
    , TemplateExpr (..)
    , TemplateElement (..)
    , templateElems
    , parseTemplateElemsFile
    ) where


--------------------------------------------------------------------------------
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)
import           Data.Typeable           (Typeable)
import           GHC.Exts                (IsString (..))
import qualified Text.Parsec             as P
import qualified Text.Parsec.String      as P


--------------------------------------------------------------------------------
import           Hakyll.Core.Util.Parser


--------------------------------------------------------------------------------
newtype TemplateKey = TemplateKey String
    deriving (Binary, Show, Eq, Typeable)


--------------------------------------------------------------------------------
instance IsString TemplateKey where
    fromString = TemplateKey


--------------------------------------------------------------------------------
-- | Elements of a template.
data TemplateElement
    = Chunk String
    | Expr TemplateExpr
    | Escaped
      -- expr, then, else
    | If TemplateExpr [TemplateElement] (Maybe [TemplateElement])
      -- expr, body, separator
    | For TemplateExpr [TemplateElement] (Maybe [TemplateElement])
      -- filename
    | Partial TemplateExpr
    | TrimL
    | TrimR
    deriving (Show, Eq, Typeable)


--------------------------------------------------------------------------------
instance Binary TemplateElement where
    put (Chunk string) = putWord8 0 >> put string
    put (Expr e)       = putWord8 1 >> put e
    put  Escaped       = putWord8 2
    put (If e t f)     = putWord8 3 >> put e >> put t >> put f
    put (For e b s)    = putWord8 4 >> put e >> put b >> put s
    put (Partial e)    = putWord8 5 >> put e
    put  TrimL         = putWord8 6
    put  TrimR         = putWord8 7

    get = getWord8 >>= \tag -> case tag of
        0 -> Chunk <$> get
        1 -> Expr <$> get
        2 -> pure Escaped
        3 -> If <$> get <*> get <*> get
        4 -> For <$> get <*> get <*> get
        5 -> Partial <$> get
        6 -> pure TrimL
        7 -> pure TrimR
        _ -> error "Hakyll.Web.Template.Internal: Error reading cached template"


--------------------------------------------------------------------------------
-- | Expression in a template
data TemplateExpr
    = Ident TemplateKey
    | Call TemplateKey [TemplateExpr]
    | StringLiteral String
    deriving (Eq, Typeable)


--------------------------------------------------------------------------------
instance Show TemplateExpr where
    show (Ident (TemplateKey k))   = k
    show (Call (TemplateKey k) as) =
        k ++ "(" ++ intercalate ", " (map show as) ++ ")"
    show (StringLiteral s)         = show s


--------------------------------------------------------------------------------
instance Binary TemplateExpr where
    put (Ident k)         = putWord8 0 >> put k
    put (Call k as)       = putWord8 1 >> put k >> put as
    put (StringLiteral s) = putWord8 2 >> put s

    get = getWord8 >>= \tag -> case tag of
        0 -> Ident         <$> get
        1 -> Call          <$> get <*> get
        2 -> StringLiteral <$> get
        _ -> error "Hakyll.Web.Template.Internal: Error reading cached template"

--------------------------------------------------------------------------------
parseTemplateElemsFile :: FilePath -> String -> Either String [TemplateElement]
parseTemplateElemsFile file = left (\e -> "Cannot parse template " ++ show e)
                            . P.parse (templateElems <* P.eof) file


--------------------------------------------------------------------------------
templateElems :: P.Parser [TemplateElement]
templateElems = mconcat <$> P.many (P.choice [ lift chunk
                                             , lift escaped
                                             , conditional
                                             , for
                                             , partial
                                             , expr
                                             ])
    where lift = fmap (:[])


--------------------------------------------------------------------------------
chunk :: P.Parser TemplateElement
chunk = Chunk <$> P.many1 (P.noneOf "$")


--------------------------------------------------------------------------------
expr :: P.Parser [TemplateElement]
expr = P.try $ do
    trimLExpr <- trimOpen
    e <- expr'
    trimRExpr <- trimClose
    return $ [TrimL | trimLExpr] ++ [Expr e] ++ [TrimR | trimRExpr]


--------------------------------------------------------------------------------
expr' :: P.Parser TemplateExpr
expr' = stringLiteral <|> call <|> ident


--------------------------------------------------------------------------------
escaped :: P.Parser TemplateElement
escaped = Escaped <$ P.try (P.string "$$")


--------------------------------------------------------------------------------
trimOpen :: P.Parser Bool
trimOpen = do
    void $ P.char '$'
    trimLIf <- P.optionMaybe $ P.try (P.char '-')
    pure $ isJust trimLIf


--------------------------------------------------------------------------------
trimClose :: P.Parser Bool
trimClose = do
    trimIfR <- P.optionMaybe $ (P.char '-')
    void $ P.char '$'
    pure $ isJust trimIfR


--------------------------------------------------------------------------------
conditional :: P.Parser [TemplateElement]
conditional = P.try $ do
    -- if
    trimLIf <- trimOpen
    void $ P.string "if("
    e <- expr'
    void $ P.char ')'
    trimRIf <- trimClose
    -- then
    thenBranch <- templateElems
    -- else
    elseParse <- opt "else"
    -- endif
    trimLEnd <- trimOpen
    void $ P.string "endif"
    trimREnd <- trimClose

    -- As else is optional we need to sort out where any Trim_s need to go.
    let (thenBody, elseBody) = maybe (thenNoElse, Nothing) thenElse elseParse
            where thenNoElse =
                      [TrimR | trimRIf] ++ thenBranch ++ [TrimL | trimLEnd]

                  thenElse (trimLElse, elseBranch, trimRElse) = (thenB, elseB)
                      where thenB = [TrimR | trimRIf]
                                 ++ thenBranch
                                 ++ [TrimL | trimLElse]

                            elseB = Just $ [TrimR | trimRElse]
                                        ++ elseBranch
                                        ++ [TrimL | trimLEnd]

    pure $ [TrimL | trimLIf] ++ [If e thenBody elseBody] ++ [TrimR | trimREnd]


--------------------------------------------------------------------------------
for :: P.Parser [TemplateElement]
for = P.try $ do
    -- for
    trimLFor <- trimOpen
    void $ P.string "for("
    e <- expr'
    void $ P.char ')'
    trimRFor <- trimClose
    -- body
    bodyBranch <- templateElems
    -- sep
    sepParse <- opt "sep"
    -- endfor
    trimLEnd <- trimOpen
    void $ P.string "endfor"
    trimREnd <- trimClose

    -- As sep is optional we need to sort out where any Trim_s need to go.
    let (forBody, sepBody) = maybe (forNoSep, Nothing) forSep sepParse
            where forNoSep =
                      [TrimR | trimRFor] ++ bodyBranch ++ [TrimL | trimLEnd]

                  forSep (trimLSep, sepBranch, trimRSep) = (forB, sepB)
                      where forB = [TrimR | trimRFor]
                                ++ bodyBranch
                                ++ [TrimL | trimLSep]

                            sepB = Just $ [TrimR | trimRSep]
                                       ++ sepBranch
                                       ++ [TrimL | trimLEnd]

    pure $ [TrimL | trimLFor] ++ [For e forBody sepBody] ++ [TrimR | trimREnd]


--------------------------------------------------------------------------------
partial :: P.Parser [TemplateElement]
partial = P.try $ do
    trimLPart <- trimOpen
    void $ P.string "partial("
    e <- expr'
    void $ P.char ')'
    trimRPart <- trimClose

    pure $ [TrimL | trimLPart] ++ [Partial e] ++ [TrimR | trimRPart]


--------------------------------------------------------------------------------
ident :: P.Parser TemplateExpr
ident = P.try $ Ident <$> key


--------------------------------------------------------------------------------
call :: P.Parser TemplateExpr
call = P.try $ do
    f <- key
    void $ P.char '('
    P.spaces
    as <- P.sepBy expr' (P.spaces >> P.char ',' >> P.spaces)
    P.spaces
    void $ P.char ')'
    return $ Call f as


--------------------------------------------------------------------------------
stringLiteral :: P.Parser TemplateExpr
stringLiteral = do
    void $ P.char '\"'
    str <- P.many $ do
        x <- P.noneOf "\""
        if x == '\\' then P.anyChar else return x
    void $ P.char '\"'
    return $ StringLiteral str


--------------------------------------------------------------------------------
key :: P.Parser TemplateKey
key = TemplateKey <$> metadataKey


--------------------------------------------------------------------------------
opt :: String -> P.Parser (Maybe (Bool, [TemplateElement], Bool))
opt clause = P.optionMaybe $ P.try $ do
    trimL <- trimOpen
    void $ P.string clause
    trimR <- trimClose
    branch <- templateElems
    pure (trimL, branch, trimR)