cf138a4 · hakyll · git.iko.soy

src/Hakyll/Core/Util/Parser.hs+1−1

compare with master

unifiedsplit

@@ -22,4 +22,4 @@ metadataKey = do

22

23--------------------------------------------------------------------------------

24reservedKeys :: [String]

25−reservedKeys = ["if", "else","endif"]

25+reservedKeys = ["if", "else", "endif", "for", "sep", "endfor"]

src/Hakyll/Web/Feed.hs+3−1

@@ -97,7 +97,9 @@ renderFeed feedPath itemPath config itemContext items = do

97 -- recent.

98 updatedField = field "updated" $ \_ -> case items of

99 [] -> return "Unknown"

100− (x : _) -> unContext itemContext' "updated" x

100+ (x : _) -> unContext itemContext' "updated" x >>= \cf -> case cf of

101+ ListField _ _ -> fail "Hakyll.Web.Feed.renderFeed: Internal error"

102+ StringField s -> return s

101

103

102

104

103--------------------------------------------------------------------------------

105--------------------------------------------------------------------------------

src/Hakyll/Web/Template.hs+36−24

@@ -39,13 +39,13 @@ module Hakyll.Web.Template

39 , applyTemplate

40 , loadAndApplyTemplate

41 , applyAsTemplate

42− , applyTemplateWith

43 ) where

42 ) where

44

43

45

44

46--------------------------------------------------------------------------------

45--------------------------------------------------------------------------------

47import Control.Monad (liftM)

46import Control.Monad (liftM)

48−import Control.Monad.Error (MonadError(..))

47+import Control.Monad.Error (MonadError (..))

48+import Data.List (intercalate)

49import Data.Monoid (mappend)

50import Prelude hiding (id)

51

@@ -73,12 +73,43 @@ applyTemplate :: Template -- ^ Template

73 -> Item a -- ^ Page

74 -> Compiler (Item String) -- ^ Resulting item

75applyTemplate tpl context item = do

76− -- Appending missingField gives better error messages

76+ body <- applyTemplate' tpl context item

77− let context' k x = unContext (context `mappend` missingField) k x

78− body <- applyTemplateWith context' tpl item

79 return $ itemSetBody body item

77 return $ itemSetBody body item

80

78

81

79

80+--------------------------------------------------------------------------------

81+applyTemplate' :: Template -- ^ Template

82+ -> Context a -- ^ Context

83+ -> Item a -- ^ Page

84+ -> Compiler String -- ^ Resulting item

85+applyTemplate' tpl context x = go tpl

86+ where

87+ context' = unContext (context `mappend` missingField)

88+ go = liftM concat . mapM applyElem . unTemplate

89+

90+ applyElem (Chunk c) = return c

91+ applyElem Escaped = return "$"

92+ applyElem (Key k) = context' k x >>= getString k

