@@ -1,6 +1,27 @@
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+
121--------------------------------------------------------------------------------
222{-# LANGUAGE CPP #-}
323{-# LANGUAGE ExistentialQuantification #-}
24+{-# LANGUAGE RankNTypes #-}
425module Hakyll.Web.Template.Context
526 ( ContextField (..)
627 , Context (..)
@@ -28,13 +49,17 @@ module Hakyll.Web.Template.Context
2849 , teaserField
2950 , teaserFieldWithSeparator
3051 , missingField
52+ , bindItem
3153 ) where
3254
3355
3456--------------------------------------------------------------------------------
3557import Control.Applicative (Alternative (..))
3658import Control.Monad (msum)
37−import Data.List (intercalate)
59+import Data.List (intercalate, tails)
60+#if MIN_VERSION_base(4,9,0)
61+import Data.Semigroup (Semigroup (..))
62+#endif
3863import Data.Time.Clock (UTCTime (..))
3964import Data.Time.Format (formatTime)
4065import qualified Data.Time.Format as TF
@@ -47,13 +72,16 @@ import Hakyll.Core.Metadata
4772import Hakyll.Core.Provider
4873import Hakyll.Core.Util.String (needlePrefix, splitAll)
4974import Hakyll.Web.Html
50−import System.FilePath (splitDirectories, takeBaseName)
75+import Prelude hiding (id)
76+import System.FilePath (dropExtension, splitDirectories,
77+ takeBaseName)
5178
5279
5380--------------------------------------------------------------------------------
5481-- | Mostly for internal usage
5582data ContextField
56− = StringField String
83+ = EmptyField
84+ | StringField String
5785 | forall a. ListField (Context a) [Item a]
5886
5987
@@ -78,71 +106,123 @@ newtype Context a = Context
78106
79107
80108--------------------------------------------------------------------------------
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
81119instance Monoid (Context a) where
82120 mempty = missingField
83121 mappend (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i
122+#endif
84123
85124
86125--------------------------------------------------------------------------------
87126field' :: String -> (Item a -> Compiler ContextField) -> Context a
88−field' key value = Context $ \k _ i -> if k == key then value i else empty
127+field' key value = Context $ \k _ i ->
128+ if k == key
129+ then value i
130+ else noResult $ "Tried field " ++ key
89131
90132
91133--------------------------------------------------------------------------------
92−-- | 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
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'.
93143field
94144 :: String -- ^ Key
95145 -> (Item a -> Compiler String) -- ^ Function that constructs a value based
96− -- on the item
146+ -- on the item (e.g. accessing metadata)
97147 -> Context a
98148field key value = field' key (fmap StringField . value)
99149
100150
101151--------------------------------------------------------------------------------
102152-- | Creates a 'field' to use with the @$if()$@ template macro.
153+-- Attempting to substitute the field into the template will cause an error.
103154boolField
104155 :: String
105156 -> (Item a -> Bool)
106157 -> Context a
107−boolField name f = field name (\i -> if f i
108− then pure (error $ unwords ["no string value for bool field:",name])
109− else empty)
158+boolField name f = field' name (\i -> if f i
159+ then return EmptyField
160+ else noResult $ "Field " ++ name ++ " is false")
110161
111162
112163--------------------------------------------------------------------------------
113−-- | Creates a 'field' that does not depend on the 'Item'
114−constField :: String -> String -> Context a
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
115169constField key = field key . const . return
116170
117171
118172--------------------------------------------------------------------------------
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.
119176listField :: String -> Context a -> Compiler [Item a] -> Context b
120177listField key c xs = listFieldWith key c (const xs)
121178
122179
123180--------------------------------------------------------------------------------
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.
124187listFieldWith
125188 :: String -> Context a -> (Item b -> Compiler [Item a]) -> Context b
126189listFieldWith key c f = field' key $ fmap (ListField c) . f
127190
128191
129192--------------------------------------------------------------------------------
130−functionField :: String -> ([String] -> Item a -> Compiler String) -> Context a
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
131200functionField name value = Context $ \k args i ->
132201 if k == name
133202 then StringField <$> value args i
134− else empty
203+ else noResult $ "Tried function field " ++ name
135204
136205
137206--------------------------------------------------------------------------------
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+--
138216mapContext :: (String -> String) -> Context a -> Context a
139217mapContext f (Context c) = Context $ \k a i -> do
140218 fld <- c k a i
141219 case fld of
220+ EmptyField -> wrongType "boolField"
142221 StringField str -> return $ StringField (f str)
143− ListField _ _ -> fail $
144− "Hakyll.Web.Template.Context.mapContext: " ++
145− "can't map over a ListField!"
222+ _ -> wrongType "ListField"
223+ where
224+ wrongType typ = fail $ "Hakyll.Web.Template.Context.mapContext: " ++
225+ "can't map over a " ++ typ ++ "!"
146226
147227--------------------------------------------------------------------------------
148228-- | A context that allows snippet inclusion. In processed file, use as:
@@ -151,15 +231,15 @@ mapContext f (Context c) = Context $ \k a i -> do
151231-- > $snippet("path/to/snippet/")$
152232-- > ...
153233--
154−-- The contents of the included file will not be interpolated.
234+-- The contents of the included file will not be interpolated like @partial@
235+-- does it.
155236--
156237snippetField :: Context String
157238snippetField = functionField "snippet" f
158239 where
159240 f [contentsPath] _ = loadBody (fromFilePath contentsPath)
160− f _ i = error $
161− "Too many arguments to function 'snippet()' in item " ++
162− show (itemIdentifier i)
241+ f [] _ = fail "No argument to function 'snippet()'"
242+ f _ _ = fail "Too many arguments to function 'snippet()'"
163243
164244--------------------------------------------------------------------------------
165245-- | A context that contains (in that order)
@@ -179,8 +259,7 @@ defaultContext =
179259 metadataField `mappend`
180260 urlField "url" `mappend`
181261 pathField "path" `mappend`
182− titleField "title" `mappend`
183− missingField
262+ titleField "title"
184263
185264
186265--------------------------------------------------------------------------------
@@ -198,15 +277,20 @@ bodyField key = field key $ return . itemBody
198277-- | Map any field to its metadata value, if present
199278metadataField :: Context a
200279metadataField = Context $ \k _ i -> do
201− value <- getMetadataField (itemIdentifier i) k
202− maybe empty (return . StringField) value
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
203285
204286
205287--------------------------------------------------------------------------------
206288-- | Absolute url to the resulting item
207289urlField :: String -> Context a
208−urlField key = field key $
209− fmap (maybe empty toUrl) . getRoute . itemIdentifier
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
210294
211295
212296--------------------------------------------------------------------------------
@@ -257,6 +341,12 @@ titleField = mapContext takeBaseName . pathField
257341-- that begins with @yyyy-mm-dd@ . For example:
258342-- @folder//yyyy-mm-dd-title//dist//main.extension@ .
259343-- 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.
260350
261351dateField :: String -- ^ Key in which the rendered date should be placed
262352 -> String -- ^ Format to use on the date
@@ -267,7 +357,7 @@ dateField = dateFieldWith defaultTimeLocale
267357--------------------------------------------------------------------------------
268358-- | This is an extended version of 'dateField' that allows you to
269359-- specify a time locale that is used for outputting the date. For more
270−-- details, see 'dateField'.
360+-- details, see 'dateField' and 'formatTime'.
271361dateFieldWith :: TimeLocale -- ^ Output time locale
272362 -> String -- ^ Destination key
273363 -> String -- ^ Format to use on the date
@@ -288,12 +378,13 @@ getItemUTC :: MonadMetadata m
288378getItemUTC locale id' = do
289379 metadata <- getMetadata id'
290380 let tryField k fmt = lookupString k metadata >>= parseTime' fmt
291− paths = splitDirectories $ toFilePath id'
381+ paths = splitDirectories $ (dropExtension . toFilePath) id'
292382
293383 maybe empty' return $ msum $
294384 [tryField "published" fmt | fmt <- formats] ++
295385 [tryField "date" fmt | fmt <- formats] ++
296− [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]
297388 where
298389 empty' = fail $ "Hakyll.Web.Template.Context.getItemUTC: " ++
299390 "could not parse time for " ++ show id'
@@ -321,13 +412,16 @@ getItemModificationTime identifier = do
321412
322413
323414--------------------------------------------------------------------------------
415+-- | Creates a field with the last modification date of the underlying item.
324416modificationTimeField :: String -- ^ Key
325417 -> String -- ^ Format
326− -> Context a -- ^ Resuting context
418+ -> Context a -- ^ Resulting context
327419modificationTimeField = modificationTimeFieldWith defaultTimeLocale
328420
329421
330422--------------------------------------------------------------------------------
423+-- | Creates a field with the last modification date of the underlying item
424+-- in a custom localisation format (see 'formatTime').
331425modificationTimeFieldWith :: TimeLocale -- ^ Time output locale
332426 -> String -- ^ Key
333427 -> String -- ^ Format
@@ -366,10 +460,11 @@ teaserFieldWithSeparator separator key snapshot = field key $ \item -> do
366460
367461
368462--------------------------------------------------------------------------------
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.
369465missingField :: Context a
370−missingField = Context $ \k _ i -> fail $
371− "Missing field $" ++ k ++ "$ in context for item " ++
372− show (itemIdentifier i)
466+missingField = Context $ \k _ _ -> noResult $
467+ "Missing field '" ++ k ++ "' in context"
373468
374469parseTimeM :: Bool -> TimeLocale -> String -> String -> Maybe UTCTime
375470#if MIN_VERSION_time(1,5,0)
@@ -377,3 +472,10 @@ parseTimeM = TF.parseTimeM
377472#else
378473parseTimeM _ = TF.parseTime
379474#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