{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Hakyll.Web.Template.Internal.Element
( TemplateKey (..)
, TemplateExpr (..)
, TemplateElement (..)
, templateElems
, readTemplateElems
, readTemplateElemsFile
) where
import Control.Applicative ((<|>))
import Control.Monad (void)
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
data TemplateElement
= Chunk String
| Expr TemplateExpr
| Escaped
| If TemplateExpr [TemplateElement] (Maybe [TemplateElement])
| For TemplateExpr [TemplateElement] (Maybe [TemplateElement])
| 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"
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"
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
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.try (P.char '-')
void $ P.char '$'
pure $ isJust trimIfR
conditional :: P.Parser [TemplateElement]
conditional = P.try $ do
trimLIf <- trimOpen
void $ P.string "if("
e <- expr'
void $ P.char ')'
trimRIf <- trimClose
thenBranch <- templateElems
elseParse <- opt "else"
trimLEnd <- trimOpen
void $ P.string "endif"
trimREnd <- trimClose
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
trimLFor <- trimOpen
void $ P.string "for("
e <- expr'
void $ P.char ')'
trimRFor <- trimClose
bodyBranch <- templateElems
sepParse <- opt "sep"
trimLEnd <- trimOpen
void $ P.string "endfor"
trimREnd <- trimClose
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)