4cb6f92 · hakyll · git.iko.soy

git.iko.soy/hakyll

on master help sign in

Rewrite template application

4cb6f92Jasper Van der Jeugt14 years ago

src/Hakyll/Core/Compiler.hs−7

compare with master

unifiedsplit

@@ -108,7 +108,6 @@ module Hakyll.Core.Compiler

108 , cached

109 , unsafeCompiler

110 , traceShowCompiler

111− , mapCompiler

112 , timedCompiler

111 , timedCompiler

113 , byPattern

112 , byPattern

114 , byExtension

113 , byExtension

@@ -328,12 +327,6 @@ traceShowCompiler = fromJob $ \x -> CompilerM $ do

328 report logger $ show x

327 report logger $ show x

329 return x

328 return x

330

329

331−-- | Map over a compiler

332−--

333−mapCompiler :: Compiler a b

334− -> Compiler [a] [b]

335−mapCompiler (Compiler d j) = Compiler d $ mapM j

336−

337-- | Log and time a compiler

330-- | Log and time a compiler

338--

331--

339timedCompiler :: String -- ^ Message

332timedCompiler :: String -- ^ Message

src/Hakyll/Core/Compiler/Internal.hs+6

@@ -38,6 +38,7 @@ import Hakyll.Core.Logger

38import Hakyll.Core.ResourceProvider

39import Hakyll.Core.Routes

40import Hakyll.Core.Store

41+import Hakyll.Core.Util.Arrow

43--------------------------------------------------------------------------------

44--------------------------------------------------------------------------------

@@ -138,6 +139,11 @@ instance ArrowChoice Compiler where

138 Right r -> Right <$> return r

139 Right r -> Right <$> return r

139

140

141

142+--------------------------------------------------------------------------------

143+instance ArrowMap Compiler where

144+ mapA (Compiler d j) = Compiler d $ mapM j

145+

146+

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

147--------------------------------------------------------------------------------

142-- | Run a compiler, yielding the resulting target

148-- | Run a compiler, yielding the resulting target

143runCompilerJob :: Compiler () a -- ^ Compiler to run

149runCompilerJob :: Compiler () a -- ^ Compiler to run

src/Hakyll/Core/Util/Arrow.hs+26−11

@@ -1,25 +1,40 @@

1+--------------------------------------------------------------------------------

1-- | Various arrow utility functions

2-- | Various arrow utility functions

2−--

3module Hakyll.Core.Util.Arrow

4+ ( ArrowMap (..)

4− ( constA

5+ , constA

5 , sequenceA

6 , sequenceA

6 , unitA

7 , unitA

7 ) where

8 ) where

9−import Control.Arrow (Arrow, (&&&), arr, (>>^))

11+--------------------------------------------------------------------------------

12+import Control.Arrow (Arrow, ArrowChoice, arr, (&&&), (>>^))

13+

14+

15+--------------------------------------------------------------------------------

16+-- | Additional arrow typeclass for performance reasons.

17+class ArrowChoice a => ArrowMap a where

18+ mapA :: a b c -> a [b] [c]

19+

20+

21+--------------------------------------------------------------------------------

22+instance ArrowMap (->) where

23+ mapA = map

24+

25+

26+--------------------------------------------------------------------------------

11−constA :: Arrow a

27+constA :: Arrow a => c -> a b c

12− => c

13− -> a b c

14constA = arr . const

28constA = arr . const

30+

31+--------------------------------------------------------------------------------

16−sequenceA :: Arrow a

32+sequenceA :: Arrow a => [a b c] -> a b [c]

17− => [a b c]

18− -> a b [c]

19sequenceA = foldr reduce $ constA []

33sequenceA = foldr reduce $ constA []

20 where

34 where

21 reduce xa la = xa &&& la >>^ arr (uncurry (:))

35 reduce xa la = xa &&& la >>^ arr (uncurry (:))

37+

38+--------------------------------------------------------------------------------

23−unitA :: Arrow a

39+unitA :: Arrow a => a b ()

24− => a b ()

25unitA = constA ()

40unitA = constA ()

src/Hakyll/Web/Feed.hs+2−2

@@ -62,7 +62,7 @@ createFeed :: Template -- ^ Feed template

62 -> [Page String] -- ^ Items to include

63 -> String -- ^ Resulting feed

64createFeed feedTemplate itemTemplate url configuration items =

65− pageBody $ applyTemplate feedTemplate

65+ pageBody $ applyTemplateToPage feedTemplate

66 $ trySetField "updated" updated

67 $ trySetField "title" (feedTitle configuration)

68 $ trySetField "description" (feedDescription configuration)

