diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Hakyll/Core/Util/Parser.hs | 11 | ||||
| -rw-r--r-- | src/Hakyll/Web/Feed.hs | 14 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template.hs | 96 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template/Internal.hs | 208 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template/Trim.hs | 95 |
5 files changed, 327 insertions, 97 deletions
diff --git a/src/Hakyll/Core/Util/Parser.hs b/src/Hakyll/Core/Util/Parser.hs index e958b76..c4b2f8d 100644 --- a/src/Hakyll/Core/Util/Parser.hs +++ b/src/Hakyll/Core/Util/Parser.hs @@ -8,7 +8,7 @@ module Hakyll.Core.Util.Parser -------------------------------------------------------------------------------- import Control.Applicative ((<|>)) -import Control.Monad (mzero) +import Control.Monad (guard, mzero, void) import qualified Text.Parsec as P import Text.Parsec.String (Parser) @@ -16,7 +16,14 @@ import Text.Parsec.String (Parser) -------------------------------------------------------------------------------- metadataKey :: Parser String metadataKey = do - i <- (:) <$> P.letter <*> (P.many $ P.alphaNum <|> P.oneOf "_-.") + -- Ensure trailing '-' binds to '$' if present. + let hyphon = P.try $ do + void $ P.char '-' + x <- P.lookAhead P.anyChar + guard $ x /= '$' + pure '-' + + i <- (:) <$> P.letter <*> P.many (P.alphaNum <|> P.oneOf "_." <|> hyphon) if i `elem` reservedKeys then mzero else return i diff --git a/src/Hakyll/Web/Feed.hs b/src/Hakyll/Web/Feed.hs index 16b6dc0..f40fa8a 100644 --- a/src/Hakyll/Web/Feed.hs +++ b/src/Hakyll/Web/Feed.hs @@ -24,16 +24,11 @@ module Hakyll.Web.Feed -------------------------------------------------------------------------------- -import Control.Monad ((<=<)) - - --------------------------------------------------------------------------------- import Hakyll.Core.Compiler import Hakyll.Core.Compiler.Internal import Hakyll.Core.Item import Hakyll.Web.Template import Hakyll.Web.Template.Context -import Hakyll.Web.Template.Internal import Hakyll.Web.Template.List @@ -66,17 +61,16 @@ renderFeed :: FilePath -- ^ Feed template -> [Item String] -- ^ Input items -> Compiler (Item String) -- ^ Resulting item renderFeed feedPath itemPath config itemContext items = do - feedTpl <- compilerUnsafeIO $ loadTemplate feedPath - itemTpl <- compilerUnsafeIO $ loadTemplate itemPath + feedTpl <- loadTemplate feedPath + itemTpl <- loadTemplate itemPath body <- makeItem =<< applyTemplateList itemTpl itemContext' items applyTemplate feedTpl feedContext body where -- Auxiliary: load a template from a datafile loadTemplate path = do - file <- getDataFileName path - templ <- readFile file - return $ readTemplateFile file templ + file <- compilerUnsafeIO $ getDataFileName path + unsafeReadTemplateFile file itemContext' = mconcat [ itemContext diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index a662906..4a8d94c 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -115,7 +115,31 @@ -- That is, calling @$partial$@ is equivalent to just copying and pasting -- template code. -- -{-# LANGUAGE ScopedTypeVariables #-} +-- 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 +-- +-- > <p> +-- > $for(counts)-$ +-- > $count$ +-- > $-sep$... +-- > $-endfor$ +-- > </p> +-- +-- the resulting page would look like +-- +-- > <p> +-- > 3...2...1 +-- > </p> +-- +{-# 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 + |