Implement foreach structure

5 files changed, 78 insertions, 43 deletions

diff --git a/src/Hakyll/Web/Feed.hs b/src/Hakyll/Web/Feed.hs
index da2fd5d..d394243 100644
--- a/src/Hakyll/Web/Feed.hs
+++ b/src/Hakyll/Web/Feed.hs
@@ -97,7 +97,9 @@ renderFeed feedPath itemPath config itemContext items = do
     -- recent.
     updatedField = field "updated" $ \_ -> case items of
         []      -> return "Unknown"
-        (x : _) -> unContext itemContext' "updated" x
+        (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 8e3859a..45d1b92 100644
--- a/src/Hakyll/Web/Template.hs
+++ b/src/Hakyll/Web/Template.hs
@@ -39,13 +39,13 @@ module Hakyll.Web.Template
     , applyTemplate
     , loadAndApplyTemplate
     , applyAsTemplate
-    , applyTemplateWith
     ) where
 
 
 --------------------------------------------------------------------------------
 import           Control.Monad                (liftM)
-import           Control.Monad.Error          (MonadError(..))
+import           Control.Monad.Error          (MonadError (..))
+import           Data.List                    (intercalate)
 import           Data.Monoid                  (mappend)
 import           Prelude                      hiding (id)
 
@@ -73,13 +73,44 @@ applyTemplate :: Template                -- ^ Template
               -> Item a                  -- ^ Page
               -> Compiler (Item String)  -- ^ Resulting item
 applyTemplate tpl context item = do
-    -- Appending missingField gives better error messages
-    let context' k x = unContext (context `mappend` missingField) k x
-    body <- applyTemplateWith context' tpl item
+    body <- applyTemplate' tpl context item
     return $ itemSetBody body item
 
 
 --------------------------------------------------------------------------------
