diff options
Diffstat (limited to 'src/Hakyll/Web/Template/Internal')
| -rw-r--r-- | src/Hakyll/Web/Template/Internal/Element.hs | 298 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template/Internal/Trim.hs | 95 |
2 files changed, 0 insertions, 393 deletions
diff --git a/src/Hakyll/Web/Template/Internal/Element.hs b/src/Hakyll/Web/Template/Internal/Element.hs deleted file mode 100644 index f564355..0000000 --- a/src/Hakyll/Web/Template/Internal/Element.hs +++ /dev/null @@ -1,298 +0,0 @@ --------------------------------------------------------------------------------- --- | 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 deleted file mode 100644 index e416ff2..0000000 --- a/src/Hakyll/Web/Template/Internal/Trim.hs +++ /dev/null @@ -1,95 +0,0 @@ --------------------------------------------------------------------------------- --- | 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 - |