@@ -73,7 +73,7 @@ createFeed feedTemplate itemTemplate url configuration items =

73 $ fromBody body

74 where

75 -- Preprocess items

76− items' = flip map items $ applyTemplate itemTemplate

76+ items' = flip map items $ applyTemplateToPage itemTemplate

77 . trySetField "root" (feedRoot configuration)

79 -- Body: concatenated items

src/Hakyll/Web/Page/List.hs+2−2

@@ -55,8 +55,8 @@ pageListCompiler sort template =

55--

56applyTemplateToList :: Identifier Template

57 -> Compiler [Page String] [Page String]

58−applyTemplateToList identifier =

58+applyTemplateToList identifier = require identifier $

59− require identifier $ \posts template -> map (applyTemplate template) posts

59+ \posts template -> map (applyTemplateToPage template) posts

61-- | Concatenate the bodies of a page list

62--

src/Hakyll/Web/Tags.hs+3−3

@@ -65,6 +65,7 @@ import Hakyll.Web.Urls

65import Hakyll.Core.Writable

66import Hakyll.Core.Identifier

67import Hakyll.Core.Compiler

68+import Hakyll.Core.Util.Arrow

68import Hakyll.Core.Util.String

69import Hakyll.Core.Util.String

70-- | Data about tags

71-- | Data about tags

@@ -128,8 +129,7 @@ renderTags :: (String -> Identifier (Page a))

128 -- ^ Tag cloud renderer

129 -- ^ Tag cloud renderer

129renderTags makeUrl makeItem concatItems = proc (Tags tags) -> do

130renderTags makeUrl makeItem concatItems = proc (Tags tags) -> do

130 -- In tags' we create a list: [((tag, route), count)]

131 -- In tags' we create a list: [((tag, route), count)]

131− tags' <- mapCompiler ((id &&& (getRouteFor <<^ makeUrl)) *** arr length)

132+ tags' <- mapA ((id &&& (getRouteFor <<^ makeUrl)) *** arr length) -< tags

132− -< tags

133

134 let -- Absolute frequencies of the pages

135 freqs = map snd tags'

@@ -195,7 +195,7 @@ renderTagsFieldWith tags destination makeUrl =

195 -- Compiler creating a comma-separated HTML string for a list of tags

196 renderTags' :: Compiler [String] String

197 renderTags' = arr (map $ id &&& makeUrl)

198− >>> mapCompiler (id *** getRouteFor)

198+ >>> mapA (id *** getRouteFor)

199 >>> arr (map $ uncurry renderLink)

200 >>> arr (renderHtml . mconcat . intersperse ", " . catMaybes)

201

src/Hakyll/Web/Template.hs+53−47

@@ -58,66 +58,78 @@

58-- > <a href="/about.html"> About

59-- > <a href="/code.html"> Code

60-- > #{body}

61−--

