summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Hakyll/Web/Template.hs184
-rw-r--r--src/Hakyll/Web/Template/Internal.hs374
-rw-r--r--src/Hakyll/Web/Template/Internal/Element.hs298
-rw-r--r--src/Hakyll/Web/Template/Internal/Trim.hs (renamed from src/Hakyll/Web/Template/Trim.hs)20
4 files changed, 448 insertions, 428 deletions
diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs
index 8118fff..2a9684b 100644
--- a/src/Hakyll/Web/Template.hs
+++ b/src/Hakyll/Web/Template.hs
@@ -138,8 +138,6 @@
-- > 3...2...1
-- > </p>
--
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ScopedTypeVariables #-}
module Hakyll.Web.Template
( Template
, templateBodyCompiler
@@ -153,186 +151,4 @@ module Hakyll.Web.Template
--------------------------------------------------------------------------------
-import Control.Monad.Except (MonadError (..))
-import Data.Binary (Binary)
-import Data.List (intercalate)
-import Data.Typeable (Typeable)
-import GHC.Exts (IsString (..))
-import Prelude hiding (id)
-
-
---------------------------------------------------------------------------------
-import Hakyll.Core.Compiler
-import Hakyll.Core.Identifier
-import Hakyll.Core.Item
-import Hakyll.Core.Writable
-import Hakyll.Web.Template.Context
import Hakyll.Web.Template.Internal
-import Hakyll.Web.Template.Trim
-
-
---------------------------------------------------------------------------------
--- | 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
-
-
---------------------------------------------------------------------------------
--- | Wrap the constructor to ensure trim is called.
-template :: [TemplateElement] -> Template
-template = Template . trim
-
-
---------------------------------------------------------------------------------
-readTemplate :: String -> Template
-readTemplate = Template . trim . readTemplateElems
-
---------------------------------------------------------------------------------
--- | Read a template, without metadata header
-templateBodyCompiler :: Compiler (Item Template)
-templateBodyCompiler = cached "Hakyll.Web.Template.templateBodyCompiler" $ do
- item <- getResourceBody
- file <- getResourceFilePath
- return $ fmap (template . readTemplateElemsFile file) item
-
---------------------------------------------------------------------------------
--- | Read complete file contents as a template
-templateCompiler :: Compiler (Item Template)
-templateCompiler = cached "Hakyll.Web.Template.templateCompiler" $ do
- item <- getResourceString
- file <- getResourceFilePath
- return $ fmap (template . readTemplateElemsFile file) item
-
-
---------------------------------------------------------------------------------
-applyTemplate :: Template -- ^ Template
- -> Context a -- ^ Context
- -> Item a -- ^ Page
- -> Compiler (Item String) -- ^ Resulting item
-applyTemplate tpl context item = do
- body <- applyTemplate' (unTemplate tpl) context item
- return $ itemSetBody body item
-
-
---------------------------------------------------------------------------------
-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
-
- trimError = error $ "Hakyll.Web.Template.applyTemplate: template not " ++
- "fully trimmed."
-
- ---------------------------------------------------------------------------
-
- applyElem :: TemplateElement -> Compiler String
-
- applyElem TrimL = trimError
-
- applyElem TrimR = trimError
-
- applyElem (Chunk c) = return c
-
- applyElem (Expr e) = applyExpr e >>= getString e
-
- applyElem Escaped = return "$"
-
- applyElem (If e t mf) = (applyExpr e >> go t) `catchError` handler
- where
- handler _ = case mf of
- Nothing -> return ""
- Just f -> go f
-
- applyElem (For e b s) = applyExpr e >>= \cf -> case cf of
- StringField _ -> fail $
- "Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++
- "got StringField for expr " ++ show e
- ListField c xs -> do
- sep <- maybe (return "") go s
- bs <- mapM (applyTemplate' b c) xs
- return $ intercalate sep bs
-
- applyElem (Partial e) = do
- p <- applyExpr e >>= getString e
- tpl' <- loadBody (fromFilePath p)
- applyTemplate' tpl' context x
-
- ---------------------------------------------------------------------------
-
- applyExpr :: TemplateExpr -> Compiler ContextField
-
- applyExpr (Ident (TemplateKey k)) = context' k [] x
-
- applyExpr (Call (TemplateKey k) args) = do
- args' <- mapM (\e -> applyExpr e >>= getString e) args
- context' k args' x
-
- applyExpr (StringLiteral s) = return (StringField s)
-
- ----------------------------------------------------------------------------
-
- getString _ (StringField s) = return s
- getString e (ListField _ _) = fail $
- "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++
- "got ListField for expr " ++ show e
-
-
---------------------------------------------------------------------------------
--- | 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 =
- let tpl = template $ readTemplateElemsFile file (itemBody item)
- file = toFilePath $ itemIdentifier item
- in applyTemplate tpl context item
-
-
---------------------------------------------------------------------------------
-unsafeReadTemplateFile :: FilePath -> Compiler Template
-unsafeReadTemplateFile file = do
- tpl <- unsafeCompiler $ readFile file
- pure $ template $ readTemplateElemsFile file tpl
-
diff --git a/src/Hakyll/Web/Template/Internal.hs b/src/Hakyll/Web/Template/Internal.hs
index 15266a0..3686914 100644
--- a/src/Hakyll/Web/Template/Internal.hs
+++ b/src/Hakyll/Web/Template/Internal.hs
@@ -1,297 +1,203 @@
---------------------------------------------------------------------------------
--- | Module containing the template data structure
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Hakyll.Web.Template.Internal
- ( TemplateKey (..)
- , TemplateExpr (..)
- , TemplateElement (..)
- , templateElems
- , readTemplateElems
- , readTemplateElemsFile
+ ( Template (..)
+ , template
+ , templateBodyCompiler
+ , templateCompiler
+ , applyTemplate
+ , applyTemplate'
+ , loadAndApplyTemplate
+ , applyAsTemplate
+ , readTemplate
+ , unsafeReadTemplateFile
+
+ , module Hakyll.Web.Template.Internal.Element
+ , module Hakyll.Web.Template.Internal.Trim
) 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
+import Control.Monad.Except (MonadError (..))
+import Data.Binary (Binary)
+import Data.List (intercalate)
+import Data.Typeable (Typeable)
+import GHC.Exts (IsString (..))
+import Prelude hiding (id)
--------------------------------------------------------------------------------
-newtype TemplateKey = TemplateKey String
- deriving (Binary, Show, Eq, Typeable)
+import Hakyll.Core.Compiler
+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
--------------------------------------------------------------------------------
-instance IsString TemplateKey where
- fromString = TemplateKey
+-- | Datatype used for template substitutions.
+newtype Template = Template
+ { unTemplate :: [TemplateElement]
+ } deriving (Show, Eq, Binary, Typeable)
--------------------------------------------------------------------------------
--- | 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 Writable Template where
+ -- Writing a template is impossible
+ write _ _ = return ()
--------------------------------------------------------------------------------
-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"
+instance IsString Template where
+ fromString = readTemplate
--------------------------------------------------------------------------------
--- | 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"
+-- | Wrap the constructor to ensure trim is called.
+template :: [TemplateElement] -> Template
+template = Template . trim
--------------------------------------------------------------------------------
-readTemplateElems :: String -> [TemplateElement]
-readTemplateElems = readTemplateElemsFile "{literal}"
-
+readTemplate :: String -> Template
+readTemplate = Template . trim . readTemplateElems
--------------------------------------------------------------------------------
-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
-
+-- | Read a template, without metadata header
+templateBodyCompiler :: Compiler (Item Template)
+templateBodyCompiler = cached "Hakyll.Web.Template.templateBodyCompiler" $ do
+ item <- getResourceBody
+ file <- getResourceFilePath
+ return $ fmap (template . readTemplateElemsFile file) item
--------------------------------------------------------------------------------
-templateElems :: P.Parser [TemplateElement]
-templateElems = mconcat <$> P.many (P.choice [ lift chunk
- , lift escaped
- , conditional
- , for
- , partial
- , expr
- ])
- where lift = fmap (:[])
+-- | Read complete file contents as a template
+templateCompiler :: Compiler (Item Template)
+templateCompiler = cached "Hakyll.Web.Template.templateCompiler" $ do
+ item <- getResourceString
+ file <- getResourceFilePath
+ return $ fmap (template . readTemplateElemsFile file) item
--------------------------------------------------------------------------------
-chunk :: P.Parser TemplateElement
-chunk = Chunk <$> P.many1 (P.noneOf "$")
+applyTemplate :: Template -- ^ Template
+ -> Context a -- ^ Context
+ -> Item a -- ^ Page
+ -> Compiler (Item String) -- ^ Resulting item
+applyTemplate tpl context item = do
+ body <- applyTemplate' (unTemplate tpl) context item
+ return $ itemSetBody body item
--------------------------------------------------------------------------------
-expr :: P.Parser [TemplateElement]
-expr = P.try $ do
- trimLExpr <- trimOpen
- e <- expr'
- trimRExpr <- trimClose
- return $ [TrimL | trimLExpr] ++ [Expr e] ++ [TrimR | trimRExpr]
+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
---------------------------------------------------------------------------------
-expr' :: P.Parser TemplateExpr
-expr' = stringLiteral <|> call <|> ident
+ trimError = error $ "Hakyll.Web.Template.applyTemplate: template not " ++
+ "fully trimmed."
+ ---------------------------------------------------------------------------
---------------------------------------------------------------------------------
-escaped :: P.Parser TemplateElement
-escaped = Escaped <$ P.try (P.string "$$")
+ applyElem :: TemplateElement -> Compiler String
+ applyElem TrimL = trimError
---------------------------------------------------------------------------------
-trimOpen :: P.Parser Bool
-trimOpen = do
- void $ P.char '$'
- trimLIf <- P.optionMaybe $ P.try (P.char '-')
- pure $ isJust trimLIf
+ applyElem TrimR = trimError
+ applyElem (Chunk c) = return c
---------------------------------------------------------------------------------
-trimClose :: P.Parser Bool
-trimClose = do
- trimIfR <- P.optionMaybe $ P.try (P.char '-')
- void $ P.char '$'
- pure $ isJust trimIfR
+ applyElem (Expr e) = applyExpr e >>= getString e
+ applyElem Escaped = return "$"
---------------------------------------------------------------------------------
-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]
+ applyElem (If e t mf) = (applyExpr e >> go t) `catchError` handler
+ where
+ handler _ = case mf of
+ Nothing -> return ""
+ Just f -> go f
+ applyElem (For e b s) = applyExpr e >>= \cf -> case cf of
+ StringField _ -> fail $
+ "Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++
+ "got StringField for expr " ++ show e
+ ListField c xs -> do
+ sep <- maybe (return "") go s
+ bs <- mapM (applyTemplate' b c) xs
+ return $ intercalate sep bs
---------------------------------------------------------------------------------
-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]
+ applyElem (Partial e) = do
+ p <- applyExpr e >>= getString e
+ tpl' <- loadBody (fromFilePath p)
+ applyTemplate' tpl' context x
+ ---------------------------------------------------------------------------
---------------------------------------------------------------------------------
-partial :: P.Parser [TemplateElement]
-partial = P.try $ do
- trimLPart <- trimOpen
- void $ P.string "partial("
- e <- expr'
- void $ P.char ')'
- trimRPart <- trimClose
+ applyExpr :: TemplateExpr -> Compiler ContextField
- pure $ [TrimL | trimLPart] ++ [Partial e] ++ [TrimR | trimRPart]
+ applyExpr (Ident (TemplateKey k)) = context' k [] x
+ applyExpr (Call (TemplateKey k) args) = do
+ args' <- mapM (\e -> applyExpr e >>= getString e) args
+ context' k args' x
---------------------------------------------------------------------------------
-ident :: P.Parser TemplateExpr
-ident = P.try $ Ident <$> key
+ applyExpr (StringLiteral s) = return (StringField s)
+ ----------------------------------------------------------------------------
---------------------------------------------------------------------------------
-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
+ getString _ (StringField s) = return s
+ getString e (ListField _ _) = fail $
+ "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++
+ "got ListField for expr " ++ show e
--------------------------------------------------------------------------------
-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
+-- | 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
--------------------------------------------------------------------------------
-key :: P.Parser TemplateKey
-key = TemplateKey <$> metadataKey
+-- | 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 =
+ let tpl = template $ readTemplateElemsFile file (itemBody item)
+ file = toFilePath $ itemIdentifier item
+ in applyTemplate tpl context item
--------------------------------------------------------------------------------
-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)
+unsafeReadTemplateFile :: FilePath -> Compiler Template
+unsafeReadTemplateFile file = do
+ tpl <- unsafeCompiler $ readFile file
+ pure $ template $ readTemplateElemsFile file tpl
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/Trim.hs b/src/Hakyll/Web/Template/Internal/Trim.hs
index bc7e691..e416ff2 100644
--- a/src/Hakyll/Web/Template/Trim.hs
+++ b/src/Hakyll/Web/Template/Internal/Trim.hs
@@ -1,17 +1,17 @@
--------------------------------------------------------------------------------
--- | Module for trimming whitespace
-module Hakyll.Web.Template.Trim
+-- | Module for trimming whitespace from tempaltes.
+module Hakyll.Web.Template.Internal.Trim
( trim
) where
--------------------------------------------------------------------------------
-import Data.Char (isSpace)
-import Data.List (dropWhileEnd)
+import Data.Char (isSpace)
+import Data.List (dropWhileEnd)
--------------------------------------------------------------------------------
-import Hakyll.Web.Template.Internal
+import Hakyll.Web.Template.Internal.Element
--------------------------------------------------------------------------------
@@ -58,7 +58,7 @@ redundant = recurse redundant . process
-- Remove trailing 'TrimR's.
process ts = foldr trailing [] ts
where trailing TrimR [] = []
- trailing x xs = x:xs
+ trailing x xs = x:xs
--------------------------------------------------------------------------------
@@ -66,19 +66,19 @@ redundant = recurse redundant . process
-- [TrimL, TrimR]
swap :: [TemplateElement] -> [TemplateElement]
swap = recurse swap . process
- where process [] = []
+ where process [] = []
process (TrimR:TrimL:ts) = TrimL:process (TrimR:ts)
- process (t:ts) = t:process ts
+ process (t:ts) = t:process ts
--------------------------------------------------------------------------------
-- | Remove 'TrimR' and 'TrimL' duplication.
dedupe :: [TemplateElement] -> [TemplateElement]
dedupe = recurse dedupe . process
- where process [] = []
+ where process [] = []
process (TrimR:TrimR:ts) = process (TrimR:ts)
process (TrimL:TrimL:ts) = process (TrimL:ts)
- process (t:ts) = t:process ts
+ process (t:ts) = t:process ts
--------------------------------------------------------------------------------