@@ -1,9 +1,32 @@
1+-- | This module provides 'Context's which are used to expand expressions in
2+-- templates and allow for arbitrary customisation.
4+-- 'Template's define a small expression DSL which consists of strings,
5+-- identifiers and function application. There is no type system, every value is
6+-- a string and on the top level they get substituted verbatim into the page.
8+-- For example, you can build a context that contains
10+-- > … <> functionField "concat" (const . concat) <> …
12+-- which will allow you to use the @concat@ identifier as a function that takes
13+-- arbitrarily many stings and concatenates them to a new string:
15+-- > $partial(concat("templates/categories/", category))$
17+-- This will evaluate the @category@ field in the context, then prepend he path,
18+-- and include the referenced file as a template.
1--------------------------------------------------------------------------------
21--------------------------------------------------------------------------------
2{-# LANGUAGE ExistentialQuantification #-}
23{-# LANGUAGE ExistentialQuantification #-}
24+{-# LANGUAGE RankNTypes #-}
3module Hakyll.Web.Template.Context
25module Hakyll.Web.Template.Context
4 ( ContextField (..)
26 ( ContextField (..)
5 , Context (..)
27 , Context (..)
7 , constField
30 , constField
8 , listField
31 , listField
9 , listFieldWith
32 , listFieldWith
@@ -16,43 +39,49 @@ module Hakyll.Web.Template.Context
16 , urlField
39 , urlField
17 , pathField
40 , pathField
18 , titleField
41 , titleField
19 , dateField
43 , dateField
20 , dateFieldWith
44 , dateFieldWith
21 , getItemUTC
45 , getItemUTC
46+ , getItemModificationTime
22 , modificationTimeField
47 , modificationTimeField
23 , modificationTimeFieldWith
48 , modificationTimeFieldWith
24 , teaserField
49 , teaserField
50+ , teaserFieldWithSeparator
25 , missingField
51 , missingField
29--------------------------------------------------------------------------------
56--------------------------------------------------------------------------------
30−import Control.Applicative (Alternative (..), (<$>))
57+import Control.Applicative (Alternative (..))
31import Control.Monad (msum)
58import Control.Monad (msum)
32−import Data.List (intercalate)
59+import Data.List (intercalate, tails)
33−import qualified Data.Map as M
60+#if MIN_VERSION_base(4,9,0)
34−import Data.Monoid (Monoid (..))
61+import Data.Semigroup (Semigroup (..))
35import Data.Time.Clock (UTCTime (..))
63import Data.Time.Clock (UTCTime (..))
36−import Data.Time.Format (formatTime, parseTime)
64+import Data.Time.Format (formatTime)
37−import System.FilePath (takeBaseName, splitDirectories)
65+import qualified Data.Time.Format as TF
38−import System.Locale (TimeLocale, defaultTimeLocale)
66+import Data.Time.Locale.Compat (TimeLocale, defaultTimeLocale)
41−--------------------------------------------------------------------------------
42import Hakyll.Core.Compiler
67import Hakyll.Core.Compiler
43import Hakyll.Core.Compiler.Internal
68import Hakyll.Core.Compiler.Internal
44import Hakyll.Core.Identifier
69import Hakyll.Core.Identifier
45import Hakyll.Core.Item
70import Hakyll.Core.Item
46import Hakyll.Core.Metadata
71import Hakyll.Core.Metadata
47import Hakyll.Core.Provider
72import Hakyll.Core.Provider
48−import Hakyll.Core.Util.String (splitAll, needlePrefix)
73+import Hakyll.Core.Util.String (needlePrefix, splitAll)
49import Hakyll.Web.Html
74import Hakyll.Web.Html
75+import Prelude hiding (id)
76+import System.FilePath (dropExtension, splitDirectories,
52--------------------------------------------------------------------------------
80--------------------------------------------------------------------------------
53-- | Mostly for internal usage
81-- | Mostly for internal usage
54data ContextField
82data ContextField
55− = StringField String
84+ | StringField String
56 | forall a. ListField (Context a) [Item a]
85 | forall a. ListField (Context a) [Item a]
@@ -77,61 +106,140 @@ newtype Context a = Context
79--------------------------------------------------------------------------------
108--------------------------------------------------------------------------------
109+-- | Tries to find a key in the left context,
110+-- or when that fails in the right context.
111+#if MIN_VERSION_base(4,9,0)
112+instance Semigroup (Context a) where
113+ (<>) (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i
115+instance Monoid (Context a) where
116+ mempty = missingField
80instance Monoid (Context a) where
119instance Monoid (Context a) where
81 mempty = missingField
120 mempty = missingField
82 mappend (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i
121 mappend (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i
85--------------------------------------------------------------------------------
125--------------------------------------------------------------------------------
86field' :: String -> (Item a -> Compiler ContextField) -> Context a
126field' :: String -> (Item a -> Compiler ContextField) -> Context a
87−field' key value = Context $ \k _ i -> if k == key then value i else empty
127+field' key value = Context $ \k _ i ->
130+ else noResult $ "Tried field " ++ key
90--------------------------------------------------------------------------------
133--------------------------------------------------------------------------------
91−-- | Constructs a new field in the 'Context.'
134+-- | Constructs a new field for a 'Context'.
135+-- If the key matches, the compiler is run and its result is substituted in the
138+-- If the compiler fails, the field will be considered non-existent
139+-- in an @$if()$@ macro or ultimately break the template application
140+-- (unless the key is found in another context when using '<>').
141+-- Use 'empty' or 'noResult' for intentional failures of fields used in
142+-- @$if()$@, to distinguish them from exceptions thrown with 'fail'.
93 :: String -- ^ Key
144 :: String -- ^ Key
94 -> (Item a -> Compiler String) -- ^ Function that constructs a value based
145 -> (Item a -> Compiler String) -- ^ Function that constructs a value based
95− -- on the item
146+ -- on the item (e.g. accessing metadata)
96 -> Context a
147 -> Context a
97field key value = field' key (fmap StringField . value)
148field key value = field' key (fmap StringField . value)
100--------------------------------------------------------------------------------
151--------------------------------------------------------------------------------
152+-- | Creates a 'field' to use with the @$if()$@ template macro.
153+-- Attempting to substitute the field into the template will cause an error.
158+boolField name f = field' name (\i -> if f i
159+ then return EmptyField
160+ else noResult $ "Field " ++ name ++ " is false")
163+--------------------------------------------------------------------------------
101−-- | Creates a 'field' that does not depend on the 'Item'
164+-- | Creates a 'field' that does not depend on the 'Item' but always yields
102−constField :: String -> String -> Context a
166+constField :: String -- ^ Key
167+ -> String -- ^ Value
103constField key = field key . const . return
169constField key = field key . const . return
106--------------------------------------------------------------------------------
172--------------------------------------------------------------------------------
173+-- | Creates a list field to be consumed by a @$for(…)$@ expression.
174+-- The compiler returns multiple items which are rendered in the loop body
175+-- with the supplied context.
107listField :: String -> Context a -> Compiler [Item a] -> Context b
176listField :: String -> Context a -> Compiler [Item a] -> Context b
108listField key c xs = listFieldWith key c (const xs)
177listField key c xs = listFieldWith key c (const xs)
111--------------------------------------------------------------------------------
180--------------------------------------------------------------------------------
181+-- | Produces a new 'Context' which has list field 'key'. All fields from
182+-- 'c' are also accessible from the produced context.
183+-- Be careful when doing @listFieldWith k ca f <> cb@ as any fields in @ca@
184+-- will override fields in @cb@ with the same name.
185+-- Creates a list field like 'listField', but supplies the current page
112listFieldWith
187listFieldWith
113 :: String -> Context a -> (Item b -> Compiler [Item a]) -> Context b
188 :: String -> Context a -> (Item b -> Compiler [Item a]) -> Context b
114listFieldWith key c f = field' key $ fmap (ListField c) . f
189listFieldWith key c f = field' key $ fmap (ListField c) . f
117--------------------------------------------------------------------------------
192--------------------------------------------------------------------------------
193+-- | Creates a variadic function field.
195+-- The function will be called with the dynamically evaluated string arguments
196+-- from the template as well as the page that is currently rendered.
197+functionField :: String -- ^ Key
118−functionField :: String -> ([String] -> Item a -> Compiler String) -> Context a
198+ -> ([String] -> Item a -> Compiler String) -- ^ Function
119functionField name value = Context $ \k args i ->
200functionField name value = Context $ \k args i ->
120 if k == name
201 if k == name
121 then StringField <$> value args i
202 then StringField <$> value args i
122− else empty
203+ else noResult $ "Tried function field " ++ name
125--------------------------------------------------------------------------------
206--------------------------------------------------------------------------------
207+-- | Transform the respective string results of all fields in a context.
210+-- > mapContext (++"c") (constField "x" "a" <> constField "y" "b")
214+-- > constField "x" "ac" <> constField "y" "bc"
126mapContext :: (String -> String) -> Context a -> Context a
216mapContext :: (String -> String) -> Context a -> Context a
127mapContext f (Context c) = Context $ \k a i -> do
217mapContext f (Context c) = Context $ \k a i -> do
128 fld <- c k a i
218 fld <- c k a i
129 case fld of
219 case fld of
220+ EmptyField -> wrongType "boolField"
130 StringField str -> return $ StringField (f str)
221 StringField str -> return $ StringField (f str)
131− ListField _ _ -> fail $
222+ _ -> wrongType "ListField"
132− "Hakyll.Web.Template.Context.mapContext: " ++
224+ wrongType typ = fail $ "Hakyll.Web.Template.Context.mapContext: " ++
133− "can't map over a ListField!"
225+ "can't map over a " ++ typ ++ "!"
227+--------------------------------------------------------------------------------
228+-- | A context that allows snippet inclusion. In processed file, use as:
231+-- > $snippet("path/to/snippet/")$
234+-- The contents of the included file will not be interpolated like @partial@
237+snippetField :: Context String
238+snippetField = functionField "snippet" f
240+ f [contentsPath] _ = loadBody (fromFilePath contentsPath)
241+ f [] _ = fail "No argument to function 'snippet()'"
242+ f _ _ = fail "Too many arguments to function 'snippet()'"
136--------------------------------------------------------------------------------
244--------------------------------------------------------------------------------
137-- | A context that contains (in that order)
245-- | A context that contains (in that order)
@@ -151,8 +259,7 @@ defaultContext =
151 metadataField `mappend`
259 metadataField `mappend`
152 urlField "url" `mappend`
260 urlField "url" `mappend`
153 pathField "path" `mappend`
261 pathField "path" `mappend`
154− titleField "title" `mappend`
262+ titleField "title"
158--------------------------------------------------------------------------------
265--------------------------------------------------------------------------------
@@ -170,15 +277,20 @@ bodyField key = field key $ return . itemBody
170-- | Map any field to its metadata value, if present
277-- | Map any field to its metadata value, if present
171metadataField :: Context a
278metadataField :: Context a
172metadataField = Context $ \k _ i -> do
279metadataField = Context $ \k _ i -> do
173− value <- getMetadataField (itemIdentifier i) k
280+ let id = itemIdentifier i
281+ empty' = noResult $ "No '" ++ k ++ "' field in metadata " ++
282+ "of item " ++ show id
283+ value <- getMetadataField id k
174− maybe empty (return . StringField) value
284+ maybe empty' (return . StringField) value
177--------------------------------------------------------------------------------
287--------------------------------------------------------------------------------
178-- | Absolute url to the resulting item
288-- | Absolute url to the resulting item
179urlField :: String -> Context a
289urlField :: String -> Context a
180−urlField key = field key $
290+urlField key = field key $ \i -> do
291+ let id = itemIdentifier i
292+ empty' = fail $ "No route url found for item " ++ show id
181− fmap (maybe empty toUrl) . getRoute . itemIdentifier
293+ fmap (maybe empty' toUrl) $ getRoute id
184--------------------------------------------------------------------------------
296--------------------------------------------------------------------------------
@@ -225,10 +337,16 @@ titleField = mapContext takeBaseName . pathField
225-- Alternatively, when the metadata has a field called @path@ in a
337-- Alternatively, when the metadata has a field called @path@ in a
226-- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages)
338-- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages)
227-- and no @published@ metadata field set, this function can render
339-- and no @published@ metadata field set, this function can render
228−-- the date. This pattern matches the file name or directory names
340+-- the date. This pattern matches the file name or directory names
229-- that begins with @yyyy-mm-dd@ . For example:
341-- that begins with @yyyy-mm-dd@ . For example:
230-- @folder//yyyy-mm-dd-title//dist//main.extension@ .
342-- @folder//yyyy-mm-dd-title//dist//main.extension@ .
231-- In case of multiple matches, the rightmost one is used.
343-- In case of multiple matches, the rightmost one is used.
345+-- As another alternative, if none of the above matches, and the file has a
346+-- path which contains nested directories specifying a date, then that date
347+-- will be used. In other words, if the path is of the form
348+-- @**//yyyy//mm//dd//**//main.extension@ .
349+-- As above, in case of multiple matches, the rightmost one is used.
233dateField :: String -- ^ Key in which the rendered date should be placed
351dateField :: String -- ^ Key in which the rendered date should be placed
234 -> String -- ^ Format to use on the date
352 -> String -- ^ Format to use on the date
@@ -239,7 +357,7 @@ dateField = dateFieldWith defaultTimeLocale
239--------------------------------------------------------------------------------
357--------------------------------------------------------------------------------
240-- | This is an extended version of 'dateField' that allows you to
358-- | This is an extended version of 'dateField' that allows you to
241-- specify a time locale that is used for outputting the date. For more
359-- specify a time locale that is used for outputting the date. For more
242−-- details, see 'dateField'.
360+-- details, see 'dateField' and 'formatTime'.
243dateFieldWith :: TimeLocale -- ^ Output time locale
361dateFieldWith :: TimeLocale -- ^ Output time locale
244 -> String -- ^ Destination key
362 -> String -- ^ Destination key
245 -> String -- ^ Format to use on the date
363 -> String -- ^ Format to use on the date
@@ -259,17 +377,18 @@ getItemUTC :: MonadMetadata m
259 -> m UTCTime -- ^ Parsed UTCTime
377 -> m UTCTime -- ^ Parsed UTCTime
260getItemUTC locale id' = do
378getItemUTC locale id' = do
261 metadata <- getMetadata id'
379 metadata <- getMetadata id'
262− let tryField k fmt = M.lookup k metadata >>= parseTime' fmt
380+ let tryField k fmt = lookupString k metadata >>= parseTime' fmt
263− paths = splitDirectories $ toFilePath id'
381+ paths = splitDirectories $ (dropExtension . toFilePath) id'
265 maybe empty' return $ msum $
383 maybe empty' return $ msum $
266 [tryField "published" fmt | fmt <- formats] ++
384 [tryField "published" fmt | fmt <- formats] ++
267 [tryField "date" fmt | fmt <- formats] ++
385 [tryField "date" fmt | fmt <- formats] ++
268− [parseTime' "%Y-%m-%d" $ intercalate "-" $ take 3 $ splitAll "-" fnCand | fnCand <- reverse paths]
386+ [parseTime' "%Y-%m-%d" $ intercalate "-" $ take 3 $ splitAll "-" fnCand | fnCand <- reverse paths] ++
387+ [parseTime' "%Y-%m-%d" $ intercalate "-" $ fnCand | fnCand <- map (take 3) $ reverse . tails $ paths]
270 empty' = fail $ "Hakyll.Web.Template.Context.getItemUTC: " ++
389 empty' = fail $ "Hakyll.Web.Template.Context.getItemUTC: " ++
271 "could not parse time for " ++ show id'
390 "could not parse time for " ++ show id'
272− parseTime' = parseTime locale
391+ parseTime' = parseTimeM True locale
273 formats =
392 formats =
274 [ "%a, %d %b %Y %H:%M:%S %Z"
393 [ "%a, %d %b %Y %H:%M:%S %Z"
275 , "%Y-%m-%dT%H:%M:%S%Z"
394 , "%Y-%m-%dT%H:%M:%S%Z"
@@ -282,20 +401,33 @@ getItemUTC locale id' = do
284--------------------------------------------------------------------------------
403--------------------------------------------------------------------------------
404+-- | Get the time on which the actual file was last modified. This only works if
405+-- there actually is an underlying file, of couse.
406+getItemModificationTime
409+getItemModificationTime identifier = do
410+ provider <- compilerProvider <$> compilerAsk
411+ return $ resourceModificationTime provider identifier
414+--------------------------------------------------------------------------------
415+-- | Creates a field with the last modification date of the underlying item.
285modificationTimeField :: String -- ^ Key
416modificationTimeField :: String -- ^ Key
286 -> String -- ^ Format
417 -> String -- ^ Format
287− -> Context a -- ^ Resuting context
418+ -> Context a -- ^ Resulting context
288modificationTimeField = modificationTimeFieldWith defaultTimeLocale
419modificationTimeField = modificationTimeFieldWith defaultTimeLocale
291--------------------------------------------------------------------------------
422--------------------------------------------------------------------------------
423+-- | Creates a field with the last modification date of the underlying item
424+-- in a custom localisation format (see 'formatTime').
292modificationTimeFieldWith :: TimeLocale -- ^ Time output locale
425modificationTimeFieldWith :: TimeLocale -- ^ Time output locale
293 -> String -- ^ Key
426 -> String -- ^ Key
294 -> String -- ^ Format
427 -> String -- ^ Format
295 -> Context a -- ^ Resulting context
428 -> Context a -- ^ Resulting context
296modificationTimeFieldWith locale key fmt = field key $ \i -> do
429modificationTimeFieldWith locale key fmt = field key $ \i -> do
297− provider <- compilerProvider <$> compilerAsk
298− let mtime = resourceModificationTime provider $ itemIdentifier i
430+ mtime <- getItemModificationTime $ itemIdentifier i
299 return $ formatTime locale fmt mtime
431 return $ formatTime locale fmt mtime
@@ -306,9 +438,21 @@ modificationTimeFieldWith locale key fmt = field key $ \i -> do
306teaserField :: String -- ^ Key to use
438teaserField :: String -- ^ Key to use
307 -> Snapshot -- ^ Snapshot to load
439 -> Snapshot -- ^ Snapshot to load
308 -> Context String -- ^ Resulting context
440 -> Context String -- ^ Resulting context
441+teaserField = teaserFieldWithSeparator teaserSeparator
444+--------------------------------------------------------------------------------
445+-- | A context with "teaser" key which contain a teaser of the item, defined as
446+-- the snapshot content before the teaser separator. The item is loaded from the
447+-- given snapshot (which should be saved in the user code before any templates
449+teaserFieldWithSeparator :: String -- ^ Separator to use
450+ -> String -- ^ Key to use
451+ -> Snapshot -- ^ Snapshot to load
452+ -> Context String -- ^ Resulting context
309−teaserField key snapshot = field key $ \item -> do
453+teaserFieldWithSeparator separator key snapshot = field key $ \item -> do
310 body <- itemBody <$> loadSnapshot (itemIdentifier item) snapshot
454 body <- itemBody <$> loadSnapshot (itemIdentifier item) snapshot
311− case needlePrefix teaserSeparator body of
455+ case needlePrefix separator body of
312 Nothing -> fail $
456 Nothing -> fail $
313 "Hakyll.Web.Template.Context: no teaser defined for " ++
457 "Hakyll.Web.Template.Context: no teaser defined for " ++
314 show (itemIdentifier item)
458 show (itemIdentifier item)
@@ -316,7 +460,22 @@ teaserField key snapshot = field key $ \item -> do
318--------------------------------------------------------------------------------
462--------------------------------------------------------------------------------
463+-- | Constantly reports any field as missing. Mostly for internal usage,
464+-- it is the last choice in every context used in a template application.
319missingField :: Context a
465missingField :: Context a
320−missingField = Context $ \k _ i -> fail $
466+missingField = Context $ \k _ _ -> noResult $
321− "Missing field $" ++ k ++ "$ in context for item " ++
467+ "Missing field '" ++ k ++ "' in context"
322− show (itemIdentifier i)
468+
469+parseTimeM :: Bool -> TimeLocale -> String -> String -> Maybe UTCTime
470+#if MIN_VERSION_time(1,5,0)
471+parseTimeM = TF.parseTimeM
473+parseTimeM _ = TF.parseTime
476+--------------------------------------------------------------------------------
478+-- | Binds an 'Item' to a given 'Context', allowing it to be combined with any
479+-- other 'Context' of any type.
480+bindItem :: Context a -> Item a -> forall b. Context b
481+bindItem (Context ctx) ia = Context $ \k args _ -> ctx k args ia