Internal.hs

--------------------------------------------------------------------------------
-- | Module containing the template data structure
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Hakyll.Web.Template.Internal
    ( Template (..)
    , TemplateKey (..)
    , TemplateExpr (..)
    , TemplateElement (..)
    , readTemplate
    ) where


--------------------------------------------------------------------------------
import           Control.Applicative     (pure, (<$), (<$>), (<*>), (<|>))
import           Control.Monad           (void)
import           Data.Binary             (Binary, get, getWord8, put, putWord8)
import           Data.Typeable           (Typeable)
import           Data.List (intercalate)
import           GHC.Exts                (IsString (..))
import qualified Text.Parsec             as P
import qualified Text.Parsec.String      as P


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


--------------------------------------------------------------------------------
-- | Datatype used for template substitutions.
newtype Template = Template
    { unTemplate :: [TemplateElement]
    } deriving (Show, Eq, Binary, Typeable)


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


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


--------------------------------------------------------------------------------
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
    | If TemplateExpr Template (Maybe Template)   -- expr, then, else
    | For TemplateExpr Template (Maybe Template)  -- expr, body, separator
    | Partial TemplateExpr                        -- filename
    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

    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
        _ -> 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.Tamplte.Internal: Error reading cached template"


--------------------------------------------------------------------------------
readTemplate :: String -> Template
readTemplate input = case P.parse template "" input of
    Left err -> error $ "Cannot parse template: " ++ show err
    Right t  -> t


--------------------------------------------------------------------------------
template :: P.Parser Template
template = Template <$>
    (P.many $ chunk <|> escaped <|> conditional <|> for <|> partial <|> expr)


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


--------------------------------------------------------------------------------
expr :: P.Parser TemplateElement
expr = P.try $ do
    void $ P.char '$'
    e <- expr'
    void $ P.char '$'
    return $ Expr e


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


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


--------------------------------------------------------------------------------
conditional :: P.Parser TemplateElement
conditional = P.try $ do
    void $ P.string "$if("
    e <- expr'
    void $ P.string ")$"
    thenBranch <- template
    elseBranch <- P.optionMaybe $ P.try (P.string "$else$") >> template
    void $ P.string "$endif$"
    return $ If e thenBranch elseBranch


--------------------------------------------------------------------------------
for :: P.Parser TemplateElement
for = P.try $ do
    void $ P.string "$for("
    e <- expr'
    void $ P.string ")$"
    body <- template
    sep  <- P.optionMaybe $ P.try (P.string "$sep$") >> template
    void $ P.string "$endfor$"
    return $ For e body sep


--------------------------------------------------------------------------------
partial :: P.Parser TemplateElement
partial = P.try $ do
    void $ P.string "$partial("
    e <- expr'
    void $ P.string ")$"
    return $ Partial e


--------------------------------------------------------------------------------
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