+applyTemplate' :: Template         -- ^ Template
+               -> Context a        -- ^ Context
+               -> Item a           -- ^ Page
+               -> Compiler String  -- ^ Resulting item
+applyTemplate' tpl context x = go tpl
+  where
+    context' = unContext (context `mappend` missingField)
+    go = liftM concat . mapM applyElem . unTemplate
+
+    applyElem (Chunk c)   = return c
+    applyElem Escaped     = return "$"
+    applyElem (Key k)     = context' k x >>= getString k
+    applyElem (If k t mf) = (context' k x >> 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
+        StringField _  -> fail $
+            "Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++
+            "got StringField for key " ++ show k
+        ListField c xs -> do
+            sep <- maybe (return "") go s
+            bs  <- mapM (applyTemplate' b c) xs
+            return $ intercalate sep bs
+
+    getString _ (StringField s) = return s
+    getString k (ListField _ _) = fail $
+        "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++
+        "got ListField for key " ++ show k
+
+
+--------------------------------------------------------------------------------
 -- | The following pattern is so common:
 --
 -- > tpl <- loadBody "templates/foo.html"
@@ -109,22 +140,3 @@ applyAsTemplate :: Context String          -- ^ Context
 applyAsTemplate context item =
     let tpl = readTemplate $ itemBody item
     in applyTemplate tpl context item
-
-
---------------------------------------------------------------------------------
--- | Overloaded apply template function to work in an arbitrary Monad.
-applyTemplateWith :: MonadError e m
-                  => (String -> a -> m String)
-                  -> Template -> a -> m String
-applyTemplateWith context tpl x = go tpl
-  where
-    go = liftM concat . mapM applyElem . unTemplate
-
-    applyElem (Chunk c)   = return c
-    applyElem Escaped     = return "$"
-    applyElem (Key k)     = context k x
-    applyElem (If k t mf) = (context k x >> go t) `catchError` handler
-      where
-        handler _ = case mf of
-            Nothing -> return ""
-            Just f  -> go f
diff --git a/src/Hakyll/Web/Template/Context.hs b/src/Hakyll/Web/Template/Context.hs
index 74c2e8d..7b2d920 100644
--- a/src/Hakyll/Web/Template/Context.hs
+++ b/src/Hakyll/Web/Template/Context.hs
@@ -1,10 +1,11 @@
 --------------------------------------------------------------------------------
+{-# LANGUAGE ExistentialQuantification #-}
 module Hakyll.Web.Template.Context
-    ( Context (..)
-    , mapContext
+    ( ContextField (..)
+    , Context (..)
     , field
     , constField
-    , functionField
+    , listField
 
     , defaultContext
     , teaserContext
@@ -46,8 +47,15 @@ import           Hakyll.Web.Html
 
 
 --------------------------------------------------------------------------------
+-- | Mostly for internal usage
+data ContextField
+    = StringField String
+    | forall a. ListField (Context a) [Item a]
+
+
+--------------------------------------------------------------------------------
 newtype Context a = Context
-    { unContext :: String -> Item a -> Compiler String
+    { unContext :: String -> Item a -> Compiler ContextField
     }
 
 
@@ -58,13 +66,13 @@ instance Monoid (Context a) where
 
 
 --------------------------------------------------------------------------------
-mapContext :: (String -> String) -> Context a -> Context a
-mapContext f (Context g) = Context $ \k i -> f <$> g k i
+field' :: String -> (Item a -> Compiler ContextField) -> Context a
+field' key value = Context $ \k i -> if k == key then value i else empty
 
 
 --------------------------------------------------------------------------------
 field :: String -> (Item a -> Compiler String) -> Context a
-field key value = Context $ \k i -> if k == key then value i else empty
+field key value = field' key (fmap StringField . value)
 
 
 --------------------------------------------------------------------------------
@@ -73,12 +81,8 @@ constField key = field key . const . return
 
 
 --------------------------------------------------------------------------------
-functionField :: String -> ([String] -> Item a -> Compiler String) -> Context a
-functionField name value = Context $ \k i -> case words k of
-    []              -> empty
-    (n : args)
-        | n == name -> value args i
-        | otherwise -> empty
+listField :: String -> Context a -> Compiler [Item a] -> Context b
+listField key c xs = field' key $ \_ -> fmap (ListField c) xs
 
 
 --------------------------------------------------------------------------------
@@ -91,6 +95,7 @@ defaultContext =
     titleField    "title"    `mappend`
     missingField
 
+
 --------------------------------------------------------------------------------
 -- | A context with "teaser" key which contain a teaser of the item.
 -- The item is loaded from the given snapshot (which should be saved
@@ -116,7 +121,7 @@ bodyField key = field key $ return . itemBody
 metadataField :: Context String
 metadataField = Context $ \k i -> do
     value <- getMetadataField (itemIdentifier i) k
-    maybe empty return value
+    maybe empty (return . StringField) value
 
 
 --------------------------------------------------------------------------------
@@ -135,7 +140,7 @@ pathField key = field key $ return . toFilePath . itemIdentifier
 --------------------------------------------------------------------------------
 -- | This title field takes the basename of the underlying file by default
 titleField :: String -> Context a
-titleField key = mapContext takeBaseName $ pathField key
+titleField key = field key $ return . takeBaseName . toFilePath . itemIdentifier
 
 
 --------------------------------------------------------------------------------
diff --git a/src/Hakyll/Web/Template/Internal.hs b/src/Hakyll/Web/Template/Internal.hs
index f939566..1c81670 100644
--- a/src/Hakyll/Web/Template/Internal.hs
+++ b/src/Hakyll/Web/Template/Internal.hs
@@ -37,7 +37,8 @@ data TemplateElement
     = Chunk String
     | Key String
     | Escaped
-    | If String Template (Maybe Template) -- key, then branch, else branch
+    | If String Template (Maybe Template)   -- key, then branch, else branch
+    | For String Template (Maybe Template)  -- key, body, separator
     deriving (Show, Eq, Typeable)
 
 
@@ -47,11 +48,13 @@ instance Binary TemplateElement where
     put (Key key)      = putWord8 1 >> put key
     put (Escaped)      = putWord8 2
     put (If key t f)   = putWord8 3 >> put key >> put t >> put f
+    put (For key b s)  = putWord8 4 >> put key >> put b >> put s
 
     get = getWord8 >>= \tag -> case tag of
         0 -> Chunk <$> get
         1 -> Key   <$> get
         2 -> pure Escaped
-        3 -> If <$> get <*> get <*> get
+        3 -> If  <$> get <*> get <*> get
+        4 -> For <$> get <*> get <*> get
         _ -> error $
             "Hakyll.Web.Template.Internal: Error reading cached template"
diff --git a/src/Hakyll/Web/Template/Read.hs b/src/Hakyll/Web/Template/Read.hs
index 620ce14..2dd0fc5 100644
--- a/src/Hakyll/Web/Template/Read.hs
+++ b/src/Hakyll/Web/Template/Read.hs
@@ -26,7 +26,8 @@ readTemplate input = case parse template "" input of
 
 --------------------------------------------------------------------------------
 template :: Parser Template
-template = Template <$> (many1 $ chunk <|> escaped <|> conditional <|> key)
+template = Template <$>
+    (many1 $ chunk <|> escaped <|> conditional <|> for <|> key)
 
 
 --------------------------------------------------------------------------------
@@ -52,6 +53,18 @@ conditional = try $ do
 
 
 --------------------------------------------------------------------------------
+for :: Parser TemplateElement
+for = try $ do
+    void $ string "$for("
+    i <- metadataKey
+    void $ string ")$"
+    body <- template
+    sep  <- optionMaybe $ try (string "$sep$") >> template
+    void $ string "$endfor$"
+    return $ For i body sep
+
+
+--------------------------------------------------------------------------------
 key :: Parser TemplateElement
 key = try $ do
     void $ char '$'