@@ -1,481 +0,0 @@
1−-- | This module provides 'Context's which are used to expand expressions in
2−-- templates and allow for arbitrary customisation.
3−--
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.
7−--
8−-- For example, you can build a context that contains
9−--
10−-- > … <> functionField "concat" (const . concat) <> …
11−--
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:
14−--
15−-- > $partial(concat("templates/categories/", category))$
16−--
17−-- This will evaluate the @category@ field in the context, then prepend he path,
18−-- and include the referenced file as a template.
19−
20−
21−--------------------------------------------------------------------------------
22−{-# LANGUAGE CPP #-}
23−{-# LANGUAGE ExistentialQuantification #-}
24−{-# LANGUAGE RankNTypes #-}
25−module Hakyll.Web.Template.Context
26− ( ContextField (..)
27− , Context (..)
28− , field
29− , boolField
30− , constField
31− , listField
32− , listFieldWith
33− , functionField
34− , mapContext
35−
36− , defaultContext
37− , bodyField
38− , metadataField
39− , urlField
40− , pathField
41− , titleField
42− , snippetField
43− , dateField
44− , dateFieldWith
45− , getItemUTC
46− , getItemModificationTime
47− , modificationTimeField
48− , modificationTimeFieldWith
49− , teaserField
50− , teaserFieldWithSeparator
51− , missingField
52− , bindItem
53− ) where
54−
55−
56−--------------------------------------------------------------------------------
57−import Control.Applicative (Alternative (..))
58−import Control.Monad (msum)
59−import Data.List (intercalate, tails)
60−#if MIN_VERSION_base(4,9,0)
61−import Data.Semigroup (Semigroup (..))
62−#endif
63−import Data.Time.Clock (UTCTime (..))
64−import Data.Time.Format (formatTime)
65−import qualified Data.Time.Format as TF
66−import Data.Time.Locale.Compat (TimeLocale, defaultTimeLocale)
67−import Hakyll.Core.Compiler
68−import Hakyll.Core.Compiler.Internal
69−import Hakyll.Core.Identifier
70−import Hakyll.Core.Item
71−import Hakyll.Core.Metadata
72−import Hakyll.Core.Provider
73−import Hakyll.Core.Util.String (needlePrefix, splitAll)
74−import Hakyll.Web.Html
75−import Prelude hiding (id)
76−import System.FilePath (dropExtension, splitDirectories,
77− takeBaseName)
78−
79−
80−--------------------------------------------------------------------------------
81−-- | Mostly for internal usage
82−data ContextField
83− = EmptyField
84− | StringField String
85− | forall a. ListField (Context a) [Item a]
86−
87−
88−--------------------------------------------------------------------------------
89−-- | The 'Context' monoid. Please note that the order in which you
90−-- compose the items is important. For example in
91−--
92−-- > field "A" f1 <> field "A" f2
93−--
94−-- the first context will overwrite the second. This is especially
95−-- important when something is being composed with
96−-- 'metadataField' (or 'defaultContext'). If you want your context to be
97−-- overwritten by the metadata fields, compose it from the right:
98−--
99−-- @
100−-- 'metadataField' \<\> field \"date\" fDate
101−-- @
102−--
103−newtype Context a = Context
104− { unContext :: String -> [String] -> Item a -> Compiler ContextField
105− }
106−
107−
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
114−
115−instance Monoid (Context a) where
116− mempty = missingField
117− mappend = (<>)
118−#else
119−instance Monoid (Context a) where
120− mempty = missingField
121− mappend (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i
122−#endif
123−
124−
125−--------------------------------------------------------------------------------
126−field' :: String -> (Item a -> Compiler ContextField) -> Context a
127−field' key value = Context $ \k _ i ->
128− if k == key
129− then value i
130− else noResult $ "Tried field " ++ key
131−
132−
133−--------------------------------------------------------------------------------
134−-- | Constructs a new field for a 'Context'.
135−-- If the key matches, the compiler is run and its result is substituted in the
136−-- template.
137−--
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'.
143−field
144− :: String -- ^ Key
145− -> (Item a -> Compiler String) -- ^ Function that constructs a value based
146− -- on the item (e.g. accessing metadata)
147− -> Context a
148−field key value = field' key (fmap StringField . value)
149−
150−
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.
154−boolField
155− :: String
156− -> (Item a -> Bool)
157− -> Context a
158−boolField name f = field' name (\i -> if f i
159− then return EmptyField
160− else noResult $ "Field " ++ name ++ " is false")
161−
162−
163−--------------------------------------------------------------------------------
164−-- | Creates a 'field' that does not depend on the 'Item' but always yields
165−-- the same string
166−constField :: String -- ^ Key
167− -> String -- ^ Value
168− -> Context a
169−constField key = field key . const . return
170−
171−
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.
176−listField :: String -> Context a -> Compiler [Item a] -> Context b
177−listField key c xs = listFieldWith key c (const xs)
178−
179−
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
186−-- to the compiler.
187−listFieldWith
188− :: String -> Context a -> (Item b -> Compiler [Item a]) -> Context b
189−listFieldWith key c f = field' key $ fmap (ListField c) . f
190−
191−
192−--------------------------------------------------------------------------------
193−-- | Creates a variadic function field.
194−--
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
198− -> ([String] -> Item a -> Compiler String) -- ^ Function
199− -> Context a
200−functionField name value = Context $ \k args i ->
201− if k == name
202− then StringField <$> value args i
203− else noResult $ "Tried function field " ++ name
204−
205−
206−--------------------------------------------------------------------------------
207−-- | Transform the respective string results of all fields in a context.
208−-- For example,
209−--
210−-- > mapContext (++"c") (constField "x" "a" <> constField "y" "b")
211−--
212−-- is equivalent to
213−--
214−-- > constField "x" "ac" <> constField "y" "bc"
215−--
216−mapContext :: (String -> String) -> Context a -> Context a
217−mapContext f (Context c) = Context $ \k a i -> do
218− fld <- c k a i
219− case fld of
220− EmptyField -> wrongType "boolField"
221− StringField str -> return $ StringField (f str)
222− _ -> wrongType "ListField"
223− where
224− wrongType typ = fail $ "Hakyll.Web.Template.Context.mapContext: " ++
225− "can't map over a " ++ typ ++ "!"
226−
227−--------------------------------------------------------------------------------
228−-- | A context that allows snippet inclusion. In processed file, use as:
229−--
230−-- > ...
231−-- > $snippet("path/to/snippet/")$
232−-- > ...
233−--
234−-- The contents of the included file will not be interpolated like @partial@
235−-- does it.
236−--
237−snippetField :: Context String
238−snippetField = functionField "snippet" f
239− where
240− f [contentsPath] _ = loadBody (fromFilePath contentsPath)
241− f [] _ = fail "No argument to function 'snippet()'"
242− f _ _ = fail "Too many arguments to function 'snippet()'"
243−
244−--------------------------------------------------------------------------------
245−-- | A context that contains (in that order)
246−--
247−-- 1. A @$body$@ field
248−--
249−-- 2. Metadata fields
250−--
251−-- 3. A @$url$@ 'urlField'
252−--
253−-- 4. A @$path$@ 'pathField'
254−--
255−-- 5. A @$title$@ 'titleField'
256−defaultContext :: Context String
257−defaultContext =
258− bodyField "body" `mappend`
259− metadataField `mappend`
260− urlField "url" `mappend`
261− pathField "path" `mappend`
262− titleField "title"
263−
264−
265−--------------------------------------------------------------------------------
266−teaserSeparator :: String
267−teaserSeparator = "<!--more-->"
268−
269−
270−--------------------------------------------------------------------------------
271−-- | Constructs a 'field' that contains the body of the item.
272−bodyField :: String -> Context String
273−bodyField key = field key $ return . itemBody
274−
275−
276−--------------------------------------------------------------------------------
277−-- | Map any field to its metadata value, if present
278−metadataField :: Context a
279−metadataField = Context $ \k _ i -> do
280− let id = itemIdentifier i
281− empty' = noResult $ "No '" ++ k ++ "' field in metadata " ++
282− "of item " ++ show id
283− value <- getMetadataField id k
284− maybe empty' (return . StringField) value
285−
286−
287−--------------------------------------------------------------------------------
288−-- | Absolute url to the resulting item
289−urlField :: String -> Context a
290−urlField key = field key $ \i -> do
291− let id = itemIdentifier i
292− empty' = fail $ "No route url found for item " ++ show id
293− fmap (maybe empty' toUrl) $ getRoute id
294−
295−
296−--------------------------------------------------------------------------------
297−-- | Filepath of the underlying file of the item
298−pathField :: String -> Context a
299−pathField key = field key $ return . toFilePath . itemIdentifier
300−
301−
302−--------------------------------------------------------------------------------
303−-- | This title 'field' takes the basename of the underlying file by default
304−titleField :: String -> Context a
305−titleField = mapContext takeBaseName . pathField
306−
307−
308−--------------------------------------------------------------------------------
309−-- | When the metadata has a field called @published@ in one of the
310−-- following formats then this function can render the date.
311−--
312−-- * @Mon, 06 Sep 2010 00:01:00 +0000@
313−--
314−-- * @Mon, 06 Sep 2010 00:01:00 UTC@
315−--
316−-- * @Mon, 06 Sep 2010 00:01:00@
317−--
318−-- * @2010-09-06T00:01:00+0000@
319−--
320−-- * @2010-09-06T00:01:00Z@
321−--
322−-- * @2010-09-06T00:01:00@
323−--
324−-- * @2010-09-06 00:01:00+0000@
325−--
326−-- * @2010-09-06 00:01:00@
327−--
328−-- * @September 06, 2010 00:01 AM@
329−--
330−-- Following date-only formats are supported too (@00:00:00@ for time is
331−-- assumed)
332−--
333−-- * @2010-09-06@
334−--
335−-- * @September 06, 2010@
336−--
337−-- Alternatively, when the metadata has a field called @path@ in a
338−-- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages)
339−-- and no @published@ metadata field set, this function can render
340−-- the date. This pattern matches the file name or directory names
341−-- that begins with @yyyy-mm-dd@ . For example:
342−-- @folder//yyyy-mm-dd-title//dist//main.extension@ .
343−-- In case of multiple matches, the rightmost one is used.
344−--
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.
350−
351−dateField :: String -- ^ Key in which the rendered date should be placed
352− -> String -- ^ Format to use on the date
353− -> Context a -- ^ Resulting context
354−dateField = dateFieldWith defaultTimeLocale
355−
356−
357−--------------------------------------------------------------------------------
358−-- | This is an extended version of 'dateField' that allows you to
359−-- specify a time locale that is used for outputting the date. For more
360−-- details, see 'dateField' and 'formatTime'.
361−dateFieldWith :: TimeLocale -- ^ Output time locale
362− -> String -- ^ Destination key
363− -> String -- ^ Format to use on the date
364− -> Context a -- ^ Resulting context
365−dateFieldWith locale key format = field key $ \i -> do
366− time <- getItemUTC locale $ itemIdentifier i
367− return $ formatTime locale format time
368−
369−
370−--------------------------------------------------------------------------------
371−-- | Parser to try to extract and parse the time from the @published@
372−-- field or from the filename. See 'dateField' for more information.
373−-- Exported for user convenience.
374−getItemUTC :: MonadMetadata m
375− => TimeLocale -- ^ Output time locale
376− -> Identifier -- ^ Input page
377− -> m UTCTime -- ^ Parsed UTCTime
378−getItemUTC locale id' = do
379− metadata <- getMetadata id'
380− let tryField k fmt = lookupString k metadata >>= parseTime' fmt
381− paths = splitDirectories $ (dropExtension . toFilePath) id'
382−
383− maybe empty' return $ msum $
384− [tryField "published" fmt | fmt <- formats] ++
385− [tryField "date" fmt | fmt <- formats] ++
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]
388− where
389− empty' = fail $ "Hakyll.Web.Template.Context.getItemUTC: " ++
390− "could not parse time for " ++ show id'
391− parseTime' = parseTimeM True locale
392− formats =
393− [ "%a, %d %b %Y %H:%M:%S %Z"
394− , "%Y-%m-%dT%H:%M:%S%Z"
395− , "%Y-%m-%d %H:%M:%S%Z"
396− , "%Y-%m-%d"
397− , "%B %e, %Y %l:%M %p"
398− , "%B %e, %Y"
399− , "%b %d, %Y"
400− ]
401−
402−
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
407− :: Identifier
408− -> Compiler UTCTime
409−getItemModificationTime identifier = do
410− provider <- compilerProvider <$> compilerAsk
411− return $ resourceModificationTime provider identifier
412−
413−
414−--------------------------------------------------------------------------------
415−-- | Creates a field with the last modification date of the underlying item.
416−modificationTimeField :: String -- ^ Key
417− -> String -- ^ Format
418− -> Context a -- ^ Resulting context
419−modificationTimeField = modificationTimeFieldWith defaultTimeLocale
420−
421−
422−--------------------------------------------------------------------------------
423−-- | Creates a field with the last modification date of the underlying item
424−-- in a custom localisation format (see 'formatTime').
425−modificationTimeFieldWith :: TimeLocale -- ^ Time output locale
426− -> String -- ^ Key
427− -> String -- ^ Format
428− -> Context a -- ^ Resulting context
429−modificationTimeFieldWith locale key fmt = field key $ \i -> do
430− mtime <- getItemModificationTime $ itemIdentifier i
431− return $ formatTime locale fmt mtime
432−
433−
434−--------------------------------------------------------------------------------
435−-- | A context with "teaser" key which contain a teaser of the item.
436−-- The item is loaded from the given snapshot (which should be saved
437−-- in the user code before any templates are applied).
438−teaserField :: String -- ^ Key to use
439− -> Snapshot -- ^ Snapshot to load
440− -> Context String -- ^ Resulting context
441−teaserField = teaserFieldWithSeparator teaserSeparator
442−
443−
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
448−-- are applied).
449−teaserFieldWithSeparator :: String -- ^ Separator to use
450− -> String -- ^ Key to use
451− -> Snapshot -- ^ Snapshot to load
452− -> Context String -- ^ Resulting context
453−teaserFieldWithSeparator separator key snapshot = field key $ \item -> do
454− body <- itemBody <$> loadSnapshot (itemIdentifier item) snapshot
455− case needlePrefix separator body of
456− Nothing -> fail $
457− "Hakyll.Web.Template.Context: no teaser defined for " ++
458− show (itemIdentifier item)
459− Just t -> return t
460−
461−
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.
465−missingField :: Context a
466−missingField = Context $ \k _ _ -> noResult $
467− "Missing field '" ++ k ++ "' in context"
468−
469−parseTimeM :: Bool -> TimeLocale -> String -> String -> Maybe UTCTime
470−#if MIN_VERSION_time(1,5,0)
471−parseTimeM = TF.parseTimeM
472−#else
473−parseTimeM _ = TF.parseTime
474−#endif
475−
476−--------------------------------------------------------------------------------
477−
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