+-- > $for(counts)-$ +-- > $count$ +-- > $-sep$... +-- > $-endfor$ +-- >
+-- +-- the resulting page would look like +-- +-- >+-- > 3...2...1 +-- >
+-- module Hakyll.Web.Template ( Template , templateBodyCompiler @@ -124,140 +146,9 @@ , loadAndApplyTemplate , applyAsTemplate , readTemplate + , unsafeReadTemplateFile ) where -------------------------------------------------------------------------------- -import Control.Monad (liftM) -import Control.Monad.Except (MonadError (..)) -import Data.List (intercalate) -import Prelude hiding (id) - - --------------------------------------------------------------------------------- -import Hakyll.Core.Compiler -import Hakyll.Core.Identifier -import Hakyll.Core.Item -import Hakyll.Web.Template.Context import Hakyll.Web.Template.Internal - - --------------------------------------------------------------------------------- --- | Read a template, without metadata header -templateBodyCompiler :: Compiler (Item Template) -templateBodyCompiler = cached "Hakyll.Web.Template.templateBodyCompiler" $ do - item <- getResourceBody - return $ fmap readTemplate item - --------------------------------------------------------------------------------- --- | Read complete file contents as a template -templateCompiler :: Compiler (Item Template) -templateCompiler = cached "Hakyll.Web.Template.templateCompiler" $ do - item <- getResourceString - return $ fmap readTemplate item - - --------------------------------------------------------------------------------- -applyTemplate :: Template -- ^ Template - -> Context a -- ^ Context - -> Item a -- ^ Page - -> Compiler (Item String) -- ^ Resulting item -applyTemplate tpl context item = do - body <- applyTemplate' 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 - where - context' :: String -> [String] -> Item a -> Compiler ContextField - context' = unContext (context `mappend` missingField) - - go = liftM concat . mapM applyElem . unTemplate - - --------------------------------------------------------------------------- - - applyElem :: TemplateElement -> Compiler String - - applyElem (Chunk c) = return c - - applyElem (Expr e) = applyExpr e >>= getString e - - applyElem Escaped = return "$" - - applyElem (If e t mf) = (applyExpr e >> go t) `catchError` handler - where - handler _ = case mf of - Nothing -> return "" - Just f -> go f - - applyElem (For e b s) = applyExpr e >>= \cf -> case cf of - StringField _ -> fail $ - "Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++ - "got StringField for expr " ++ show e - ListField c xs -> do - sep <- maybe (return "") go s - bs <- mapM (applyTemplate' b c) xs - return $ intercalate sep bs - - applyElem (Partial e) = do - p <- applyExpr e >>= getString e - tpl' <- loadBody (fromFilePath p) - applyTemplate' tpl' context x - - --------------------------------------------------------------------------- - - applyExpr :: TemplateExpr -> Compiler ContextField - - applyExpr (Ident (TemplateKey k)) = context' k [] x - - applyExpr (Call (TemplateKey k) args) = do - args' <- mapM (\e -> applyExpr e >>= getString e) args - context' k args' x - - applyExpr (StringLiteral s) = return (StringField s) - - ---------------------------------------------------------------------------- - - getString _ (StringField s) = return s - getString e (ListField _ _) = fail $ - "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++ - "got ListField for expr " ++ show e - - --------------------------------------------------------------------------------- --- | The following pattern is so common: --- --- > tpl <- loadBody "templates/foo.html" --- > someCompiler --- > >>= applyTemplate tpl context --- --- That we have a single function which does this: --- --- > someCompiler --- > >>= loadAndApplyTemplate "templates/foo.html" context -loadAndApplyTemplate :: Identifier -- ^ Template identifier - -> Context a -- ^ Context - -> Item a -- ^ Page - -> Compiler (Item String) -- ^ Resulting item -loadAndApplyTemplate identifier context item = do - tpl <- loadBody identifier - applyTemplate tpl context item - - --------------------------------------------------------------------------------- --- | It is also possible that you want to substitute @$key$@s within the body of --- an item. This function does that by interpreting the item body as a template, --- and then applying it to itself. -applyAsTemplate :: Context String -- ^ Context - -> Item String -- ^ Item and template - -> Compiler (Item String) -- ^ Resulting item -applyAsTemplate context item = - let tpl = readTemplate $ itemBody item - in applyTemplate tpl context item diff --git a/src/Hakyll/Web/Template/Internal.hs b/src/Hakyll/Web/Template/Internal.hs --- a/src/Hakyll/Web/Template/Internal.hs +++ b/src/Hakyll/Web/Template/Internal.hs @@ -1,30 +1,39 @@ --------------------------------------------------------------------------------- --- | Module containing the template data structure -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} module Hakyll.Web.Template.Internal ( Template (..) - , TemplateKey (..) - , TemplateExpr (..) - , TemplateElement (..) + , template + , templateBodyCompiler + , templateCompiler + , applyTemplate + , applyTemplate' + , loadAndApplyTemplate + , applyAsTemplate , readTemplate + , unsafeReadTemplateFile + + , module Hakyll.Web.Template.Internal.Element + , module Hakyll.Web.Template.Internal.Trim ) where -------------------------------------------------------------------------------- -import Control.Applicative ((<|>)) -import Control.Monad (void) -import Data.Binary (Binary, get, getWord8, put, putWord8) -import Data.Typeable (Typeable) -import Data.List (intercalate) -import GHC.Exts (IsString (..)) -import qualified Text.Parsec as P -import qualified Text.Parsec.String as P +import Control.Monad.Except (MonadError (..)) +import Data.Binary (Binary) +import Data.List (intercalate) +import Data.Typeable (Typeable) +import GHC.Exts (IsString (..)) +import Prelude hiding (id) -------------------------------------------------------------------------------- -import Hakyll.Core.Util.Parser +import Hakyll.Core.Compiler +import Hakyll.Core.Identifier +import Hakyll.Core.Item import Hakyll.Core.Writable +import Hakyll.Web.Template.Context +import Hakyll.Web.Template.Internal.Element +import Hakyll.Web.Template.Internal.Trim -------------------------------------------------------------------------------- @@ -46,176 +55,149 @@ -------------------------------------------------------------------------------- -newtype TemplateKey = TemplateKey String - deriving (Binary, Show, Eq, Typeable) - - --------------------------------------------------------------------------------- -instance IsString TemplateKey where - fromString = TemplateKey +-- | Wrap the constructor to ensure trim is called. +template :: [TemplateElement] -> Template +template = Template . trim -------------------------------------------------------------------------------- --- | Elements of a template. -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 - deriving (Show, Eq, Typeable) - +readTemplate :: String -> Template +readTemplate = Template . trim . readTemplateElems -------------------------------------------------------------------------------- -instance Binary TemplateElement where - put (Chunk string) = putWord8 0 >> put string - put (Expr e) = putWord8 1 >> put e - put (Escaped) = putWord8 2 - put (If e t f ) = putWord8 3 >> put e >> put t >> put f - put (For e b s) = putWord8 4 >> put e >> put b >> put s - put (Partial e) = putWord8 5 >> put e - - get = getWord8 >>= \tag -> case tag of - 0 -> Chunk <$> get - 1 -> Expr <$> get - 2 -> pure Escaped - 3 -> If <$> get <*> get <*> get - 4 -> For <$> get <*> get <*> get - 5 -> Partial <$> get - _ -> error $ - "Hakyll.Web.Template.Internal: Error reading cached template" - +-- | Read a template, without metadata header +templateBodyCompiler :: Compiler (Item Template) +templateBodyCompiler = cached "Hakyll.Web.Template.templateBodyCompiler" $ do + item <- getResourceBody + file <- getResourceFilePath + return $ fmap (template . readTemplateElemsFile file) item -------------------------------------------------------------------------------- --- | Expression in a template -data TemplateExpr - = Ident TemplateKey - | Call TemplateKey [TemplateExpr] - | StringLiteral String - deriving (Eq, Typeable) +-- | Read complete file contents as a template +templateCompiler :: Compiler (Item Template) +templateCompiler = cached "Hakyll.Web.Template.templateCompiler" $ do + item <- getResourceString + file <- getResourceFilePath + return $ fmap (template . readTemplateElemsFile file) item -------------------------------------------------------------------------------- -instance Show TemplateExpr where - show (Ident (TemplateKey k)) = k - show (Call (TemplateKey k) as) = - k ++ "(" ++ intercalate ", " (map show as) ++ ")" - show (StringLiteral s) = show s +applyTemplate :: Template -- ^ Template + -> Context a -- ^ Context + -> Item a -- ^ Page + -> Compiler (Item String) -- ^ Resulting item +applyTemplate tpl context item = do + body <- applyTemplate' (unTemplate tpl) context item + return $ itemSetBody body item -------------------------------------------------------------------------------- -instance Binary TemplateExpr where - put (Ident k) = putWord8 0 >> put k - put (Call k as) = putWord8 1 >> put k >> put as - put (StringLiteral s) = putWord8 2 >> put s +applyTemplate' + :: forall a. + [TemplateElement] -- ^ Unwrapped Template + -> Context a -- ^ Context + -> Item a -- ^ Page + -> Compiler String -- ^ Resulting item +applyTemplate' tes context x = go tes + where + context' :: String -> [String] -> Item a -> Compiler ContextField + context' = unContext (context `mappend` missingField) - get = getWord8 >>= \tag -> case tag of - 0 -> Ident <$> get - 1 -> Call <$> get <*> get - 2 -> StringLiteral <$> get - _ -> error $ - "Hakyll.Web.Tamplte.Internal: Error reading cached template" + go = fmap concat . mapM applyElem + trimError = error $ "Hakyll.Web.Template.applyTemplate: template not " ++ + "fully trimmed." --------------------------------------------------------------------------------- -readTemplate :: String -> Template -readTemplate input = case P.parse template "" input of - Left err -> error $ "Cannot parse template: " ++ show err - Right t -> t + --------------------------------------------------------------------------- + applyElem :: TemplateElement -> Compiler String --------------------------------------------------------------------------------- -template :: P.Parser Template -template = Template <$> - (P.many $ chunk <|> escaped <|> conditional <|> for <|> partial <|> expr) + applyElem TrimL = trimError + applyElem TrimR = trimError --------------------------------------------------------------------------------- -chunk :: P.Parser TemplateElement -chunk = Chunk <$> (P.many1 $ P.noneOf "$") + applyElem (Chunk c) = return c + applyElem (Expr e) = applyExpr e >>= getString e --------------------------------------------------------------------------------- -expr :: P.Parser TemplateElement -expr = P.try $ do - void $ P.char '$' - e <- expr' - void $ P.char '$' - return $ Expr e + applyElem Escaped = return "$" + applyElem (If e t mf) = (applyExpr e >> go t) `catchError` handler + where + handler _ = case mf of + Nothing -> return "" + Just f -> go f --------------------------------------------------------------------------------- -expr' :: P.Parser TemplateExpr -expr' = stringLiteral <|> call <|> ident + applyElem (For e b s) = applyExpr e >>= \cf -> case cf of + StringField _ -> fail $ + "Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++ + "got StringField for expr " ++ show e + ListField c xs -> do + sep <- maybe (return "") go s + bs <- mapM (applyTemplate' b c) xs + return $ intercalate sep bs + applyElem (Partial e) = do + p <- applyExpr e >>= getString e + Template tpl' <- loadBody (fromFilePath p) + applyTemplate' tpl' context x --------------------------------------------------------------------------------- -escaped :: P.Parser TemplateElement -escaped = Escaped <$ (P.try $ P.string "$$") + --------------------------------------------------------------------------- + applyExpr :: TemplateExpr -> Compiler ContextField --------------------------------------------------------------------------------- -conditional :: P.Parser TemplateElement -conditional = P.try $ do - 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 + applyExpr (Ident (TemplateKey k)) = context' k [] x + applyExpr (Call (TemplateKey k) args) = do + args' <- mapM (\e -> applyExpr e >>= getString e) args + context' k args' x --------------------------------------------------------------------------------- -for :: P.Parser TemplateElement -for = P.try $ do - 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 + applyExpr (StringLiteral s) = return (StringField s) + ---------------------------------------------------------------------------- --------------------------------------------------------------------------------- -partial :: P.Parser TemplateElement -partial = P.try $ do - void $ P.string "$partial(" - e <- expr' - void $ P.string ")$" - return $ Partial e + getString _ (StringField s) = return s + getString e (ListField _ _) = fail $ + "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++ + "got ListField for expr " ++ show e -------------------------------------------------------------------------------- -ident :: P.Parser TemplateExpr -ident = P.try $ Ident <$> key +-- | The following pattern is so common: +-- +-- > tpl <- loadBody "templates/foo.html" +-- > someCompiler +-- > >>= applyTemplate tpl context +-- +-- That we have a single function which does this: +-- +-- > someCompiler +-- > >>= loadAndApplyTemplate "templates/foo.html" context +loadAndApplyTemplate :: Identifier -- ^ Template identifier + -> Context a -- ^ Context + -> Item a -- ^ Page + -> Compiler (Item String) -- ^ Resulting item +loadAndApplyTemplate identifier context item = do + tpl <- loadBody identifier + applyTemplate tpl context item -------------------------------------------------------------------------------- -call :: P.Parser TemplateExpr -call = P.try $ do - f <- key - void $ P.char '(' - P.spaces - as <- P.sepBy expr' (P.spaces >> P.char ',' >> P.spaces) - P.spaces - void $ P.char ')' - return $ Call f as +-- | It is also possible that you want to substitute @$key$@s within the body of +-- an item. This function does that by interpreting the item body as a template, +-- and then applying it to itself. +applyAsTemplate :: Context String -- ^ Context + -> Item String -- ^ Item and template + -> Compiler (Item String) -- ^ Resulting item +applyAsTemplate context item = + let tpl = template $ readTemplateElemsFile file (itemBody item) + file = toFilePath $ itemIdentifier item + in applyTemplate tpl context item -------------------------------------------------------------------------------- -stringLiteral :: P.Parser TemplateExpr -stringLiteral = do - void $ P.char '\"' - str <- P.many $ do - x <- P.noneOf "\"" - if x == '\\' then P.anyChar else return x - void $ P.char '\"' - return $ StringLiteral str - +unsafeReadTemplateFile :: FilePath -> Compiler Template +unsafeReadTemplateFile file = do + tpl <- unsafeCompiler $ readFile file + pure $ template $ readTemplateElemsFile file tpl --------------------------------------------------------------------------------- -key :: P.Parser TemplateKey -key = TemplateKey <$> metadataKey diff --git a/src/Hakyll/Web/Template/Internal/Element.hs b/src/Hakyll/Web/Template/Internal/Element.hs new file mode 100644 --- /dev/null +++ b/src/Hakyll/Web/Template/Internal/Element.hs @@ -0,0 +1,298 @@ +-------------------------------------------------------------------------------- +-- | Module containing the elements used in a template. A template is generally +-- just a list of these elements. +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Hakyll.Web.Template.Internal.Element + ( TemplateKey (..) + , TemplateExpr (..) + , TemplateElement (..) + , templateElems + , readTemplateElems + , readTemplateElemsFile + ) where + + +-------------------------------------------------------------------------------- +import Control.Applicative ((<|>)) +import Control.Monad (void) +import Data.Binary (Binary, get, getWord8, put, putWord8) +import Data.List (intercalate) +import Data.Maybe (isJust) +import Data.Typeable (Typeable) +import GHC.Exts (IsString (..)) +import qualified Text.Parsec as P +import qualified Text.Parsec.String as P + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Util.Parser + + +-------------------------------------------------------------------------------- +newtype TemplateKey = TemplateKey String + deriving (Binary, Show, Eq, Typeable) + + +-------------------------------------------------------------------------------- +instance IsString TemplateKey where + fromString = TemplateKey + + +-------------------------------------------------------------------------------- +-- | Elements of a template. +data TemplateElement + = Chunk String + | Expr TemplateExpr + | Escaped + -- expr, then, else + | If TemplateExpr [TemplateElement] (Maybe [TemplateElement]) + -- expr, body, separator + | For TemplateExpr [TemplateElement] (Maybe [TemplateElement]) + -- filename + | Partial TemplateExpr + | TrimL + | TrimR + deriving (Show, Eq, Typeable) + + +-------------------------------------------------------------------------------- +instance Binary TemplateElement where + put (Chunk string) = putWord8 0 >> put string + put (Expr e) = putWord8 1 >> put e + put Escaped = putWord8 2 + put (If e t f) = putWord8 3 >> put e >> put t >> put f + put (For e b s) = putWord8 4 >> put e >> put b >> put s + put (Partial e) = putWord8 5 >> put e + put TrimL = putWord8 6 + put TrimR = putWord8 7 + + get = getWord8 >>= \tag -> case tag of + 0 -> Chunk <$> get + 1 -> Expr <$> get + 2 -> pure Escaped + 3 -> If <$> get <*> get <*> get + 4 -> For <$> get <*> get <*> get + 5 -> Partial <$> get + 6 -> pure TrimL + 7 -> pure TrimR + _ -> error "Hakyll.Web.Template.Internal: Error reading cached template" + + +-------------------------------------------------------------------------------- +-- | Expression in a template +data TemplateExpr + = Ident TemplateKey + | Call TemplateKey [TemplateExpr] + | StringLiteral String + deriving (Eq, Typeable) + + +-------------------------------------------------------------------------------- +instance Show TemplateExpr where + show (Ident (TemplateKey k)) = k + show (Call (TemplateKey k) as) = + k ++ "(" ++ intercalate ", " (map show as) ++ ")" + show (StringLiteral s) = show s + + +-------------------------------------------------------------------------------- +instance Binary TemplateExpr where + put (Ident k) = putWord8 0 >> put k + put (Call k as) = putWord8 1 >> put k >> put as + put (StringLiteral s) = putWord8 2 >> put s + + get = getWord8 >>= \tag -> case tag of + 0 -> Ident <$> get + 1 -> Call <$> get <*> get + 2 -> StringLiteral <$> get + _ -> error "Hakyll.Web.Template.Internal: Error reading cached template" + + +-------------------------------------------------------------------------------- +readTemplateElems :: String -> [TemplateElement] +readTemplateElems = readTemplateElemsFile "{literal}" + + +-------------------------------------------------------------------------------- +readTemplateElemsFile :: FilePath -> String -> [TemplateElement] +readTemplateElemsFile file input = case P.parse templateElems file input of + Left err -> error $ "Cannot parse template: " ++ show err + Right t -> t + + +-------------------------------------------------------------------------------- +templateElems :: P.Parser [TemplateElement] +templateElems = mconcat <$> P.many (P.choice [ lift chunk + , lift escaped + , conditional + , for + , partial + , expr + ]) + where lift = fmap (:[]) + + +-------------------------------------------------------------------------------- +chunk :: P.Parser TemplateElement +chunk = Chunk <$> P.many1 (P.noneOf "$") + + +-------------------------------------------------------------------------------- +expr :: P.Parser [TemplateElement] +expr = P.try $ do + trimLExpr <- trimOpen + e <- expr' + trimRExpr <- trimClose + return $ [TrimL | trimLExpr] ++ [Expr e] ++ [TrimR | trimRExpr] + + +-------------------------------------------------------------------------------- +expr' :: P.Parser TemplateExpr +expr' = stringLiteral <|> call <|> ident + + +-------------------------------------------------------------------------------- +escaped :: P.Parser TemplateElement +escaped = Escaped <$ P.try (P.string "$$") + + +-------------------------------------------------------------------------------- +trimOpen :: P.Parser Bool +trimOpen = do + void $ P.char '$' + trimLIf <- P.optionMaybe $ P.try (P.char '-') + pure $ isJust trimLIf + + +-------------------------------------------------------------------------------- +trimClose :: P.Parser Bool +trimClose = do + trimIfR <- P.optionMaybe $ P.try (P.char '-') + void $ P.char '$' + pure $ isJust trimIfR + + +-------------------------------------------------------------------------------- +conditional :: P.Parser [TemplateElement] +conditional = P.try $ do + -- if + trimLIf <- trimOpen + void $ P.string "if(" + e <- expr' + void $ P.char ')' + trimRIf <- trimClose + -- then + thenBranch <- templateElems + -- else + elseParse <- opt "else" + -- endif + trimLEnd <- trimOpen + void $ P.string "endif" + trimREnd <- trimClose + + -- As else is optional we need to sort out where any Trim_s need to go. + let (thenBody, elseBody) = maybe (thenNoElse, Nothing) thenElse elseParse + where thenNoElse = + [TrimR | trimRIf] ++ thenBranch ++ [TrimL | trimLEnd] + + thenElse (trimLElse, elseBranch, trimRElse) = (thenB, elseB) + where thenB = [TrimR | trimRIf] + ++ thenBranch + ++ [TrimL | trimLElse] + + elseB = Just $ [TrimR | trimRElse] + ++ elseBranch + ++ [TrimL | trimLEnd] + + pure $ [TrimL | trimLIf] ++ [If e thenBody elseBody] ++ [TrimR | trimREnd] + + +-------------------------------------------------------------------------------- +for :: P.Parser [TemplateElement] +for = P.try $ do + -- for + trimLFor <- trimOpen + void $ P.string "for(" + e <- expr' + void $ P.char ')' + trimRFor <- trimClose + -- body + bodyBranch <- templateElems + -- sep + sepParse <- opt "sep" + -- endfor + trimLEnd <- trimOpen + void $ P.string "endfor" + trimREnd <- trimClose + + -- As sep is optional we need to sort out where any Trim_s need to go. + let (forBody, sepBody) = maybe (forNoSep, Nothing) forSep sepParse + where forNoSep = + [TrimR | trimRFor] ++ bodyBranch ++ [TrimL | trimLEnd] + + forSep (trimLSep, sepBranch, trimRSep) = (forB, sepB) + where forB = [TrimR | trimRFor] + ++ bodyBranch + ++ [TrimL | trimLSep] + + sepB = Just $ [TrimR | trimRSep] + ++ sepBranch + ++ [TrimL | trimLEnd] + + pure $ [TrimL | trimLFor] ++ [For e forBody sepBody] ++ [TrimR | trimREnd] + + +-------------------------------------------------------------------------------- +partial :: P.Parser [TemplateElement] +partial = P.try $ do + trimLPart <- trimOpen + void $ P.string "partial(" + e <- expr' + void $ P.char ')' + trimRPart <- trimClose + + pure $ [TrimL | trimLPart] ++ [Partial e] ++ [TrimR | trimRPart] + + +-------------------------------------------------------------------------------- +ident :: P.Parser TemplateExpr +ident = P.try $ Ident <$> key + + +-------------------------------------------------------------------------------- +call :: P.Parser TemplateExpr +call = P.try $ do + f <- key + void $ P.char '(' + P.spaces + as <- P.sepBy expr' (P.spaces >> P.char ',' >> P.spaces) + P.spaces + void $ P.char ')' + return $ Call f as + + +-------------------------------------------------------------------------------- +stringLiteral :: P.Parser TemplateExpr +stringLiteral = do + void $ P.char '\"' + str <- P.many $ do + x <- P.noneOf "\"" + if x == '\\' then P.anyChar else return x + void $ P.char '\"' + return $ StringLiteral str + + +-------------------------------------------------------------------------------- +key :: P.Parser TemplateKey +key = TemplateKey <$> metadataKey + + +-------------------------------------------------------------------------------- +opt :: String -> P.Parser (Maybe (Bool, [TemplateElement], Bool)) +opt clause = P.optionMaybe $ P.try $ do + trimL <- trimOpen + void $ P.string clause + trimR <- trimClose + branch <- templateElems + pure (trimL, branch, trimR) + diff --git a/src/Hakyll/Web/Template/Internal/Trim.hs b/src/Hakyll/Web/Template/Internal/Trim.hs new file mode 100644 --- /dev/null +++ b/src/Hakyll/Web/Template/Internal/Trim.hs @@ -0,0 +1,95 @@ +-------------------------------------------------------------------------------- +-- | Module for trimming whitespace from tempaltes. +module Hakyll.Web.Template.Internal.Trim + ( trim + ) where + + +-------------------------------------------------------------------------------- +import Data.Char (isSpace) +import Data.List (dropWhileEnd) + + +-------------------------------------------------------------------------------- +import Hakyll.Web.Template.Internal.Element + + +-------------------------------------------------------------------------------- +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/Core/Dependencies/Tests.hs b/tests/Hakyll/Core/Dependencies/Tests.hs --- a/tests/Hakyll/Core/Dependencies/Tests.hs +++ b/tests/Hakyll/Core/Dependencies/Tests.hs @@ -9,8 +9,8 @@ import Data.List (delete) import qualified Data.Map as M import qualified Data.Set as S -import Test.Framework (Test, testGroup) -import Test.HUnit (Assertion, (@=?)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, (@=?)) -------------------------------------------------------------------------------- @@ -20,7 +20,7 @@ -------------------------------------------------------------------------------- -tests :: Test +tests :: TestTree tests = testGroup "Hakyll.Core.Dependencies.Tests" $ fromAssertions "analyze" [case01, case02, case03] diff --git a/tests/Hakyll/Core/Identifier/Tests.hs b/tests/Hakyll/Core/Identifier/Tests.hs --- a/tests/Hakyll/Core/Identifier/Tests.hs +++ b/tests/Hakyll/Core/Identifier/Tests.hs @@ -6,8 +6,8 @@ -------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.HUnit ((@=?)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@=?)) -------------------------------------------------------------------------------- @@ -17,7 +17,7 @@ -------------------------------------------------------------------------------- -tests :: Test +tests :: TestTree tests = testGroup "Hakyll.Core.Identifier.Tests" $ concat [ captureTests , matchesTests @@ -25,7 +25,7 @@ -------------------------------------------------------------------------------- -captureTests :: [Test] +captureTests :: [TestTree] captureTests = fromAssertions "capture" [ Just ["bar"] @=? capture "foo/**" "foo/bar" , Just ["foo/bar"] @=? capture "**" "foo/bar" @@ -46,7 +46,7 @@ -------------------------------------------------------------------------------- -matchesTests :: [Test] +matchesTests :: [TestTree] matchesTests = fromAssertions "matches" [ True @=? matches (fromList ["foo.markdown"]) "foo.markdown" , False @=? matches (fromList ["foo"]) (setVersion (Just "x") "foo") diff --git a/tests/Hakyll/Core/Provider/Metadata/Tests.hs b/tests/Hakyll/Core/Provider/Metadata/Tests.hs --- a/tests/Hakyll/Core/Provider/Metadata/Tests.hs +++ b/tests/Hakyll/Core/Provider/Metadata/Tests.hs @@ -10,13 +10,13 @@ import qualified Data.Yaml as Yaml import Hakyll.Core.Metadata import Hakyll.Core.Provider.Metadata -import Test.Framework (Test, testGroup) -import Test.HUnit (Assertion, (@=?), assertFailure) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertFailure, (@=?)) import TestSuite.Util -------------------------------------------------------------------------------- -tests :: Test +tests :: TestTree tests = testGroup "Hakyll.Core.Provider.Metadata.Tests" $ fromAssertions "page" [testPage01, testPage02] diff --git a/tests/Hakyll/Core/Provider/Tests.hs b/tests/Hakyll/Core/Provider/Tests.hs --- a/tests/Hakyll/Core/Provider/Tests.hs +++ b/tests/Hakyll/Core/Provider/Tests.hs @@ -8,14 +8,13 @@ -------------------------------------------------------------------------------- import Hakyll.Core.Metadata import Hakyll.Core.Provider -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, assert, (@=?)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assert, testCase, (@=?)) import TestSuite.Util -------------------------------------------------------------------------------- -tests :: Test +tests :: TestTree tests = testGroup "Hakyll.Core.Provider.Tests" [ testCase "case01" case01 ] diff --git a/tests/Hakyll/Core/Routes/Tests.hs b/tests/Hakyll/Core/Routes/Tests.hs --- a/tests/Hakyll/Core/Routes/Tests.hs +++ b/tests/Hakyll/Core/Routes/Tests.hs @@ -11,13 +11,13 @@ import Hakyll.Core.Metadata import Hakyll.Core.Routes import System.FilePath (()) -import Test.Framework (Test, testGroup) -import Test.HUnit (Assertion, (@=?)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, (@=?)) import TestSuite.Util -------------------------------------------------------------------------------- -tests :: Test +tests :: TestTree tests = testGroup "Hakyll.Core.Routes.Tests" $ fromAssertions "runRoutes" [ testRoutes "foo.html" (setExtension "html") "foo" , testRoutes "foo.html" (setExtension ".html") "foo" diff --git a/tests/Hakyll/Core/Rules/Tests.hs b/tests/Hakyll/Core/Rules/Tests.hs --- a/tests/Hakyll/Core/Rules/Tests.hs +++ b/tests/Hakyll/Core/Rules/Tests.hs @@ -19,13 +19,13 @@ import Hakyll.Core.Rules.Internal import Hakyll.Web.Pandoc import System.FilePath (()) -import Test.Framework (Test, testGroup) -import Test.HUnit (Assertion, assert, (@=?)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assert, (@=?)) import TestSuite.Util -------------------------------------------------------------------------------- -tests :: Test +tests :: TestTree tests = testGroup "Hakyll.Core.Rules.Tests" $ fromAssertions "runRules" [case01] diff --git a/tests/Hakyll/Core/Runtime/Tests.hs b/tests/Hakyll/Core/Runtime/Tests.hs --- a/tests/Hakyll/Core/Runtime/Tests.hs +++ b/tests/Hakyll/Core/Runtime/Tests.hs @@ -8,8 +8,8 @@ -------------------------------------------------------------------------------- import qualified Data.ByteString as B import System.FilePath (()) -import Test.Framework (Test, testGroup) -import Test.HUnit (Assertion, (@?=)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, (@?=)) -------------------------------------------------------------------------------- @@ -20,7 +20,7 @@ -------------------------------------------------------------------------------- -tests :: Test +tests :: TestTree tests = testGroup "Hakyll.Core.Runtime.Tests" $ fromAssertions "run" [case01, case02] @@ -41,6 +41,15 @@ >>= saveSnapshot "raw" >>= renderPandoc + match (fromList ["partial.html", "partial-helper.html"]) $ + compile templateCompiler + create ["partial.html.out"] $ do + route idRoute + compile $ do + example <- loadSnapshotBody "example.md" "raw" + makeItem example + >>= loadAndApplyTemplate "partial.html" defaultContext + create ["bodies.txt"] $ do route idRoute compile $ do @@ -59,6 +68,10 @@ bodies <- readFile $ destinationDirectory testConfiguration "bodies.txt" head (lines bodies) @?= "This is an example." + + partial <- readFile $ providerDirectory testConfiguration "partial.html.out" + partial' <- readFile $ destinationDirectory testConfiguration "partial.html.out" + partial @?= partial' cleanTestEnv diff --git a/tests/Hakyll/Core/Store/Tests.hs b/tests/Hakyll/Core/Store/Tests.hs --- a/tests/Hakyll/Core/Store/Tests.hs +++ b/tests/Hakyll/Core/Store/Tests.hs @@ -6,22 +6,22 @@ -------------------------------------------------------------------------------- -import Data.Typeable (typeOf) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import qualified Test.HUnit as H -import qualified Test.QuickCheck as Q -import qualified Test.QuickCheck.Monadic as Q +import Data.Typeable (typeOf) +import qualified Test.QuickCheck as Q +import qualified Test.QuickCheck.Monadic as Q +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) +import qualified Test.Tasty.HUnit as H +import Test.Tasty.QuickCheck (testProperty) -------------------------------------------------------------------------------- -import qualified Hakyll.Core.Store as Store +import qualified Hakyll.Core.Store as Store import TestSuite.Util -------------------------------------------------------------------------------- -tests :: Test +tests :: TestTree tests = testGroup "Hakyll.Core.Store.Tests" [ testProperty "simple get . set" simpleSetGet , testProperty "persistent get . set" persistentSetGet diff --git a/tests/Hakyll/Core/UnixFilter/Tests.hs b/tests/Hakyll/Core/UnixFilter/Tests.hs --- a/tests/Hakyll/Core/UnixFilter/Tests.hs +++ b/tests/Hakyll/Core/UnixFilter/Tests.hs @@ -6,10 +6,10 @@ -------------------------------------------------------------------------------- -import Data.List (isInfixOf) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import qualified Test.HUnit as H +import Data.List (isInfixOf) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) +import qualified Test.Tasty.HUnit as H -------------------------------------------------------------------------------- @@ -21,7 +21,7 @@ -------------------------------------------------------------------------------- -tests :: Test +tests :: TestTree tests = testGroup "Hakyll.Core.UnixFilter.Tests" [ testCase "unixFilter rev" unixFilterRev , testCase "unixFilter false" unixFilterFalse diff --git a/tests/Hakyll/Core/Util/String/Tests.hs b/tests/Hakyll/Core/Util/String/Tests.hs --- a/tests/Hakyll/Core/Util/String/Tests.hs +++ b/tests/Hakyll/Core/Util/String/Tests.hs @@ -5,8 +5,8 @@ -------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.HUnit ((@=?)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@=?)) -------------------------------------------------------------------------------- @@ -15,7 +15,7 @@ -------------------------------------------------------------------------------- -tests :: Test +tests :: TestTree tests = testGroup "Hakyll.Core.Util.String.Tests" $ concat [ fromAssertions "trim" [ "foo" @=? trim " foo\n\t " diff --git a/tests/Hakyll/Web/CompressCss/Tests.hs b/tests/Hakyll/Web/CompressCss/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Hakyll/Web/CompressCss/Tests.hs @@ -0,0 +1,59 @@ +-------------------------------------------------------------------------------- +module Hakyll.Web.CompressCss.Tests + ( tests + ) where + + +-------------------------------------------------------------------------------- +import Data.Char (toUpper) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assert, (@=?)) + + +-------------------------------------------------------------------------------- +import Hakyll.Web.CompressCss +import TestSuite.Util + + +-------------------------------------------------------------------------------- +tests :: TestTree +tests = testGroup "Hakyll.Web.CompressCss.Tests" $ concat + [ fromAssertions "compressCss" + [ + -- compress whitespace + " something something " @=? + compressCss " something \n\t\r something " + -- do not compress whitespace in constants + , "abc \" \t\n\r \" xyz" @=? + compressCss "abc \" \t\n\r \" xyz" + , "abc ' \t\n\r ' xyz" @=? + compressCss "abc ' \t\n\r ' xyz" + + -- strip comments + , "before after" @=? compressCss "before /* abc { } ;; \n\t\r */ after" + -- don't strip comments inside constants + , "before \"/* abc { } ;; \n\t\r */\" after" + @=? compressCss "before \"/* abc { } ;; \n\t\r */\" after" + + -- compress separators + , "}" @=? compressCss "; }" + , "{};" @=? compressCss " { } ; " + -- compress whitespace even after this curly brace + , "}" @=? compressCss "; } " + -- but do not compress separators inside of constants + , "\" { } ; \"" @=? compressCss "\" { } ; \"" + -- don't compress separators at the start or end of constants + , "\" }\"" @=? compressCss "\" }\"" + , "\"{ \"" @=? compressCss "\"{ \"" + -- don't get irritated by the wrong constant terminator + , "\" ' \"" @=? compressCss "\" ' \"" + , "' \" '" @=? compressCss "' \" '" + -- don't compress whitespace around separators in constants in the middle of a string + , "abc '{ '" @=? compressCss "abc '{ '" + , "abc \"{ \"" @=? compressCss "abc \"{ \"" + -- compress whitespace after colons + , "abc:xyz" @=? compressCss "abc : xyz" + -- compress multiple semicolons + , ";" @=? compressCss ";;;;;;;" + ] + ] diff --git a/tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs b/tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs --- a/tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs +++ b/tests/Hakyll/Web/Html/RelativizeUrls/Tests.hs @@ -6,16 +6,17 @@ -------------------------------------------------------------------------------- -import Test.Framework (Test, testGroup) -import Test.HUnit ((@=?)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@=?)) + -------------------------------------------------------------------------------- import Hakyll.Web.Html.RelativizeUrls import TestSuite.Util -------------------------------------------------------------------------------- -tests :: Test +tests :: TestTree tests = testGroup "Hakyll.Web.Html.RelativizeUrls.Tests" $ fromAssertions "relativizeUrls" [ "bar" @=? diff --git a/tests/Hakyll/Web/Html/Tests.hs b/tests/Hakyll/Web/Html/Tests.hs --- a/tests/Hakyll/Web/Html/Tests.hs +++ b/tests/Hakyll/Web/Html/Tests.hs @@ -5,9 +5,9 @@ -------------------------------------------------------------------------------- -import Data.Char (toUpper) -import Test.Framework (Test, testGroup) -import Test.HUnit (assert, (@=?)) +import Data.Char (toUpper) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assert, (@=?)) -------------------------------------------------------------------------------- @@ -16,7 +16,7 @@ -------------------------------------------------------------------------------- -tests :: Test +tests :: TestTree tests = testGroup "Hakyll.Web.Html.Tests" $ concat [ fromAssertions "demoteHeaders" [ "