61+{-# LANGUAGE Arrows #-}

62+{-# LANGUAGE ScopedTypeVariables #-}

62module Hakyll.Web.Template

63module Hakyll.Web.Template

63 ( Template

64 ( Template

64 , applyTemplate

65 , applyTemplate

65− , applyTemplateWith

66+ , applyTemplateToPage

66 , applySelf

67 , applySelf

67 , templateCompiler

68 , templateCompiler

68 , templateCompilerWith

69 , templateCompilerWith

69 , applyTemplateCompiler

70 , applyTemplateCompiler

70− , applyTemplateCompilerWith

71 ) where

73−import Control.Arrow

74−import Data.Maybe (fromMaybe)

75−import System.FilePath (takeExtension)

76−import qualified Data.Map as M

74+--------------------------------------------------------------------------------

75+import Control.Arrow

76+import Control.Category (id)

77+import qualified Data.Map as M

78+import Data.Maybe (fromMaybe)

79+import Prelude hiding (id)

80+import System.FilePath (takeExtension)

78−import Text.Hamlet (HamletSettings, defaultHamletSettings)

81+import Text.Hamlet (HamletSettings,

82+ defaultHamletSettings)

84+--------------------------------------------------------------------------------

80−import Hakyll.Core.Compiler

85+import Hakyll.Core.Compiler

81−import Hakyll.Core.Identifier

86+import Hakyll.Core.Identifier

82−import Hakyll.Web.Template.Internal

87+import Hakyll.Core.Util.Arrow

83−import Hakyll.Web.Template.Read

84−import Hakyll.Web.Page.Internal

88+import Hakyll.Web.Page.Internal

89+import Hakyll.Web.Template.Internal

90+import Hakyll.Web.Template.Read

86−-- | Substitutes @$identifiers@ in the given @Template@ by values from the given

87−-- "Page". When a key is not found, it is left as it is.

88−--

89−applyTemplate :: Template -> Page String -> Page String

90−applyTemplate = applyTemplateWith defaultMissingHandler

92−-- | Default solution if a key is missing: render it again

93+--------------------------------------------------------------------------------

93−defaultMissingHandler :: String -> String

94+applyTemplate :: forall a b. (ArrowChoice a, ArrowMap a)

94−defaultMissingHandler k = "$" ++ k ++ "$"

95+ => a (String, b) String

96+ -> a (Template, b) String

97+applyTemplate field =

98+ arr (\(tpl, x) -> [(e, x) | e <- unTemplate tpl]) >>>

99+ mapA applyElement >>^ concat

100+ where

101+ applyElement :: a (TemplateElement, b) String

102+ applyElement = unElement >>> (id ||| field)

103

96−-- | A version of 'applyTemplate' which allows you to give a fallback option,

104+ unElement :: a (TemplateElement, b) (Either String (String, b))

97−-- which can produce the value for a key if it is missing.

105+ unElement = arr $ \(e, x) -> case e of

98−--

106+ Chunk c -> Left c

99−applyTemplateWith :: (String -> String) -- ^ Fallback if key missing

107+ Escaped -> Left "$"

100− -> Template -- ^ Template to apply

108+ Key k -> Right (k, x)

101− -> Page String -- ^ Input page

109+

102− -> Page String -- ^ Resulting page

110+

103−applyTemplateWith missing template page =

111+--------------------------------------------------------------------------------

104− fmap (const $ substitute =<< unTemplate template) page

112+-- | TODO: Remove

113+applyTemplateToPage :: Template -> Page String -> Page String

114+applyTemplateToPage tpl page =

115+ fmap (const $ applyTemplate pageField (tpl, page)) page

105 where

116 where

106− map' = toMap page

117+ pageField (k, p) = fromMaybe ("$" ++ k ++ "$") $ M.lookup k $ toMap p

107− substitute (Chunk chunk) = chunk

118+{-# DEPRECATED applyTemplateToPage "Use applyTemplate" #-}

108− substitute (Key key) = fromMaybe (missing key) $ M.lookup key map'

119+

109− substitute (Escaped) = "$"

110

120

121+--------------------------------------------------------------------------------

111-- | Apply a page as it's own template. This is often very useful to fill in

122-- | Apply a page as it's own template. This is often very useful to fill in

112-- certain keys like @$root@ and @$url@.

123-- certain keys like @$root@ and @$url@.

113−--

114applySelf :: Page String -> Page String

124applySelf :: Page String -> Page String

115−applySelf page = applyTemplate (readTemplate $ pageBody page) page

125+applySelf page = applyTemplateToPage (readTemplate $ pageBody page) page

126+{-# DEPRECATED applySelf "Use applyTemplate" #-}

127+

116

128

129+--------------------------------------------------------------------------------

117-- | Read a template. If the extension of the file we're compiling is

130-- | Read a template. If the extension of the file we're compiling is

118-- @.hml@ or @.hamlet@, it will be considered as a Hamlet template, and parsed

131-- @.hml@ or @.hamlet@, it will be considered as a Hamlet template, and parsed

119-- as such.

132-- as such.

120−--

121templateCompiler :: Compiler () Template

133templateCompiler :: Compiler () Template

122templateCompiler = templateCompilerWith defaultHamletSettings

134templateCompiler = templateCompilerWith defaultHamletSettings

123

135

@@ -135,15 +147,9 @@ templateCompilerWith settings =

135 -- Hakyll template

147 -- Hakyll template

136 else readTemplate string

148 else readTemplate string

137

149

150+

151+--------------------------------------------------------------------------------

138applyTemplateCompiler :: Identifier Template -- ^ Template

152applyTemplateCompiler :: Identifier Template -- ^ Template

139 -> Compiler (Page String) (Page String) -- ^ Compiler

153 -> Compiler (Page String) (Page String) -- ^ Compiler

140−applyTemplateCompiler = applyTemplateCompilerWith defaultMissingHandler

154+applyTemplateCompiler identifier = require identifier $

141−

155+ flip applyTemplateToPage

142−-- | A version of 'applyTemplateCompiler' which allows you to pass a function

143−-- which is called for a key when it is missing.

144−--

145−applyTemplateCompilerWith :: (String -> String)

146− -> Identifier Template

147− -> Compiler (Page String) (Page String)

148−applyTemplateCompilerWith missing identifier =

149− require identifier (flip $ applyTemplateWith missing)