diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Hakyll/Web/Template.hs | 184 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template/Internal.hs | 374 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template/Internal/Element.hs | 298 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template/Internal/Trim.hs (renamed from src/Hakyll/Web/Template/Trim.hs) | 20 |
4 files changed, 448 insertions, 428 deletions
diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index 8118fff..2a9684b 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -138,8 +138,6 @@ -- > 3...2...1 -- > </p> -- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} module Hakyll.Web.Template ( Template , templateBodyCompiler @@ -153,186 +151,4 @@ module Hakyll.Web.Template -------------------------------------------------------------------------------- -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.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 (template . readTemplateElemsFile file) item - --------------------------------------------------------------------------------- --- | 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 - - --------------------------------------------------------------------------------- -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 - - --------------------------------------------------------------------------------- -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) - - 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 - - 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 = 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 15266a0..3686914 100644 --- a/src/Hakyll/Web/Template/Internal.hs +++ b/src/Hakyll/Web/Template/Internal.hs @@ -1,297 +1,203 @@ --------------------------------------------------------------------------------- --- | Module containing the template data structure {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} module Hakyll.Web.Template.Internal - ( TemplateKey (..) - , TemplateExpr (..) - , TemplateElement (..) - , templateElems - , readTemplateElems - , readTemplateElemsFile + ( Template (..) + , 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.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 +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) -------------------------------------------------------------------------------- -newtype TemplateKey = TemplateKey String - deriving (Binary, Show, Eq, Typeable) +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 -------------------------------------------------------------------------------- -instance IsString TemplateKey where - fromString = TemplateKey +-- | Datatype used for template substitutions. +newtype Template = Template + { unTemplate :: [TemplateElement] + } deriving (Show, Eq, Binary, Typeable) -------------------------------------------------------------------------------- --- | 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 Writable Template where + -- Writing a template is impossible + write _ _ = return () -------------------------------------------------------------------------------- -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" +instance IsString Template where + fromString = readTemplate -------------------------------------------------------------------------------- --- | 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" +-- | Wrap the constructor to ensure trim is called. +template :: [TemplateElement] -> Template +template = Template . trim -------------------------------------------------------------------------------- -readTemplateElems :: String -> [TemplateElement] -readTemplateElems = readTemplateElemsFile "{literal}" - +readTemplate :: String -> Template +readTemplate = Template . trim . readTemplateElems -------------------------------------------------------------------------------- -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 - +-- | 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 -------------------------------------------------------------------------------- -templateElems :: P.Parser [TemplateElement] -templateElems = mconcat <$> P.many (P.choice [ lift chunk - , lift escaped - , conditional - , for - , partial - , expr - ]) - where lift = fmap (:[]) +-- | 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 -------------------------------------------------------------------------------- -chunk :: P.Parser TemplateElement -chunk = Chunk <$> P.many1 (P.noneOf "$") +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 -------------------------------------------------------------------------------- -expr :: P.Parser [TemplateElement] -expr = P.try $ do - trimLExpr <- trimOpen - e <- expr' - trimRExpr <- trimClose - return $ [TrimL | trimLExpr] ++ [Expr e] ++ [TrimR | trimRExpr] +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) + go = fmap concat . mapM applyElem --------------------------------------------------------------------------------- -expr' :: P.Parser TemplateExpr -expr' = stringLiteral <|> call <|> ident + trimError = error $ "Hakyll.Web.Template.applyTemplate: template not " ++ + "fully trimmed." + --------------------------------------------------------------------------- --------------------------------------------------------------------------------- -escaped :: P.Parser TemplateElement -escaped = Escaped <$ P.try (P.string "$$") + applyElem :: TemplateElement -> Compiler String + applyElem TrimL = trimError --------------------------------------------------------------------------------- -trimOpen :: P.Parser Bool -trimOpen = do - void $ P.char '$' - trimLIf <- P.optionMaybe $ P.try (P.char '-') - pure $ isJust trimLIf + applyElem TrimR = trimError + applyElem (Chunk c) = return c --------------------------------------------------------------------------------- -trimClose :: P.Parser Bool -trimClose = do - trimIfR <- P.optionMaybe $ P.try (P.char '-') - void $ P.char '$' - pure $ isJust trimIfR + applyElem (Expr e) = applyExpr e >>= getString e + applyElem Escaped = return "$" --------------------------------------------------------------------------------- -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] + 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 --------------------------------------------------------------------------------- -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] + applyElem (Partial e) = do + p <- applyExpr e >>= getString e + tpl' <- loadBody (fromFilePath p) + applyTemplate' tpl' context x + --------------------------------------------------------------------------- --------------------------------------------------------------------------------- -partial :: P.Parser [TemplateElement] -partial = P.try $ do - trimLPart <- trimOpen - void $ P.string "partial(" - e <- expr' - void $ P.char ')' - trimRPart <- trimClose + applyExpr :: TemplateExpr -> Compiler ContextField - pure $ [TrimL | trimLPart] ++ [Partial e] ++ [TrimR | trimRPart] + 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 --------------------------------------------------------------------------------- -ident :: P.Parser TemplateExpr -ident = P.try $ Ident <$> key + applyExpr (StringLiteral s) = return (StringField s) + ---------------------------------------------------------------------------- --------------------------------------------------------------------------------- -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 + getString _ (StringField s) = return s + getString e (ListField _ _) = fail $ + "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++ + "got ListField for expr " ++ show e -------------------------------------------------------------------------------- -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 +-- | 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 -------------------------------------------------------------------------------- -key :: P.Parser TemplateKey -key = TemplateKey <$> metadataKey +-- | 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 -------------------------------------------------------------------------------- -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) +unsafeReadTemplateFile :: FilePath -> Compiler Template +unsafeReadTemplateFile file = do + tpl <- unsafeCompiler $ readFile file + pure $ template $ readTemplateElemsFile file tpl diff --git a/src/Hakyll/Web/Template/Internal/Element.hs b/src/Hakyll/Web/Template/Internal/Element.hs new file mode 100644 index 0000000..f564355 --- /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/Trim.hs b/src/Hakyll/Web/Template/Internal/Trim.hs index bc7e691..e416ff2 100644 --- a/src/Hakyll/Web/Template/Trim.hs +++ b/src/Hakyll/Web/Template/Internal/Trim.hs @@ -1,17 +1,17 @@ -------------------------------------------------------------------------------- --- | Module for trimming whitespace -module Hakyll.Web.Template.Trim +-- | Module for trimming whitespace from tempaltes. +module Hakyll.Web.Template.Internal.Trim ( trim ) where -------------------------------------------------------------------------------- -import Data.Char (isSpace) -import Data.List (dropWhileEnd) +import Data.Char (isSpace) +import Data.List (dropWhileEnd) -------------------------------------------------------------------------------- -import Hakyll.Web.Template.Internal +import Hakyll.Web.Template.Internal.Element -------------------------------------------------------------------------------- @@ -58,7 +58,7 @@ redundant = recurse redundant . process -- Remove trailing 'TrimR's. process ts = foldr trailing [] ts where trailing TrimR [] = [] - trailing x xs = x:xs + trailing x xs = x:xs -------------------------------------------------------------------------------- @@ -66,19 +66,19 @@ redundant = recurse redundant . process -- [TrimL, TrimR] swap :: [TemplateElement] -> [TemplateElement] swap = recurse swap . process - where process [] = [] + where process [] = [] process (TrimR:TrimL:ts) = TrimL:process (TrimR:ts) - process (t:ts) = t:process ts + process (t:ts) = t:process ts -------------------------------------------------------------------------------- -- | Remove 'TrimR' and 'TrimL' duplication. dedupe :: [TemplateElement] -> [TemplateElement] dedupe = recurse dedupe . process - where process [] = [] + where process [] = [] process (TrimR:TrimR:ts) = process (TrimR:ts) process (TrimL:TrimL:ts) = process (TrimL:ts) - process (t:ts) = t:process ts + process (t:ts) = t:process ts -------------------------------------------------------------------------------- |