From 59b6f01218eb2fbd36cb9fec6a3413093171ccda Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 27 Oct 2014 12:20:31 +0100 Subject: Better functions in templates --- src/Hakyll/Core/Util/Parser.hs | 2 +- src/Hakyll/Web/Feed.hs | 2 +- src/Hakyll/Web/Template.hs | 49 ++++++++++---- src/Hakyll/Web/Template/Context.hs | 38 +++++------ src/Hakyll/Web/Template/Internal.hs | 123 ++++++++++++++++++++++++++++-------- 5 files changed, 154 insertions(+), 60 deletions(-) (limited to 'src/Hakyll') diff --git a/src/Hakyll/Core/Util/Parser.hs b/src/Hakyll/Core/Util/Parser.hs index 25494bd..c5789ed 100644 --- a/src/Hakyll/Core/Util/Parser.hs +++ b/src/Hakyll/Core/Util/Parser.hs @@ -16,7 +16,7 @@ import Text.Parsec.String (Parser) -------------------------------------------------------------------------------- metadataKey :: Parser String metadataKey = do - i <- (:) <$> P.letter <*> (P.many $ P.alphaNum <|> P.oneOf " _-.") + i <- (:) <$> P.letter <*> (P.many $ P.alphaNum <|> P.oneOf "_-.") if i `elem` reservedKeys then mzero else return i diff --git a/src/Hakyll/Web/Feed.hs b/src/Hakyll/Web/Feed.hs index 8c68a75..794ded5 100644 --- a/src/Hakyll/Web/Feed.hs +++ b/src/Hakyll/Web/Feed.hs @@ -96,7 +96,7 @@ renderFeed feedPath itemPath config itemContext items = do -- recent. updatedField = field "updated" $ \_ -> case items of [] -> return "Unknown" - (x : _) -> unContext itemContext' "updated" x >>= \cf -> case cf of + (x : _) -> unContext itemContext' "updated" [] x >>= \cf -> case cf of ListField _ _ -> fail "Hakyll.Web.Feed.renderFeed: Internal error" StringField s -> return s diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs index 086e9b2..d28ce08 100644 --- a/src/Hakyll/Web/Template.hs +++ b/src/Hakyll/Web/Template.hs @@ -115,7 +115,7 @@ -- That is, calling @$partial$@ is equivalent to just copying and pasting -- template code. -- - +{-# LANGUAGE ScopedTypeVariables #-} module Hakyll.Web.Template ( Template , templateCompiler @@ -161,44 +161,67 @@ applyTemplate tpl context item = do -------------------------------------------------------------------------------- -applyTemplate' :: Template -- ^ Template - -> Context a -- ^ Context - -> Item a -- ^ Page - -> Compiler String -- ^ Resulting 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 Escaped = return "$" + applyElem (Expr e) = applyExpr e >>= getString e - applyElem (Key k) = context' k x >>= getString k + applyElem Escaped = return "$" - applyElem (If k t mf) = (context' k x >> go t) `catchError` handler + applyElem (If e t mf) = (applyExpr e >> go t) `catchError` handler where handler _ = case mf of Nothing -> return "" Just f -> go f - applyElem (For k b s) = context' k x >>= \cf -> case cf of + applyElem (For e b s) = applyExpr e >>= \cf -> case cf of StringField _ -> fail $ "Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++ - "got StringField for key " ++ show k + "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 p) = do + 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 k (ListField _ _) = fail $ + getString e (ListField _ _) = fail $ "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++ - "got ListField for key " ++ show k + "got ListField for expr " ++ show e -------------------------------------------------------------------------------- diff --git a/src/Hakyll/Web/Template/Context.hs b/src/Hakyll/Web/Template/Context.hs index a606a69..b5066a6 100644 --- a/src/Hakyll/Web/Template/Context.hs +++ b/src/Hakyll/Web/Template/Context.hs @@ -69,29 +69,30 @@ data ContextField -- @ -- 'metadataField' \<\> field \"date\" fDate -- @ --- +-- newtype Context a = Context - { unContext :: String -> Item a -> Compiler ContextField + { unContext :: String -> [String] -> Item a -> Compiler ContextField } -------------------------------------------------------------------------------- instance Monoid (Context a) where mempty = missingField - mappend (Context f) (Context g) = Context $ \k i -> f k i <|> g k i + mappend (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i -------------------------------------------------------------------------------- field' :: String -> (Item a -> Compiler ContextField) -> Context a -field' key value = Context $ \k i -> if k == key then value i else empty +field' key value = Context $ \k _ i -> if k == key then value i else empty -------------------------------------------------------------------------------- -- | Constructs a new field in the 'Context.' -field :: String -- ^ Key - -> (Item a -> Compiler String) -- ^ Function that constructs a - -- value based on the item - -> Context a +field + :: String -- ^ Key + -> (Item a -> Compiler String) -- ^ Function that constructs a value based + -- on the item + -> Context a field key value = field' key (fmap StringField . value) @@ -108,17 +109,16 @@ listField key c xs = field' key $ \_ -> fmap (ListField c) xs -------------------------------------------------------------------------------- functionField :: String -> ([String] -> Item a -> Compiler String) -> Context a -functionField name value = Context $ \k i -> case words k of - [] -> empty - (n : args) - | n == name -> StringField <$> value args i - | otherwise -> empty +functionField name value = Context $ \k args i -> + if k == name + then StringField <$> value args i + else empty -------------------------------------------------------------------------------- mapContext :: (String -> String) -> Context a -> Context a -mapContext f (Context c) = Context $ \k i -> do - fld <- c k i +mapContext f (Context c) = Context $ \k a i -> do + fld <- c k a i case fld of StringField str -> return $ StringField (f str) ListField _ _ -> fail $ @@ -132,12 +132,12 @@ mapContext f (Context c) = Context $ \k i -> do -- 1. A @$body$@ field -- -- 2. Metadata fields --- +-- -- 3. A @$url$@ 'urlField' -- -- 4. A @$path$@ 'pathField' -- --- 5. A @$title$@ 'titleField' +-- 5. A @$title$@ 'titleField' defaultContext :: Context String defaultContext = bodyField "body" `mappend` @@ -162,7 +162,7 @@ bodyField key = field key $ return . itemBody -------------------------------------------------------------------------------- -- | Map any field to its metadata value, if present metadataField :: Context a -metadataField = Context $ \k i -> do +metadataField = Context $ \k _ i -> do value <- getMetadataField (itemIdentifier i) k maybe empty (return . StringField) value @@ -310,6 +310,6 @@ teaserField key snapshot = field key $ \item -> do -------------------------------------------------------------------------------- missingField :: Context a -missingField = Context $ \k i -> fail $ +missingField = Context $ \k _ i -> fail $ "Missing field $" ++ k ++ "$ in context for item " ++ show (itemIdentifier i) diff --git a/src/Hakyll/Web/Template/Internal.hs b/src/Hakyll/Web/Template/Internal.hs index 4450a19..b677923 100644 --- a/src/Hakyll/Web/Template/Internal.hs +++ b/src/Hakyll/Web/Template/Internal.hs @@ -4,6 +4,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hakyll.Web.Template.Internal ( Template (..) + , TemplateKey (..) + , TemplateExpr (..) , TemplateElement (..) , readTemplate ) where @@ -14,6 +16,7 @@ import Control.Applicative (pure, (<$), (<$>), (<*>), (<|>)) 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 @@ -37,30 +40,45 @@ instance Writable Template where write _ _ = return () +-------------------------------------------------------------------------------- +instance IsString Template where + fromString = readTemplate + + +-------------------------------------------------------------------------------- +newtype TemplateKey = TemplateKey String + deriving (Binary, Show, Eq, Typeable) + + +-------------------------------------------------------------------------------- +instance IsString TemplateKey where + fromString = TemplateKey + + -------------------------------------------------------------------------------- -- | Elements of a template. data TemplateElement = Chunk String - | Key String + | Expr TemplateExpr | Escaped - | If String Template (Maybe Template) -- key, then branch, else branch - | For String Template (Maybe Template) -- key, body, separator - | Partial String -- filename + | If TemplateExpr Template (Maybe Template) -- expr, then, else + | For TemplateExpr Template (Maybe Template) -- expr, body, separator + | Partial TemplateExpr -- filename deriving (Show, Eq, Typeable) -------------------------------------------------------------------------------- instance Binary TemplateElement where put (Chunk string) = putWord8 0 >> put string - put (Key k) = putWord8 1 >> put k + put (Expr e) = putWord8 1 >> put e put (Escaped) = putWord8 2 - put (If k t f ) = putWord8 3 >> put k >> put t >> put f - put (For k b s) = putWord8 4 >> put k >> put b >> put s - put (Partial p) = putWord8 5 >> put p + 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 -> Key <$> get + 1 -> Expr <$> get 2 -> pure Escaped 3 -> If <$> get <*> get <*> get 4 -> For <$> get <*> get <*> get @@ -70,8 +88,34 @@ instance Binary TemplateElement where -------------------------------------------------------------------------------- -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.Tamplte.Internal: Error reading cached template" -------------------------------------------------------------------------------- @@ -84,7 +128,7 @@ readTemplate input = case P.parse template "" input of -------------------------------------------------------------------------------- template :: P.Parser Template template = Template <$> - (P.many1 $ chunk <|> escaped <|> conditional <|> for <|> partial <|> key) + (P.many1 $ chunk <|> escaped <|> conditional <|> for <|> partial <|> expr) -------------------------------------------------------------------------------- @@ -92,6 +136,20 @@ chunk :: P.Parser TemplateElement chunk = Chunk <$> (P.many1 $ P.noneOf "$") +-------------------------------------------------------------------------------- +expr :: P.Parser TemplateElement +expr = P.try $ do + void $ P.char '$' + e <- expr' + void $ P.char '$' + return $ Expr e + + +-------------------------------------------------------------------------------- +expr' :: P.Parser TemplateExpr +expr' = stringLiteral <|> call <|> ident + + -------------------------------------------------------------------------------- escaped :: P.Parser TemplateElement escaped = Escaped <$ (P.try $ P.string "$$") @@ -101,50 +159,63 @@ escaped = Escaped <$ (P.try $ P.string "$$") conditional :: P.Parser TemplateElement conditional = P.try $ do void $ P.string "$if(" - i <- metadataKey + e <- expr' void $ P.string ")$" thenBranch <- template elseBranch <- P.optionMaybe $ P.try (P.string "$else$") >> template void $ P.string "$endif$" - return $ If i thenBranch elseBranch + return $ If e thenBranch elseBranch -------------------------------------------------------------------------------- for :: P.Parser TemplateElement for = P.try $ do void $ P.string "$for(" - i <- metadataKey + e <- expr' void $ P.string ")$" body <- template sep <- P.optionMaybe $ P.try (P.string "$sep$") >> template void $ P.string "$endfor$" - return $ For i body sep + return $ For e body sep -------------------------------------------------------------------------------- partial :: P.Parser TemplateElement partial = P.try $ do void $ P.string "$partial(" - i <- stringLiteral + e <- expr' void $ P.string ")$" - return $ Partial i + return $ Partial e -------------------------------------------------------------------------------- -key :: P.Parser TemplateElement -key = P.try $ do - void $ P.char '$' - k <- metadataKey - void $ P.char '$' - return $ Key k +ident :: P.Parser TemplateExpr +ident = P.try $ Ident <$> key -------------------------------------------------------------------------------- -stringLiteral :: P.Parser String +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 str + return $ StringLiteral str + + +-------------------------------------------------------------------------------- +key :: P.Parser TemplateKey +key = TemplateKey <$> metadataKey -- cgit v1.2.3