93+ applyElem (If k t mf) = (context' k x >> go t) `catchError` handler

94+ where

95+ handler _ = case mf of

96+ Nothing -> return ""

97+ Just f -> go f

98+ applyElem (For k b s) = context' k x >>= \cf -> case cf of

99+ StringField _ -> fail $

100+ "Hakyll.Web.Template.applyTemplateWith: expected ListField but " ++

101+ "got StringField for key " ++ show k

102+ ListField c xs -> do

103+ sep <- maybe (return "") go s

104+ bs <- mapM (applyTemplate' b c) xs

105+ return $ intercalate sep bs

106+

107+ getString _ (StringField s) = return s

108+ getString k (ListField _ _) = fail $

109+ "Hakyll.Web.Template.applyTemplateWith: expected StringField but " ++

110+ "got ListField for key " ++ show k

111+

112+

82--------------------------------------------------------------------------------

113--------------------------------------------------------------------------------

83-- | The following pattern is so common:

114-- | The following pattern is so common:

84--

115--

@@ -109,22 +140,3 @@ applyAsTemplate :: Context String -- ^ Context

109applyAsTemplate context item =

140applyAsTemplate context item =

110 let tpl = readTemplate $ itemBody item

141 let tpl = readTemplate $ itemBody item

111 in applyTemplate tpl context item

142 in applyTemplate tpl context item

112−

113−

114−--------------------------------------------------------------------------------

115−-- | Overloaded apply template function to work in an arbitrary Monad.

116−applyTemplateWith :: MonadError e m

117− => (String -> a -> m String)

118− -> Template -> a -> m String

119−applyTemplateWith context tpl x = go tpl

120− where

121− go = liftM concat . mapM applyElem . unTemplate

122−

123− applyElem (Chunk c) = return c

124− applyElem Escaped = return "$"

125− applyElem (Key k) = context k x

126− applyElem (If k t mf) = (context k x >> go t) `catchError` handler

127− where

128− handler _ = case mf of

129− Nothing -> return ""

130− Just f -> go f

src/Hakyll/Web/Template/Context.hs+20−15

@@ -1,10 +1,11 @@

1--------------------------------------------------------------------------------

2+{-# LANGUAGE ExistentialQuantification #-}

2module Hakyll.Web.Template.Context

3module Hakyll.Web.Template.Context

3− ( Context (..)

4+ ( ContextField (..)

4− , mapContext

5+ , Context (..)

5 , field

6 , field

6 , constField

7 , constField

7− , functionField

8+ , listField

8

9

9 , defaultContext

10 , defaultContext

10 , teaserContext

11 , teaserContext

@@ -45,9 +46,16 @@ import Hakyll.Core.Util.String (splitAll, needlePrefix)

45import Hakyll.Web.Html

46import Hakyll.Web.Html

46

47

48

49+--------------------------------------------------------------------------------

50+-- | Mostly for internal usage

51+data ContextField

52+ = StringField String

53+ | forall a. ListField (Context a) [Item a]

54+

55+

48--------------------------------------------------------------------------------

56--------------------------------------------------------------------------------

49newtype Context a = Context

57newtype Context a = Context

50− { unContext :: String -> Item a -> Compiler String

58+ { unContext :: String -> Item a -> Compiler ContextField

51 }

59 }

52

60

53

61

@@ -58,13 +66,13 @@ instance Monoid (Context a) where

58

66

59

67

60--------------------------------------------------------------------------------

68--------------------------------------------------------------------------------

61−mapContext :: (String -> String) -> Context a -> Context a

69+field' :: String -> (Item a -> Compiler ContextField) -> Context a

62−mapContext f (Context g) = Context $ \k i -> f <$> g k i

70+field' key value = Context $ \k i -> if k == key then value i else empty

63

71

64

72

65--------------------------------------------------------------------------------

73--------------------------------------------------------------------------------

66field :: String -> (Item a -> Compiler String) -> Context a

74field :: String -> (Item a -> Compiler String) -> Context a

67−field key value = Context $ \k i -> if k == key then value i else empty

75+field key value = field' key (fmap StringField . value)

68

76

69

77

70--------------------------------------------------------------------------------

78--------------------------------------------------------------------------------

@@ -73,12 +81,8 @@ constField key = field key . const . return

73

81

74

82

75--------------------------------------------------------------------------------

83--------------------------------------------------------------------------------

76−functionField :: String -> ([String] -> Item a -> Compiler String) -> Context a

84+listField :: String -> Context a -> Compiler [Item a] -> Context b

77−functionField name value = Context $ \k i -> case words k of

85+listField key c xs = field' key $ \_ -> fmap (ListField c) xs

78− [] -> empty

79− (n : args)

80− | n == name -> value args i

81− | otherwise -> empty

82

86

83

87

84--------------------------------------------------------------------------------

88--------------------------------------------------------------------------------

@@ -91,6 +95,7 @@ defaultContext =

91 titleField "title" `mappend`

95 titleField "title" `mappend`

92 missingField

96 missingField

93

97

98+

94--------------------------------------------------------------------------------

99--------------------------------------------------------------------------------

95-- | A context with "teaser" key which contain a teaser of the item.

100-- | A context with "teaser" key which contain a teaser of the item.

96-- The item is loaded from the given snapshot (which should be saved

101-- The item is loaded from the given snapshot (which should be saved

@@ -116,7 +121,7 @@ bodyField key = field key $ return . itemBody

116metadataField :: Context String

121metadataField :: Context String

117metadataField = Context $ \k i -> do

122metadataField = Context $ \k i -> do

118 value <- getMetadataField (itemIdentifier i) k

123 value <- getMetadataField (itemIdentifier i) k

119− maybe empty return value

124+ maybe empty (return . StringField) value

120

125

121

126

122--------------------------------------------------------------------------------

127--------------------------------------------------------------------------------

@@ -135,7 +140,7 @@ pathField key = field key $ return . toFilePath . itemIdentifier

135--------------------------------------------------------------------------------

140--------------------------------------------------------------------------------

136-- | This title field takes the basename of the underlying file by default

141-- | This title field takes the basename of the underlying file by default

137titleField :: String -> Context a

142titleField :: String -> Context a

138−titleField key = mapContext takeBaseName $ pathField key

143+titleField key = field key $ return . takeBaseName . toFilePath . itemIdentifier

139

144

140

145

141--------------------------------------------------------------------------------

146--------------------------------------------------------------------------------

src/Hakyll/Web/Template/Internal.hs+5−2

@@ -37,7 +37,8 @@ data TemplateElement

37 = Chunk String

38 | Key String

39 | Escaped

40− | If String Template (Maybe Template) -- key, then branch, else branch

40+ | If String Template (Maybe Template) -- key, then branch, else branch

41+ | For String Template (Maybe Template) -- key, body, separator

41 deriving (Show, Eq, Typeable)

42 deriving (Show, Eq, Typeable)

42

43

44

@@ -47,11 +48,13 @@ instance Binary TemplateElement where

47 put (Key key) = putWord8 1 >> put key

48 put (Key key) = putWord8 1 >> put key

48 put (Escaped) = putWord8 2

49 put (Escaped) = putWord8 2

49 put (If key t f) = putWord8 3 >> put key >> put t >> put f

50 put (If key t f) = putWord8 3 >> put key >> put t >> put f

51+ put (For key b s) = putWord8 4 >> put key >> put b >> put s

50

52

51 get = getWord8 >>= \tag -> case tag of

53 get = getWord8 >>= \tag -> case tag of

52 0 -> Chunk <$> get

54 0 -> Chunk <$> get

53 1 -> Key <$> get

55 1 -> Key <$> get

54 2 -> pure Escaped

56 2 -> pure Escaped

57+ 3 -> If <$> get <*> get <*> get

55− 3 -> If <$> get <*> get <*> get

58+ 4 -> For <$> get <*> get <*> get

56 _ -> error $

59 _ -> error $

57 "Hakyll.Web.Template.Internal: Error reading cached template"

60 "Hakyll.Web.Template.Internal: Error reading cached template"

src/Hakyll/Web/Template/Read.hs+14−1

@@ -26,7 +26,8 @@ readTemplate input = case parse template "" input of

26

27--------------------------------------------------------------------------------

28template :: Parser Template

29+template = Template <$>

29−template = Template <$> (many1 $ chunk <|> escaped <|> conditional <|> key)

30+ (many1 $ chunk <|> escaped <|> conditional <|> for <|> key)

30

31

32

32--------------------------------------------------------------------------------

33--------------------------------------------------------------------------------

@@ -51,6 +52,18 @@ conditional = try $ do

51 return $ If i thenBranch elseBranch

52 return $ If i thenBranch elseBranch

52

53

54

55+--------------------------------------------------------------------------------

56+for :: Parser TemplateElement

57+for = try $ do

58+ void $ string "$for("

59+ i <- metadataKey

60+ void $ string ")$"

61+ body <- template

62+ sep <- optionMaybe $ try (string "$sep$") >> template

63+ void $ string "$endfor$"

64+ return $ For i body sep

65+

66+

54--------------------------------------------------------------------------------

67--------------------------------------------------------------------------------

55key :: Parser TemplateElement

68key :: Parser TemplateElement

56key = try $ do

69key = try $ do

tests/Hakyll/Web/Template/Context/Tests.hs+6−1

@@ -51,4 +51,9 @@ testContextDone :: Store -> Provider -> Identifier -> String

51testContextDone store provider identifier key context =

52 testCompilerDone store provider identifier $ do

53 item <- getResourceBody

54− unContext context key item

54+ cf <- unContext context key item

55+ case cf of

56+ StringField str -> return str

57+ ListField _ _ -> error $

58+ "Hakyll.Web.Template.Context.Tests.testContextDone: " ++

59+ "Didn't expect ListField"

tests/Hakyll/Web/Template/Tests.hs+9−2

@@ -13,6 +13,7 @@ import Test.HUnit (Assertion, (@=?), (@?=))

13

14

15--------------------------------------------------------------------------------

16+import Hakyll.Core.Compiler

16import Hakyll.Core.Item

17import Hakyll.Core.Item

17import Hakyll.Core.Provider

18import Hakyll.Core.Provider

18import Hakyll.Web.Pandoc

19import Hakyll.Web.Pandoc

@@ -43,6 +44,8 @@ case01 = do

43 item <- testCompilerDone store provider "example.md" $

44 item <- testCompilerDone store provider "example.md" $

44 pandocCompiler >>= applyTemplate (itemBody tpl) testContext

45 pandocCompiler >>= applyTemplate (itemBody tpl) testContext

45

46

47+ writeFile "foo" (itemBody item)

48+

46 out @=? itemBody item

49 out @=? itemBody item

47 cleanTestEnv

50 cleanTestEnv

48

51

@@ -50,9 +53,13 @@ case01 = do

50--------------------------------------------------------------------------------

53--------------------------------------------------------------------------------

51testContext :: Context String

54testContext :: Context String

52testContext = mconcat

55testContext = mconcat

53− [ functionField "echo" (\args _ -> return $ unwords args)

56+ [ defaultContext

54− , defaultContext

57+ , listField "authors" (bodyField "name") $ do

58+ n1 <- makeItem "Jan"

59+ n2 <- makeItem "Piet"

60+ return [n1, n2]

55 ]

61 ]

62+ where

56

63

57

64

58--------------------------------------------------------------------------------

65--------------------------------------------------------------------------------

tests/data/template.html+12−1

@@ -1,16 +1,27 @@

1<div>

2 I'm so rich I have $$3.

3− $echo test$

3+

4 $if(body)$

5 I have body

6 $else$

7 or no

8 $endif$

9+

9 $if(unbound)$

10 $if(unbound)$

10 should not be printed

11 should not be printed

11 $endif$

12 $endif$

13+

12 $if(body)$

14 $if(body)$

13 should be printed

15 should be printed

14 $endif$

16 $endif$

17+

18+ <ul>

19+ $for(authors)$

20+ <li>$name$</li>

21+ $endfor$

22+ </ul>

23+

24+ $for(authors)$$name$$sep$, $endfor$

25+

15 $body$

26 $body$

16</div>

27</div>

tests/data/template.html.out+14−1

@@ -1,12 +1,25 @@

1<div>

2 I'm so rich I have $3.

3− test

3+

4

5 I have body

6

7+

7

8

9+

8

10

9 should be printed

11 should be printed

10

12

13+

14+ <ul>

15+

16+ <li>Jan</li>

17+

18+ <li>Piet</li>

19+

20+ </ul>

21+

22+ Jan, Piet

23+

11 <p>This is an example.</p>

24 <p>This is an example.</p>

12</div>

25</div>