diff options
| -rw-r--r-- | src/Hakyll/Core/Util/Parser.hs | 2 | ||||
| -rw-r--r-- | src/Hakyll/Web/Feed.hs | 4 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template.hs | 60 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template/Context.hs | 35 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template/Internal.hs | 7 | ||||
| -rw-r--r-- | src/Hakyll/Web/Template/Read.hs | 15 | ||||
| -rw-r--r-- | tests/Hakyll/Web/Template/Context/Tests.hs | 7 | ||||
| -rw-r--r-- | tests/Hakyll/Web/Template/Tests.hs | 11 | ||||
| -rw-r--r-- | tests/data/template.html | 13 | ||||
| -rw-r--r-- | tests/data/template.html.out | 15 |
10 files changed, 120 insertions, 49 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 '$' diff --git a/tests/Hakyll/Web/Template/Context/Tests.hs b/tests/Hakyll/Web/Template/Context/Tests.hs index 5533c71..627624f 100644 --- a/tests/Hakyll/Web/Template/Context/Tests.hs +++ b/tests/Hakyll/Web/Template/Context/Tests.hs @@ -51,4 +51,9 @@ testContextDone :: Store -> Provider -> Identifier -> String testContextDone store provider identifier key context = testCompilerDone store provider identifier $ do item <- getResourceBody - unContext context key item + cf <- unContext context key item + case cf of + StringField str -> return str + ListField _ _ -> error $ + "Hakyll.Web.Template.Context.Tests.testContextDone: " ++ + "Didn't expect ListField" diff --git a/tests/Hakyll/Web/Template/Tests.hs b/tests/Hakyll/Web/Template/Tests.hs index b96cfa5..1d80a06 100644 --- a/tests/Hakyll/Web/Template/Tests.hs +++ b/tests/Hakyll/Web/Template/Tests.hs @@ -13,6 +13,7 @@ import Test.HUnit (Assertion, (@=?), (@?=)) -------------------------------------------------------------------------------- +import Hakyll.Core.Compiler import Hakyll.Core.Item import Hakyll.Core.Provider import Hakyll.Web.Pandoc @@ -43,6 +44,8 @@ case01 = do item <- testCompilerDone store provider "example.md" $ pandocCompiler >>= applyTemplate (itemBody tpl) testContext + writeFile "foo" (itemBody item) + out @=? itemBody item cleanTestEnv @@ -50,9 +53,13 @@ case01 = do -------------------------------------------------------------------------------- testContext :: Context String testContext = mconcat - [ functionField "echo" (\args _ -> return $ unwords args) - , defaultContext + [ defaultContext + , listField "authors" (bodyField "name") $ do + n1 <- makeItem "Jan" + n2 <- makeItem "Piet" + return [n1, n2] ] + where -------------------------------------------------------------------------------- diff --git a/tests/data/template.html b/tests/data/template.html index 6f668ee..22e5ddd 100644 --- a/tests/data/template.html +++ b/tests/data/template.html @@ -1,16 +1,27 @@ <div> I'm so rich I have $$3. - $echo test$ + $if(body)$ I have body $else$ or no $endif$ + $if(unbound)$ should not be printed $endif$ + $if(body)$ should be printed $endif$ + + <ul> + $for(authors)$ + <li>$name$</li> + $endfor$ + </ul> + + $for(authors)$$name$$sep$, $endfor$ + $body$ </div> diff --git a/tests/data/template.html.out b/tests/data/template.html.out index 5c201e2..8047b0d 100644 --- a/tests/data/template.html.out +++ b/tests/data/template.html.out @@ -1,12 +1,25 @@ <div> I'm so rich I have $3. - test + I have body + + should be printed + + <ul> + + <li>Jan</li> + + <li>Piet</li> + + </ul> + + Jan, Piet + <p>This is an example.</p> </div> |