+-- > $for(counts)-$ +-- > $count$ +-- > $-sep$... +-- > $-endfor$ +-- >
+-- +-- the resulting page would look like +-- +-- >+-- > 3...2...1 +-- >
+-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} module Hakyll.Web.Template ( Template , templateBodyCompiler @@ -124,13 +148,16 @@ module Hakyll.Web.Template , loadAndApplyTemplate , applyAsTemplate , readTemplate + , unsafeReadTemplateFile ) where -------------------------------------------------------------------------------- -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,17 +165,47 @@ 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 (readTemplateFile file) item + return $ fmap (template . readTemplateElemsFile file) item -------------------------------------------------------------------------------- -- | Read complete file contents as a template @@ -156,7 +213,7 @@ templateCompiler :: Compiler (Item Template) templateCompiler = cached "Hakyll.Web.Template.templateCompiler" $ do item <- getResourceString file <- getResourceFilePath - return $ fmap (readTemplateFile file) item + return $ fmap (template . readTemplateElemsFile file) item -------------------------------------------------------------------------------- @@ -165,28 +222,35 @@ 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 + + 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 @@ -261,6 +325,14 @@ applyAsTemplate :: Context String -- ^ Context -> Item String -- ^ Item and template -> Compiler (Item String) -- ^ Resulting item applyAsTemplate context item = - let tpl = readTemplateFile file (itemBody 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 a63c40d..15266a0 100644 --- a/src/Hakyll/Web/Template/Internal.hs +++ b/src/Hakyll/Web/Template/Internal.hs @@ -1,14 +1,13 @@ -------------------------------------------------------------------------------- -- | Module containing the template data structure -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Web.Template.Internal - ( Template (..) - , TemplateKey (..) + ( TemplateKey (..) , TemplateExpr (..) , TemplateElement (..) - , readTemplate - , readTemplateFile + , templateElems + , readTemplateElems + , readTemplateElemsFile ) where @@ -16,8 +15,9 @@ module Hakyll.Web.Template.Internal 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 Data.List (intercalate) import GHC.Exts (IsString (..)) import qualified Text.Parsec as P import qualified Text.Parsec.String as P @@ -25,25 +25,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 Writable Template where - -- Writing a template is impossible - write _ _ = return () - - --------------------------------------------------------------------------------- -instance IsString Template where - fromString = readTemplate -------------------------------------------------------------------------------- @@ -62,9 +43,14 @@ 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) @@ -72,10 +58,12 @@ data TemplateElement 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 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 @@ -84,8 +72,9 @@ instance Binary TemplateElement where 3 -> If <$> get <*> get <*> get 4 -> For <$> get <*> get <*> get 5 -> Partial <$> get - _ -> error $ - "Hakyll.Web.Template.Internal: Error reading cached template" + 6 -> pure TrimL + 7 -> pure TrimR + _ -> error "Hakyll.Web.Template.Internal: Error reading cached template" -------------------------------------------------------------------------------- @@ -115,48 +104,45 @@ instance Binary TemplateExpr where 0 -> Ident <$> get 1 -> Call <$> get <*> get 2 -> StringLiteral <$> get - _ -> error $ - "Hakyll.Web.Tamplte.Internal: Error reading cached template" + _ -> error "Hakyll.Web.Template.Internal: Error reading cached template" -------------------------------------------------------------------------------- -readTemplate :: String -> Template -readTemplate = readTemplateFile "{literal}" +readTemplateElems :: String -> [TemplateElement] +readTemplateElems = readTemplateElemsFile "{literal}" -------------------------------------------------------------------------------- -readTemplateFile :: FilePath -> String -> Template -readTemplateFile file input = case P.parse topLevelTemplate file input of +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 -------------------------------------------------------------------------------- -topLevelTemplate :: P.Parser Template -topLevelTemplate = Template <$> - P.manyTill templateElement P.eof - --------------------------------------------------------------------------------- -template :: P.Parser Template -template = Template <$> P.many templateElement - --------------------------------------------------------------------------------- -templateElement :: P.Parser TemplateElement -templateElement = chunk <|> escaped <|> conditional <|> for <|> partial <|> expr +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 "$") +chunk = Chunk <$> P.many1 (P.noneOf "$") -------------------------------------------------------------------------------- -expr :: P.Parser TemplateElement +expr :: P.Parser [TemplateElement] expr = P.try $ do - void $ P.char '$' + trimLExpr <- trimOpen e <- expr' - void $ P.char '$' - return $ Expr e + trimRExpr <- trimClose + return $ [TrimL | trimLExpr] ++ [Expr e] ++ [TrimR | trimRExpr] -------------------------------------------------------------------------------- @@ -166,40 +152,105 @@ expr' = stringLiteral <|> call <|> ident -------------------------------------------------------------------------------- escaped :: P.Parser TemplateElement -escaped = Escaped <$ (P.try $ P.string "$$") +escaped = Escaped <$ P.try (P.string "$$") -------------------------------------------------------------------------------- -conditional :: P.Parser TemplateElement +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 - void $ P.string "$if(" + -- if + trimLIf <- trimOpen + void $ P.string "if(" e <- expr' - void $ P.string ")$" - thenBranch <- template - elseBranch <- P.optionMaybe $ P.try (P.string "$else$") >> template - void $ P.string "$endif$" - return $ If e thenBranch elseBranch + 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.Parser [TemplateElement] for = P.try $ do - void $ P.string "$for(" + -- for + trimLFor <- trimOpen + void $ P.string "for(" e <- expr' - void $ P.string ")$" - body <- template - sep <- P.optionMaybe $ P.try (P.string "$sep$") >> template - void $ P.string "$endfor$" - return $ For e body sep + 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.Parser [TemplateElement] partial = P.try $ do - void $ P.string "$partial(" + trimLPart <- trimOpen + void $ P.string "partial(" e <- expr' - void $ P.string ")$" - return $ Partial e + void $ P.char ')' + trimRPart <- trimClose + + pure $ [TrimL | trimLPart] ++ [Partial e] ++ [TrimR | trimRPart] -------------------------------------------------------------------------------- @@ -233,3 +284,14 @@ stringLiteral = do -------------------------------------------------------------------------------- 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/Trim.hs new file mode 100644 index 0000000..bc7e691 --- /dev/null +++ b/src/Hakyll/Web/Template/Trim.hs @@ -0,0 +1,95 @@ +-------------------------------------------------------------------------------- +-- | Module for trimming whitespace +module Hakyll.Web.Template.Trim + ( trim + ) where + + +-------------------------------------------------------------------------------- +import Data.Char (isSpace) +import Data.List (dropWhileEnd) + + +-------------------------------------------------------------------------------- +import Hakyll.Web.Template.Internal + + +-------------------------------------------------------------------------------- +trim :: [TemplateElement] -> [TemplateElement] +trim = cleanse . canonicalize + + +-------------------------------------------------------------------------------- +-- | Apply the Trim nodes to the Chunks. +cleanse :: [TemplateElement] -> [TemplateElement] +cleanse = recurse cleanse . process + where process [] = [] + process (TrimR:Chunk str:ts) = let str' = dropWhile isSpace str + in if null str' + then process ts + -- Might need to TrimL. + else process $ Chunk str':ts + + process (Chunk str:TrimL:ts) = let str' = dropWhileEnd isSpace str + in if null str' + then process ts + else Chunk str':process ts + + process (t:ts) = t:process ts + +-------------------------------------------------------------------------------- +-- | Enforce the invariant that: +-- +-- * Every 'TrimL' has a 'Chunk' to its left. +-- * Every 'TrimR' has a 'Chunk' to its right. +-- +canonicalize :: [TemplateElement] -> [TemplateElement] +canonicalize = go + where go t = let t' = redundant . swap $ dedupe t + in if t == t' then t else go t' + + +-------------------------------------------------------------------------------- +-- | Remove the 'TrimR' and 'TrimL's that are no-ops. +redundant :: [TemplateElement] -> [TemplateElement] +redundant = recurse redundant . process + where -- Remove the leading 'TrimL's. + process (TrimL:ts) = process ts + -- Remove trailing 'TrimR's. + process ts = foldr trailing [] ts + where trailing TrimR [] = [] + trailing x xs = x:xs + + +-------------------------------------------------------------------------------- +-- >>> swap $ [TrimR, TrimL] +-- [TrimL, TrimR] +swap :: [TemplateElement] -> [TemplateElement] +swap = recurse swap . process + where process [] = [] + process (TrimR:TrimL:ts) = TrimL:process (TrimR:ts) + process (t:ts) = t:process ts + + +-------------------------------------------------------------------------------- +-- | Remove 'TrimR' and 'TrimL' duplication. +dedupe :: [TemplateElement] -> [TemplateElement] +dedupe = recurse dedupe . process + where process [] = [] + process (TrimR:TrimR:ts) = process (TrimR:ts) + process (TrimL:TrimL:ts) = process (TrimL:ts) + process (t:ts) = t:process ts + + +-------------------------------------------------------------------------------- +-- | @'recurse' f t@ applies f to every '[TemplateElement]' in t. +recurse :: ([TemplateElement] -> [TemplateElement]) + -> [TemplateElement] + -> [TemplateElement] +recurse _ [] = [] +recurse f (x:xs) = process x:recurse f xs + where process y = case y of + If e tb eb -> If e (f tb) (f <$> eb) + For e t s -> For e (f t) (f <$> s) + _ -> y + diff --git a/tests/Hakyll/Web/Template/Tests.hs b/tests/Hakyll/Web/Template/Tests.hs index a975901..994d9ca 100644 --- a/tests/Hakyll/Web/Template/Tests.hs +++ b/tests/Hakyll/Web/Template/Tests.hs @@ -6,7 +6,6 @@ module Hakyll.Web.Template.Tests -------------------------------------------------------------------------------- -import Data.Monoid (mconcat) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, (@=?), (@?=)) @@ -14,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 @@ -27,32 +27,67 @@ 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 ] , 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. + , [ 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. + , [ TrimL + , For (Ident (TemplateKey "authors")) + [TrimR, Chunk "\n body \n", TrimL] + Nothing + , TrimR + ] + @=? readTemplateElems "$-for(authors)-$\n body \n$-endfor-$" + -- 'Partial' trim check. + , [ TrimL + , Partial (StringLiteral "path") + , TrimR + ] + @=? readTemplateElems "$-partial(\"path\")-$" + -- 'Expr' trim check. + , [ TrimL + , Expr (Ident (TemplateKey "foo")) + , TrimR + ] + @=? readTemplateElems "$-foo-$" ] ] -------------------------------------------------------------------------------- -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 @@ -69,7 +104,6 @@ testContext = mconcat return [n1, n2] , functionField "rev" $ \args _ -> return $ unwords $ map reverse args ] - where -------------------------------------------------------------------------------- @@ -85,4 +119,4 @@ testApplyJoinTemplateList = do where i1 = Item "item1" "Hello" i2 = Item "item2" "World" - tpl = Template [Chunk "", Expr (Ident "body"), Chunk ""] + tpl = readTemplate "$body$" 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 @@ +This is an example.
+