summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Hakyll/Web/Template.hs46
-rw-r--r--src/Hakyll/Web/Template/Internal.hs113
-rw-r--r--src/Hakyll/Web/Template/Trim.hs145
-rw-r--r--tests/Hakyll/Web/Template/Tests.hs87
4 files changed, 139 insertions, 252 deletions
diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs
index 65c4ac9..204878c 100644
--- a/src/Hakyll/Web/Template.hs
+++ b/src/Hakyll/Web/Template.hs
@@ -115,7 +115,8 @@
-- That is, calling @$partial$@ is equivalent to just copying and pasting
-- template code.
--
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Hakyll.Web.Template
( Template
, templateBodyCompiler
@@ -128,9 +129,11 @@ module Hakyll.Web.Template
--------------------------------------------------------------------------------
-import Control.Monad (liftM)
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)
@@ -138,8 +141,33 @@ 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
+
+
+--------------------------------------------------------------------------------
+readTemplate :: String -> Template
+readTemplate = Template . trim . readTemplateElems
--------------------------------------------------------------------------------
@@ -163,23 +191,23 @@ applyTemplate :: Template -- ^ Template
-> Item a -- ^ Page
-> Compiler (Item String) -- ^ Resulting item
applyTemplate tpl context item = do
- body <- applyTemplate' tpl context item
+ body <- applyTemplate' (unTemplate tpl) context item
return $ itemSetBody body item
--------------------------------------------------------------------------------
applyTemplate'
:: forall a.
- Template -- ^ Template
- -> Context a -- ^ Context
- -> Item a -- ^ Page
- -> Compiler String -- ^ Resulting item
-applyTemplate' tpl context x = go tpl
+ [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 = liftM concat . mapM applyElem . unTemplate
+ go = fmap concat . mapM applyElem
---------------------------------------------------------------------------
diff --git a/src/Hakyll/Web/Template/Internal.hs b/src/Hakyll/Web/Template/Internal.hs
index 5905c93..6a9947f 100644
--- a/src/Hakyll/Web/Template/Internal.hs
+++ b/src/Hakyll/Web/Template/Internal.hs
@@ -1,13 +1,12 @@
--------------------------------------------------------------------------------
-- | Module containing the template data structure
-{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Hakyll.Web.Template.Internal
- ( Template (..)
- , TemplateKey (..)
+ ( TemplateKey (..)
, TemplateExpr (..)
, TemplateElement (..)
- , readTemplate
+ , templateElems
+ , readTemplateElems
) where
@@ -25,31 +24,6 @@ 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 Monoid Template where
- mempty = Template []
- (Template xs) `mappend` (Template ys) = Template (xs `mappend` ys)
-
-
---------------------------------------------------------------------------------
-instance Writable Template where
- -- Writing a template is impossible
- write _ _ = return ()
-
-
---------------------------------------------------------------------------------
-instance IsString Template where
- fromString = readTemplate
--------------------------------------------------------------------------------
@@ -68,9 +42,12 @@ 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
+ -- 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)
@@ -130,36 +107,22 @@ instance Binary TemplateExpr where
--------------------------------------------------------------------------------
-(.~) :: [TemplateElement] -> Template -> Template
-ts .~ (Template t) = Template (ts ++ t)
-
-infixr 6 .~
-
-
---------------------------------------------------------------------------------
-(~.) :: Template -> [TemplateElement] -> Template
-(Template t) ~. ts = Template (t ++ ts)
-
-infixl 5 ~.
-
-
---------------------------------------------------------------------------------
-readTemplate :: String -> Template
-readTemplate input = case P.parse template "" input of
+readTemplateElems :: String -> [TemplateElement]
+readTemplateElems input = case P.parse templateElems "" input of
Left err -> error $ "Cannot parse template: " ++ show err
Right t -> t
--------------------------------------------------------------------------------
-template :: P.Parser Template
-template = mconcat <$> P.many (P.choice [ lift chunk
+templateElems :: P.Parser [TemplateElement]
+templateElems = mconcat <$> P.many (P.choice [ lift chunk
, lift escaped
, conditional
, for
, partial
, expr
])
- where lift = fmap (Template . (:[]))
+ where lift = fmap (:[])
--------------------------------------------------------------------------------
@@ -168,12 +131,12 @@ chunk = Chunk <$> P.many1 (P.noneOf "$")
--------------------------------------------------------------------------------
-expr :: P.Parser Template
+expr :: P.Parser [TemplateElement]
expr = P.try $ do
trimLExpr <- trimOpen
e <- expr'
trimRExpr <- trimClose
- return $ [TrimL | trimLExpr] .~ Template [Expr e] ~. [TrimR | trimRExpr]
+ return $ [TrimL | trimLExpr] ++ [Expr e] ++ [TrimR | trimRExpr]
--------------------------------------------------------------------------------
@@ -203,7 +166,7 @@ trimClose = do
--------------------------------------------------------------------------------
-conditional :: P.Parser Template
+conditional :: P.Parser [TemplateElement]
conditional = P.try $ do
-- if
trimLIf <- trimOpen
@@ -212,7 +175,7 @@ conditional = P.try $ do
void $ P.char ')'
trimRIf <- trimClose
-- then
- thenBranch <- template
+ thenBranch <- templateElems
-- else
elseParse <- opt "else"
-- endif
@@ -223,24 +186,22 @@ conditional = P.try $ do
-- 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]
+ [TrimR | trimRIf] ++ thenBranch ++ [TrimL | trimLEnd]
thenElse (trimLElse, elseBranch, trimRElse) = (thenB, elseB)
where thenB = [TrimR | trimRIf]
- .~ thenBranch
- ~. [TrimL | trimLElse]
+ ++ thenBranch
+ ++ [TrimL | trimLElse]
elseB = Just $ [TrimR | trimRElse]
- .~ elseBranch
- ~. [TrimL | trimLEnd]
+ ++ elseBranch
+ ++ [TrimL | trimLEnd]
- pure $ [TrimL | trimLIf]
- .~ Template [If e thenBody elseBody]
- ~. [TrimR | trimREnd]
+ pure $ [TrimL | trimLIf] ++ [If e thenBody elseBody] ++ [TrimR | trimREnd]
--------------------------------------------------------------------------------
-for :: P.Parser Template
+for :: P.Parser [TemplateElement]
for = P.try $ do
-- for
trimLFor <- trimOpen
@@ -249,7 +210,7 @@ for = P.try $ do
void $ P.char ')'
trimRFor <- trimClose
-- body
- bodyBranch <- template
+ bodyBranch <- templateElems
-- sep
sepParse <- opt "sep"
-- endfor
@@ -260,24 +221,22 @@ for = P.try $ do
-- 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]
+ [TrimR | trimRFor] ++ bodyBranch ++ [TrimL | trimLEnd]
forSep (trimLSep, sepBranch, trimRSep) = (forB, sepB)
where forB = [TrimR | trimRFor]
- .~ bodyBranch
- ~. [TrimL | trimLSep]
+ ++ bodyBranch
+ ++ [TrimL | trimLSep]
sepB = Just $ [TrimR | trimRSep]
- .~ sepBranch
- ~. [TrimL | trimLEnd]
+ ++ sepBranch
+ ++ [TrimL | trimLEnd]
- pure $ [TrimL | trimLFor]
- .~ Template [For e forBody sepBody]
- ~. [TrimR | trimREnd]
+ pure $ [TrimL | trimLFor] ++ [For e forBody sepBody] ++ [TrimR | trimREnd]
--------------------------------------------------------------------------------
-partial :: P.Parser Template
+partial :: P.Parser [TemplateElement]
partial = P.try $ do
trimLPart <- trimOpen
void $ P.string "partial("
@@ -285,7 +244,7 @@ partial = P.try $ do
void $ P.char ')'
trimRPart <- trimClose
- pure $ [TrimL | trimLPart] .~ Template [Partial e] ~. [TrimR | trimRPart]
+ pure $ [TrimL | trimLPart] ++ [Partial e] ++ [TrimR | trimRPart]
--------------------------------------------------------------------------------
@@ -322,11 +281,11 @@ key = TemplateKey <$> metadataKey
--------------------------------------------------------------------------------
-opt :: String -> P.Parser (Maybe (Bool, Template, Bool))
+opt :: String -> P.Parser (Maybe (Bool, [TemplateElement], Bool))
opt clause = P.optionMaybe $ P.try $ do
trimL <- trimOpen
void $ P.string clause
trimR <- trimClose
- branch <- template
+ branch <- templateElems
pure (trimL, branch, trimR)
diff --git a/src/Hakyll/Web/Template/Trim.hs b/src/Hakyll/Web/Template/Trim.hs
index 6b7c6c8..4ea3438 100644
--- a/src/Hakyll/Web/Template/Trim.hs
+++ b/src/Hakyll/Web/Template/Trim.hs
@@ -1,6 +1,6 @@
--------------------------------------------------------------------------------
--- | TODO
-module Hakyll.Web.Template.Internal.Trim
+-- | Module for trimming whitespace.
+module Hakyll.Web.Template.Trim
( trim
) where
@@ -15,13 +15,13 @@ import Hakyll.Web.Template.Internal
--------------------------------------------------------------------------------
-trim :: Template -> Template
+trim :: [TemplateElement] -> [TemplateElement]
trim = cleanse . canonicalize
--------------------------------------------------------------------------------
-cleanse :: Template -> Template
-cleanse = tmap (recurse cleanse . process)
+cleanse :: [TemplateElement] -> [TemplateElement]
+cleanse = recurse cleanse . process
where process [] = []
process (TrimR:Chunk str:ts) = Chunk (lstrip str):process ts
process (Chunk str:TrimL:ts) = Chunk (rstrip str):process ts
@@ -31,83 +31,43 @@ cleanse = tmap (recurse cleanse . process)
rstrip = dropWhileEnd isSpace
--------------------------------------------------------------------------------
+-- | Enforce the invariant that:
--
--- Invariant: Every TrimL should have a Chunk to its Left
--- Every TrimR should have a Chunk to its Right
+-- * Every 'TrimL' has a 'Chunk' to its left.
+-- * Every 'TrimR' has a 'Chunk' to its right.
--
---
--- Some initial implementation notes. Note: Not valid syntax etc.
---
---
---
---
---------------------------------------------------------------------------------
-canonicalize :: Template -> Template
+canonicalize :: [TemplateElement] -> [TemplateElement]
canonicalize = go
- where go t = let t' = redundant . swap . dedupe $ sink t
+ where go t = let t' = redundant . swap $ dedupe t
in if t == t' then t else go t'
--------------------------------------------------------------------------------
--- | 'redundant' removes the redundant 'TrimR's and 'TrimL's from the
--- 'Template's list of 'TemplateExpr's. It does _not_ recurse down the AST.
---
--- Note: Should _only_ be used on the top level 'Template'.
---
-redundant :: Template -> Template
-redundant = tmap (recurse redundant . process)
+-- | 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 t ts = t:ts
+ trailing x xs = x:xs
--------------------------------------------------------------------------------
--- Commute:
---
--- List:
---
--- [t1, TrimR, TrimL, t2] = [t1, TrimL, TrimR, t2]
---
--- Rest should come for free provided Trim's are Sunk/Shifted etc I think.
---
-swap :: Template -> Template
-swap = tmap (recurse swap . process)
+-- >>> 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
--------------------------------------------------------------------------------
---
--- Dedupe:
---
--- List:
---
--- [t1, TrimR, TrimR, t2] = [t1, TrimR, t2]
---
--- [t1, TrimL, TrimL, t2] = [t1, TrimL, t2]
---
--- If: Should come for free after Trim_'s have been sunk.
---
--- [t1, TrimR, If ex [TrimR, t] e, t2] = [t1, If ex [TrimR, t] e, t2]
---
--- [t1, If ex t [e, TrimL], TrimL, t2] = [t1, If ex t [e, TrimL], t2]
---
--- [t1, If ex [t, TrimL] Nothing, TrimL, t2] = [t1, If ex [t, TrimL] Nothing, t2]
---
--- For:
---
--- [t1, TrimR, For e [TrimR, b] sep, t2] = [t1, For e [TrimR, b] sep, t2]
---
--- [t1, For e b [sep, TrimL], TrimL, t2] = [t1, For e b [sep, TrimL], t2]
---
--- [t1, For e [b, TrimL] Nothing, TrimL, t2] = [t1, For e [b, TrimL] Nothing, t2]
---
-dedupe :: Template -> Template
-dedupe = tmap (recurse dedupe . process)
+-- | 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)
@@ -115,64 +75,13 @@ dedupe = tmap (recurse dedupe . process)
--------------------------------------------------------------------------------
---
--- Sink:
---
--- If:
---
--- [t1, TrimR, If ex t e, t2] = [t1, If ex [TrimR, t] e, t2]
---
--- [t1, If ex t e, TrimL, t2] = if isJust e
--- then [t1, If ex t [e, TrimL], t2]
--- else [t1, If ex [t, TrimL] e, t2]
---
--- For:
---
--- [t1, TrimR, For e b sep, t2] = [t1, For e [TrimR, b] sep, t2]
---
--- [t1, For e b sep, TrimL, t2] = if isJust sep
--- then [t1, For e b [sep, TrimL], t2]
--- else [t1, For e [b, TrimL] sep, t2]
---
---
-sink :: Template -> Template
-sink = tmap (recurse sink . process)
- where process [] = []
- -- Right sink TrimR into If thenbody.
- process (TrimR:If e (Template tb) eb:ts)
- = If e (Template (TrimR:tb)) eb:process ts
- -- Left sink TrimL into If thenbody.
- process (If e (Template tb) Nothing:TrimL:ts)
- = If e (Template (tb ++ [TrimL])) Nothing:process ts
- -- Left sink TrimL into If elsebody.
- process (If e tb (Just (Template eb)):TrimL:ts)
- = If e tb (Just (Template (eb ++ [TrimL]))):process ts
- -- Right sink TrimR into For body.
- process (TrimR:For e (Template b) sep:ts)
- = For e (Template (TrimR:b)) sep:process ts
- -- Left sink TrimL into For body.
- process (For e (Template b) Nothing:TrimL:ts)
- = For e (Template (b ++ [TrimL])) Nothing:process ts
- -- Left sink TrimL into For sep.
- process (For e b (Just (Template sep)):TrimL:ts)
- = For e b (Just (Template (sep ++ [TrimL]))):process ts
- -- Otherwise move on.
- process (t:ts) = t:process ts
-
-
---------------------------------------------------------------------------------
-tmap :: ([TemplateElement] -> [TemplateElement]) -> Template -> Template
-tmap f (Template t) = Template (f t)
-
-
---------------------------------------------------------------------------------
-recurse :: (Template -> Template) -> [TemplateElement] -> [TemplateElement]
-recurse f [] = []
+recurse :: ([TemplateElement] -> [TemplateElement])
+ -> [TemplateElement]
+ -> [TemplateElement]
+recurse _ [] = []
recurse f (x:xs) = process x:recurse f xs
- where process x = case x of
+ 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)
- _ -> x
+ _ -> y
-
---------------------------------------------------------------------------------
diff --git a/tests/Hakyll/Web/Template/Tests.hs b/tests/Hakyll/Web/Template/Tests.hs
index 087e0cb..54d5406 100644
--- a/tests/Hakyll/Web/Template/Tests.hs
+++ b/tests/Hakyll/Web/Template/Tests.hs
@@ -31,57 +31,48 @@ tests = testGroup "Hakyll.Core.Template.Tests" $ concat
]
, fromAssertions "readTemplate"
- [ Template [Chunk "Hello ", Expr (Call "guest" [])]
- @=? readTemplate "Hello $guest()$"
- , Template
- [If (Call "a" [StringLiteral "bar"])
- (Template [Chunk "foo"])
- Nothing]
- @=? readTemplate "$if(a(\"bar\"))$foo$endif$"
+ [ [Chunk "Hello ", Expr (Call "guest" [])]
+ @=? readTemplateElems "Hello $guest()$"
+ , [If (Call "a" [StringLiteral "bar"]) [Chunk "foo"] Nothing]
+ @=? readTemplateElems "$if(a(\"bar\"))$foo$endif$"
-- 'If' trim check.
- , Template
- [ TrimL
- , If (Ident (TemplateKey "body"))
- (Template [ TrimR
- , Chunk "\n"
- , Expr (Ident (TemplateKey "body"))
- , Chunk "\n"
- , TrimL
- ])
- (Just (Template [ TrimR
- , Chunk "\n"
- , Expr (Ident (TemplateKey "body"))
- , Chunk "\n"
- , TrimL
- ]))
- , TrimR
- ]
- @=? readTemplate "$-if(body)-$\n$body$\n$-else-$\n$body$\n$-endif-$"
+ , [ TrimL
+ , If (Ident (TemplateKey "body"))
+ [ TrimR
+ , Chunk "\n"
+ , Expr (Ident (TemplateKey "body"))
+ , Chunk "\n"
+ , TrimL
+ ]
+ (Just [ TrimR
+ , Chunk "\n"
+ , Expr (Ident (TemplateKey "body"))
+ , Chunk "\n"
+ , TrimL
+ ])
+ , TrimR
+ ]
+ @=? readTemplateElems "$-if(body)-$\n$body$\n$-else-$\n$body$\n$-endif-$"
-- 'For' trim check.
- , Template
- [ TrimL
- , For (Ident (TemplateKey "authors"))
- (Template [ TrimR
- , Chunk "\n body \n"
- , TrimL])
- Nothing
- , TrimR
- ]
- @=? readTemplate "$-for(authors)-$\n body \n$-endfor-$"
+ , [ TrimL
+ , For (Ident (TemplateKey "authors"))
+ [TrimR, Chunk "\n body \n", TrimL]
+ Nothing
+ , TrimR
+ ]
+ @=? readTemplateElems "$-for(authors)-$\n body \n$-endfor-$"
-- 'Partial' trim check.
- , Template
- [ TrimL
- , Partial (StringLiteral "path")
- , TrimR
- ]
- @=? readTemplate "$-partial(\"path\")-$"
+ , [ TrimL
+ , Partial (StringLiteral "path")
+ , TrimR
+ ]
+ @=? readTemplateElems "$-partial(\"path\")-$"
-- 'Expr' trim check.
- , Template
- [ TrimL
- , Expr (Ident (TemplateKey "foo"))
- , TrimR
- ]
- @=? readTemplate "$-foo-$"
+ , [ TrimL
+ , Expr (Ident (TemplateKey "foo"))
+ , TrimR
+ ]
+ @=? readTemplateElems "$-foo-$"
]
]
@@ -126,4 +117,4 @@ testApplyJoinTemplateList = do
where
i1 = Item "item1" "Hello"
i2 = Item "item2" "World"
- tpl = Template [Chunk "<b>", Expr (Ident "body"), Chunk "</b>"]
+ tpl = readTemplate "<b>$body$</b>"