From ca7b78ee428a43bb307ecefb65529d5106751192 Mon Sep 17 00:00:00 2001 From: samgd Date: Sun, 24 Jul 2016 15:10:12 +0200 Subject: Working trimming but module loop and formatting req. --- src/Hakyll/Web/Template/Trim.hs | 178 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 178 insertions(+) create mode 100644 src/Hakyll/Web/Template/Trim.hs (limited to 'src/Hakyll/Web/Template/Trim.hs') diff --git a/src/Hakyll/Web/Template/Trim.hs b/src/Hakyll/Web/Template/Trim.hs new file mode 100644 index 0000000..6b7c6c8 --- /dev/null +++ b/src/Hakyll/Web/Template/Trim.hs @@ -0,0 +1,178 @@ +-------------------------------------------------------------------------------- +-- | TODO +module Hakyll.Web.Template.Internal.Trim + ( trim + ) where + + +-------------------------------------------------------------------------------- +import Data.Char (isSpace) +import Data.List (dropWhileEnd) + + +-------------------------------------------------------------------------------- +import Hakyll.Web.Template.Internal + + +-------------------------------------------------------------------------------- +trim :: Template -> Template +trim = cleanse . canonicalize + + +-------------------------------------------------------------------------------- +cleanse :: Template -> Template +cleanse = tmap (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 + process (t:ts) = t:process ts + + lstrip = dropWhile isSpace + rstrip = dropWhileEnd isSpace + +-------------------------------------------------------------------------------- +-- +-- Invariant: Every TrimL should have a Chunk to its Left +-- Every TrimR should have a Chunk to its Right +-- +-- +-- Some initial implementation notes. Note: Not valid syntax etc. +-- +-- +-- +-- +-------------------------------------------------------------------------------- +canonicalize :: Template -> Template +canonicalize = go + where go t = let t' = redundant . swap . dedupe $ sink 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) + 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 + + +-------------------------------------------------------------------------------- +-- 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) + 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) + where process [] = [] + process (TrimR:TrimR:ts) = process (TrimR:ts) + process (TrimL:TrimL:ts) = process (TrimL:ts) + process (t:ts) = t:process ts + + +-------------------------------------------------------------------------------- +-- +-- 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 f (x:xs) = process x:recurse f xs + where process x = case x of + If e tb eb -> If e (f tb) (f <$> eb) + For e t s -> For e (f t) (f <$> s) + _ -> x + + +-------------------------------------------------------------------------------- -- cgit v1.2.3 From 43c969f326082d29d8e340ee865414deb87b8ac5 Mon Sep 17 00:00:00 2001 From: samgd Date: Sun, 24 Jul 2016 17:30:47 +0200 Subject: Fix module layout --- src/Hakyll/Web/Template.hs | 46 +++++++++--- src/Hakyll/Web/Template/Internal.hs | 113 +++++++++------------------- src/Hakyll/Web/Template/Trim.hs | 145 +++++++----------------------------- tests/Hakyll/Web/Template/Tests.hs | 87 ++++++++++------------ 4 files changed, 139 insertions(+), 252 deletions(-) (limited to 'src/Hakyll/Web/Template/Trim.hs') 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 "", Expr (Ident "body"), Chunk ""] + tpl = readTemplate "$body$" -- cgit v1.2.3 From 82d6402ba38b9e1ea789e83c5ea7d08bcbeff467 Mon Sep 17 00:00:00 2001 From: samgd Date: Mon, 25 Jul 2016 12:47:30 +0200 Subject: Trim instructions. TrimRd chunk might need TrimL. Trim tests. --- src/Hakyll/Web/Template.hs | 30 ++++++++++++++++++++++++++++++ src/Hakyll/Web/Template/Trim.hs | 20 ++++++++++++++------ tests/Hakyll/Web/Template/Tests.hs | 14 ++++++++------ tests/data/strip.html | 34 ++++++++++++++++++++++++++++++++++ tests/data/strip.html.out | 18 ++++++++++++++++++ 5 files changed, 104 insertions(+), 12 deletions(-) create mode 100644 tests/data/strip.html create mode 100644 tests/data/strip.html.out (limited to 'src/Hakyll/Web/Template/Trim.hs') diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index 204878c..13d5d35 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -115,6 +115,29 @@ -- That is, calling @$partial$@ is equivalent to just copying and pasting -- template code. -- +-- In the examples above you can see that outputs contain a lot of leftover +-- whitespace that you may wish to remove. Using @'$-'@ or @'-$'@ instead of +-- @'$'@ in a macro strips all whitespace to the left or right of that clause +-- respectively. Given the context +-- +-- > listField "counts" (field "count" (return . itemBody)) +-- > (sequence [makeItem "3", makeItem "2", makeItem "1"]) +-- +-- and a template +-- +-- >

+-- > $for(counts)-$ +-- > $count$ +-- > $-sep-$... +-- > $-endfor$ +-- >

+-- +-- the resulting page would look like +-- +-- >

+-- > 3...2...1 +-- >

+-- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} module Hakyll.Web.Template @@ -209,10 +232,17 @@ applyTemplate' tes context x = go tes 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 diff --git a/src/Hakyll/Web/Template/Trim.hs b/src/Hakyll/Web/Template/Trim.hs index 4ea3438..bc7e691 100644 --- a/src/Hakyll/Web/Template/Trim.hs +++ b/src/Hakyll/Web/Template/Trim.hs @@ -1,5 +1,5 @@ -------------------------------------------------------------------------------- --- | Module for trimming whitespace. +-- | Module for trimming whitespace module Hakyll.Web.Template.Trim ( trim ) where @@ -20,15 +20,22 @@ trim = cleanse . canonicalize -------------------------------------------------------------------------------- +-- | Apply the Trim nodes to the Chunks. 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 - process (t:ts) = t:process ts + 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 - lstrip = dropWhile isSpace - rstrip = dropWhileEnd isSpace + process (t:ts) = t:process ts -------------------------------------------------------------------------------- -- | Enforce the invariant that: @@ -75,6 +82,7 @@ dedupe = recurse dedupe . process -------------------------------------------------------------------------------- +-- | @'recurse' f t@ applies f to every '[TemplateElement]' in t. recurse :: ([TemplateElement] -> [TemplateElement]) -> [TemplateElement] -> [TemplateElement] diff --git a/tests/Hakyll/Web/Template/Tests.hs b/tests/Hakyll/Web/Template/Tests.hs index 54d5406..994d9ca 100644 --- a/tests/Hakyll/Web/Template/Tests.hs +++ b/tests/Hakyll/Web/Template/Tests.hs @@ -13,6 +13,7 @@ import Test.HUnit (Assertion, (@=?), (@?=)) -------------------------------------------------------------------------------- import Hakyll.Core.Compiler +import Hakyll.Core.Identifier import Hakyll.Core.Item import Hakyll.Core.Provider import Hakyll.Web.Pandoc @@ -26,7 +27,8 @@ import TestSuite.Util -------------------------------------------------------------------------------- tests :: Test tests = testGroup "Hakyll.Core.Template.Tests" $ concat - [ [ testCase "case01" case01 + [ [ testCase "case01" $ test ("template.html.out", "template.html", "example.md") + , testCase "case02" $ test ("strip.html.out", "strip.html", "example.md") , testCase "applyJoinTemplateList" testApplyJoinTemplateList ] @@ -78,14 +80,14 @@ tests = testGroup "Hakyll.Core.Template.Tests" $ concat -------------------------------------------------------------------------------- -case01 :: Assertion -case01 = do +test :: (Identifier, Identifier, Identifier) -> Assertion +test (outf, tplf, itemf) = do store <- newTestStore provider <- newTestProvider store - out <- resourceString provider "template.html.out" - tpl <- testCompilerDone store provider "template.html" templateBodyCompiler - item <- testCompilerDone store provider "example.md" $ + out <- resourceString provider outf + tpl <- testCompilerDone store provider tplf templateBodyCompiler + item <- testCompilerDone store provider itemf $ pandocCompiler >>= applyTemplate (itemBody tpl) testContext out @=? itemBody item diff --git a/tests/data/strip.html b/tests/data/strip.html new file mode 100644 index 0000000..d28571e --- /dev/null +++ b/tests/data/strip.html @@ -0,0 +1,34 @@ +
+ I'm so rich I have $$3. + + $rev("foo")$ + $-rev(rev("foo"))$ + + $if(body)-$ + I have body + $else-$ + or no + $-endif-$ + + $if(unbound)$ + should not be printed + $endif$ + + $-if(body)-$ + should be printed + $-endif$ + +
    + $for(authors)-$ +
  • $name$
    • + $endfor-$ +
+ + $for(authors)-$ + $name-$ + $sep$, + $-endfor$ + + $body$ +
+ diff --git a/tests/data/strip.html.out b/tests/data/strip.html.out new file mode 100644 index 0000000..9b37e69 --- /dev/null +++ b/tests/data/strip.html.out @@ -0,0 +1,18 @@ +
+ I'm so rich I have $3. + + ooffoo + + I have body + should be printed + +
    +
  • Jan
    • +
  • Piet
    • +
+ + Jan,Piet + +

This is an example.

+
+ -- cgit v1.2.3