summaryrefslogtreecommitdiff
path: root/src/Hakyll
diff options
context:
space:
mode:
Diffstat (limited to 'src/Hakyll')
-rw-r--r--src/Hakyll/Core/Util/Parser.hs2
-rw-r--r--src/Hakyll/Web/Feed.hs4
-rw-r--r--src/Hakyll/Web/Template.hs60
-rw-r--r--src/Hakyll/Web/Template/Context.hs35
-rw-r--r--src/Hakyll/Web/Template/Internal.hs7
-rw-r--r--src/Hakyll/Web/Template/Read.hs15
6 files changed, 79 insertions, 44 deletions
diff --git a/src/Hakyll/Core/Util/Parser.hs b/src/Hakyll/Core/Util/Parser.hs
index afa72c1..7fb3b50 100644
--- a/src/Hakyll/Core/Util/Parser.hs
+++ b/src/Hakyll/Core/Util/Parser.hs
@@ -22,4 +22,4 @@ metadataKey = do
--------------------------------------------------------------------------------
reservedKeys :: [String]
-reservedKeys = ["if", "else","endif"]
+reservedKeys = ["if", "else", "endif", "for", "sep", "endfor"]
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 '$'
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 07:06:27 +0000