Reorganise template module hierarchy

2 files changed, 393 insertions, 0 deletions

diff --git a/src/Hakyll/Web/Template/Internal/Element.hs b/src/Hakyll/Web/Template/Internal/Element.hs
new file mode 100644
index 0000000..f564355
--- /dev/null
+++ b/src/Hakyll/Web/Template/Internal/Element.hs
@@ -0,0 +1,298 @@
+--------------------------------------------------------------------------------
+-- | 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
+    , 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
+
+
+--------------------------------------------------------------------------------
+-- | 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"
+
+
+--------------------------------------------------------------------------------
+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
+    -- 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)
+
diff --git a/src/Hakyll/Web/Template/Internal/Trim.hs b/src/Hakyll/Web/Template/Internal/Trim.hs
new file mode 100644
index 0000000..e416ff2
--- /dev/null
+++ b/src/Hakyll/Web/Template/Internal/Trim.hs
@@ -0,0 +1,95 @@
+--------------------------------------------------------------------------------
+-- | Module for trimming whitespace from tempaltes.
+module Hakyll.Web.Template.Internal.Trim
+    ( trim
+    ) where
+
+
+--------------------------------------------------------------------------------
+import           Data.Char                            (isSpace)
+import           Data.List                            (dropWhileEnd)
+
+
+--------------------------------------------------------------------------------
+import           Hakyll.Web.Template.Internal.Element
+
+
+--------------------------------------------------------------------------------
+trim :: [TemplateElement] -> [TemplateElement]
+trim = cleanse . canonicalize
+
+
+--------------------------------------------------------------------------------
+-- | Apply the Trim nodes to the Chunks.
+cleanse :: [TemplateElement] -> [TemplateElement]
+cleanse = recurse cleanse . process
+    where process [] = []
+          process (TrimR:Chunk str:ts) = let str' = dropWhile isSpace str
+                                         in if null str'
+                                                then process ts
+                                                -- Might need to TrimL.
+                                                else process $ Chunk str':ts
+
+          process (Chunk str:TrimL:ts) = let str' = dropWhileEnd isSpace str
+                                         in if null str'
+                                                then process ts
+                                                else Chunk str':process ts
+
+          process (t:ts) = t:process ts
+
+--------------------------------------------------------------------------------
+-- | Enforce the invariant that:
+--
+--     * Every 'TrimL' has a 'Chunk' to its left.
+--     * Every 'TrimR' has a 'Chunk' to its right.
+--
+canonicalize :: [TemplateElement] -> [TemplateElement]
+canonicalize = go
+    where go t = let t' = redundant . swap $ dedupe t
+                 in if t == t' then t else go t'
+
+
+--------------------------------------------------------------------------------
+-- | Remove the 'TrimR' and 'TrimL's that are no-ops.
+redundant :: [TemplateElement] -> [TemplateElement]
+redundant = recurse redundant . process
+    where -- Remove the leading 'TrimL's.
+          process (TrimL:ts) = process ts
+          -- Remove trailing 'TrimR's.
+          process ts = foldr trailing [] ts
+              where trailing TrimR [] = []
+                    trailing x xs     = x:xs
+
+
+--------------------------------------------------------------------------------
+-- >>> swap $ [TrimR, TrimL]
+-- [TrimL, TrimR]
+swap :: [TemplateElement] -> [TemplateElement]
+swap = recurse swap . process
+    where process []               = []
+          process (TrimR:TrimL:ts) = TrimL:process (TrimR:ts)
+          process (t:ts)           = t:process ts
+
+
+--------------------------------------------------------------------------------
+-- | Remove 'TrimR' and 'TrimL' duplication.
+dedupe :: [TemplateElement] -> [TemplateElement]
+dedupe = recurse dedupe . process
+    where process []               = []
+          process (TrimR:TrimR:ts) = process (TrimR:ts)
+          process (TrimL:TrimL:ts) = process (TrimL:ts)
+          process (t:ts)           = t:process ts
+
+
+--------------------------------------------------------------------------------
+-- | @'recurse' f t@ applies f to every '[TemplateElement]' in t.
+recurse :: ([TemplateElement] -> [TemplateElement])
+        -> [TemplateElement]
+        -> [TemplateElement]
+recurse _ []     = []
+recurse f (x:xs) = process x:recurse f xs
+    where process y = case y of
+                          If e tb eb -> If e (f tb) (f <$> eb)
+                          For e t s  -> For e (f t) (f <$> s)
+                          _          -> y
+