diff options
| -rw-r--r-- | src/Hakyll/Web/Template.hs | 46 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template/Internal.hs | 113 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template/Trim.hs | 145 | ||||
| -rw-r--r-- | tests/Hakyll/Web/Template/Tests.hs | 87 |
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>" |