From cf138a415b0fbfa5153deec693f1310547f359b2 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 6 May 2013 23:32:25 +0200 Subject: Implement foreach structure --- src/Hakyll/Web/Feed.hs | 4 ++- src/Hakyll/Web/Template.hs | 60 ++++++++++++++++++++++--------------- src/Hakyll/Web/Template/Context.hs | 35 ++++++++++++---------- src/Hakyll/Web/Template/Internal.hs | 7 +++-- src/Hakyll/Web/Template/Read.hs | 15 +++++++++- 5 files changed, 78 insertions(+), 43 deletions(-) (limited to 'src/Hakyll/Web') 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,12 +73,43 @@ 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: -- @@ -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 @@ -45,9 +46,16 @@ import Hakyll.Core.Util.String (splitAll, needlePrefix) 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) -------------------------------------------------------------------------------- @@ -51,6 +52,18 @@ conditional = try $ do return $ If i thenBranch elseBranch +-------------------------------------------------------------------------------- +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 -- cgit v1.2.3