Better functions in templates

hakyll.cabal

@@ -163,7 +163,7 @@ Library
     pandoc-citeproc >= 0.4    && < 0.5,
     parsec          >= 3.0    && < 3.2,
     process         >= 1.0    && < 1.3,
-    random          >= 1.0    && < 1.1,
+    random          >= 1.0    && < 1.2,
     regex-base      >= 0.93   && < 0.94,
     regex-tdfa      >= 1.1    && < 1.3,
     tagsoup         >= 0.13.1 && < 0.14,
@@ -250,7 +250,7 @@ Test-suite hakyll-tests
     pandoc-citeproc >= 0.4    && < 0.5,
     parsec          >= 3.0    && < 3.2,
     process         >= 1.0    && < 1.3,
-    random          >= 1.0    && < 1.1,
+    random          >= 1.0    && < 1.2,
     regex-base      >= 0.93   && < 0.94,
     regex-tdfa      >= 1.1    && < 1.3,
     tagsoup         >= 0.13.1 && < 0.14,

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
 
 

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
 

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 (Expr e) = applyExpr e >>= getString e
+
     applyElem Escaped = return "$"
 
-    applyElem (Key k) = context' k x >>= getString k
-
-    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
 
 
 --------------------------------------------------------------------------------

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)

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

tests/Hakyll/Web/Template/Context/Tests.hs

@@ -51,7 +51,7 @@ testContextDone :: Store -> Provider -> Identifier -> String
 testContextDone store provider identifier key context =
     testCompilerDone store provider identifier $ do
         item <- getResourceBody
-        cf   <- unContext context key item
+        cf   <- unContext context key [] item
         case cf of
             StringField str -> return str
             ListField _ _   -> error $

tests/Hakyll/Web/Template/Tests.hs

@@ -76,4 +76,4 @@ testApplyJoinTemplateList = do
   where
     i1  = Item "item1" "Hello"
     i2  = Item "item2" "World"
-    tpl = Template [Chunk "<b>", Key "body", Chunk "</b>"]
+    tpl = Template [Chunk "<b>", Expr (Ident "body"), Chunk "</b>"]

tests/data/template.html

@@ -1,7 +1,8 @@
 <div>
     I'm so rich I have $$3.
 
-    $rev foo$
+    $rev("foo")$
+    $rev(rev("foo"))$
 
     $if(body)$
     I have body

tests/data/template.html.out

@@ -2,6 +2,7 @@
     I'm so rich I have $3.
 
     oof
+    foo
 
     
     I have body