hakyll-4.7.2.2: src/Hakyll/Web/Template/Context.hs
--------------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
module Hakyll.Web.Template.Context
( ContextField (..)
, Context (..)
, field
, boolField
, constField
, listField
, listFieldWith
, functionField
, mapContext
, defaultContext
, bodyField
, metadataField
, urlField
, pathField
, titleField
, dateField
, dateFieldWith
, getItemUTC
, modificationTimeField
, modificationTimeFieldWith
, teaserField
, teaserFieldWithSeparator
, missingField
) where
--------------------------------------------------------------------------------
import Control.Applicative (Alternative (..), pure, (<$>))
import Control.Monad (msum)
import Data.List (intercalate)
import qualified Data.Map as M
import Data.Monoid (Monoid (..))
import Data.Time.Clock (UTCTime (..))
import Data.Time.Format (formatTime)
import qualified Data.Time.Format as TF
import Data.Time.Locale.Compat (TimeLocale, defaultTimeLocale)
import System.FilePath (splitDirectories, takeBaseName)
--------------------------------------------------------------------------------
import Hakyll.Core.Compiler
import Hakyll.Core.Compiler.Internal
import Hakyll.Core.Identifier
import Hakyll.Core.Item
import Hakyll.Core.Metadata
import Hakyll.Core.Provider
import Hakyll.Core.Util.String (needlePrefix, splitAll)
import Hakyll.Web.Html
--------------------------------------------------------------------------------
-- | Mostly for internal usage
data ContextField
= StringField String
| forall a. ListField (Context a) [Item a]
--------------------------------------------------------------------------------
-- | The 'Context' monoid. Please note that the order in which you
-- compose the items is important. For example in
--
-- > field "A" f1 <> field "A" f2
--
-- the first context will overwrite the second. This is especially
-- important when something is being composed with
-- 'metadataField' (or 'defaultContext'). If you want your context to be
-- overwritten by the metadata fields, compose it from the right:
--
-- @
-- 'metadataField' \<\> field \"date\" fDate
-- @
--
newtype Context a = Context
{ unContext :: String -> [String] -> Item a -> Compiler ContextField
}
--------------------------------------------------------------------------------
instance Monoid (Context a) where
mempty = missingField
mappend (Context f) (Context g) = Context $ \k a i -> f k a i <|> g k a i
--------------------------------------------------------------------------------
field' :: String -> (Item a -> Compiler ContextField) -> Context a
field' key value = Context $ \k _ i -> if k == key then value i else empty
--------------------------------------------------------------------------------
-- | Constructs a new field in the 'Context.'
field
:: String -- ^ Key
-> (Item a -> Compiler String) -- ^ Function that constructs a value based
-- on the item
-> Context a
field key value = field' key (fmap StringField . value)
--------------------------------------------------------------------------------
-- | Creates a 'field' to use with the @$if()$@ template macro.
boolField
:: String
-> (Item a -> Bool)
-> Context a
boolField name f = field name (\i -> if f i
then pure (error $ unwords ["no string value for bool field:",name])
else empty)
--------------------------------------------------------------------------------
-- | Creates a 'field' that does not depend on the 'Item'
constField :: String -> String -> Context a
constField key = field key . const . return
--------------------------------------------------------------------------------
listField :: String -> Context a -> Compiler [Item a] -> Context b
listField key c xs = listFieldWith key c (const xs)
--------------------------------------------------------------------------------
listFieldWith
:: String -> Context a -> (Item b -> Compiler [Item a]) -> Context b
listFieldWith key c f = field' key $ fmap (ListField c) . f
--------------------------------------------------------------------------------
functionField :: String -> ([String] -> Item a -> Compiler String) -> Context a
functionField name value = Context $ \k args i ->
if k == name
then StringField <$> value args i
else empty
--------------------------------------------------------------------------------
mapContext :: (String -> String) -> Context a -> Context a
mapContext f (Context c) = Context $ \k a i -> do
fld <- c k a i
case fld of
StringField str -> return $ StringField (f str)
ListField _ _ -> fail $
"Hakyll.Web.Template.Context.mapContext: " ++
"can't map over a ListField!"
--------------------------------------------------------------------------------
-- | A context that contains (in that order)
--
-- 1. A @$body$@ field
--
-- 2. Metadata fields
--
-- 3. A @$url$@ 'urlField'
--
-- 4. A @$path$@ 'pathField'
--
-- 5. A @$title$@ 'titleField'
defaultContext :: Context String
defaultContext =
bodyField "body" `mappend`
metadataField `mappend`
urlField "url" `mappend`
pathField "path" `mappend`
titleField "title" `mappend`
missingField
--------------------------------------------------------------------------------
teaserSeparator :: String
teaserSeparator = "<!--more-->"
--------------------------------------------------------------------------------
-- | Constructs a 'field' that contains the body of the item.
bodyField :: String -> Context String
bodyField key = field key $ return . itemBody
--------------------------------------------------------------------------------
-- | Map any field to its metadata value, if present
metadataField :: Context a
metadataField = Context $ \k _ i -> do
value <- getMetadataField (itemIdentifier i) k
maybe empty (return . StringField) value
--------------------------------------------------------------------------------
-- | Absolute url to the resulting item
urlField :: String -> Context a
urlField key = field key $
fmap (maybe empty toUrl) . getRoute . itemIdentifier
--------------------------------------------------------------------------------
-- | Filepath of the underlying file of the item
pathField :: String -> Context a
pathField key = field key $ return . toFilePath . itemIdentifier
--------------------------------------------------------------------------------
-- | This title 'field' takes the basename of the underlying file by default
titleField :: String -> Context a
titleField = mapContext takeBaseName . pathField
--------------------------------------------------------------------------------
-- | When the metadata has a field called @published@ in one of the
-- following formats then this function can render the date.
--
-- * @Mon, 06 Sep 2010 00:01:00 +0000@
--
-- * @Mon, 06 Sep 2010 00:01:00 UTC@
--
-- * @Mon, 06 Sep 2010 00:01:00@
--
-- * @2010-09-06T00:01:00+0000@
--
-- * @2010-09-06T00:01:00Z@
--
-- * @2010-09-06T00:01:00@
--
-- * @2010-09-06 00:01:00+0000@
--
-- * @2010-09-06 00:01:00@
--
-- * @September 06, 2010 00:01 AM@
--
-- Following date-only formats are supported too (@00:00:00@ for time is
-- assumed)
--
-- * @2010-09-06@
--
-- * @September 06, 2010@
--
-- Alternatively, when the metadata has a field called @path@ in a
-- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages)
-- and no @published@ metadata field set, this function can render
-- the date. This pattern matches the file name or directory names
-- that begins with @yyyy-mm-dd@ . For example:
-- @folder//yyyy-mm-dd-title//dist//main.extension@ .
-- In case of multiple matches, the rightmost one is used.
dateField :: String -- ^ Key in which the rendered date should be placed
-> String -- ^ Format to use on the date
-> Context a -- ^ Resulting context
dateField = dateFieldWith defaultTimeLocale
--------------------------------------------------------------------------------
-- | This is an extended version of 'dateField' that allows you to
-- specify a time locale that is used for outputting the date. For more
-- details, see 'dateField'.
dateFieldWith :: TimeLocale -- ^ Output time locale
-> String -- ^ Destination key
-> String -- ^ Format to use on the date
-> Context a -- ^ Resulting context
dateFieldWith locale key format = field key $ \i -> do
time <- getItemUTC locale $ itemIdentifier i
return $ formatTime locale format time
--------------------------------------------------------------------------------
-- | Parser to try to extract and parse the time from the @published@
-- field or from the filename. See 'dateField' for more information.
-- Exported for user convenience.
getItemUTC :: MonadMetadata m
=> TimeLocale -- ^ Output time locale
-> Identifier -- ^ Input page
-> m UTCTime -- ^ Parsed UTCTime
getItemUTC locale id' = do
metadata <- getMetadata id'
let tryField k fmt = M.lookup k metadata >>= parseTime' fmt
paths = splitDirectories $ toFilePath id'
maybe empty' return $ msum $
[tryField "published" fmt | fmt <- formats] ++
[tryField "date" fmt | fmt <- formats] ++
[parseTime' "%Y-%m-%d" $ intercalate "-" $ take 3 $ splitAll "-" fnCand | fnCand <- reverse paths]
where
empty' = fail $ "Hakyll.Web.Template.Context.getItemUTC: " ++
"could not parse time for " ++ show id'
parseTime' = parseTimeM True locale
formats =
[ "%a, %d %b %Y %H:%M:%S %Z"
, "%Y-%m-%dT%H:%M:%S%Z"
, "%Y-%m-%d %H:%M:%S%Z"
, "%Y-%m-%d"
, "%B %e, %Y %l:%M %p"
, "%B %e, %Y"
, "%b %d, %Y"
]
--------------------------------------------------------------------------------
modificationTimeField :: String -- ^ Key
-> String -- ^ Format
-> Context a -- ^ Resuting context
modificationTimeField = modificationTimeFieldWith defaultTimeLocale
--------------------------------------------------------------------------------
modificationTimeFieldWith :: TimeLocale -- ^ Time output locale
-> String -- ^ Key
-> String -- ^ Format
-> Context a -- ^ Resulting context
modificationTimeFieldWith locale key fmt = field key $ \i -> do
provider <- compilerProvider <$> compilerAsk
let mtime = resourceModificationTime provider $ itemIdentifier i
return $ formatTime locale fmt mtime
--------------------------------------------------------------------------------
-- | A context with "teaser" key which contain a teaser of the item.
-- The item is loaded from the given snapshot (which should be saved
-- in the user code before any templates are applied).
teaserField :: String -- ^ Key to use
-> Snapshot -- ^ Snapshot to load
-> Context String -- ^ Resulting context
teaserField = teaserFieldWithSeparator teaserSeparator
--------------------------------------------------------------------------------
-- | A context with "teaser" key which contain a teaser of the item, defined as
-- the snapshot content before the teaser separator. The item is loaded from the
-- given snapshot (which should be saved in the user code before any templates
-- are applied).
teaserFieldWithSeparator :: String -- ^ Separator to use
-> String -- ^ Key to use
-> Snapshot -- ^ Snapshot to load
-> Context String -- ^ Resulting context
teaserFieldWithSeparator separator key snapshot = field key $ \item -> do
body <- itemBody <$> loadSnapshot (itemIdentifier item) snapshot
case needlePrefix separator body of
Nothing -> fail $
"Hakyll.Web.Template.Context: no teaser defined for " ++
show (itemIdentifier item)
Just t -> return t
--------------------------------------------------------------------------------
missingField :: Context a
missingField = Context $ \k _ i -> fail $
"Missing field $" ++ k ++ "$ in context for item " ++
show (itemIdentifier i)
parseTimeM :: Bool -> TimeLocale -> String -> String -> Maybe UTCTime
#if MIN_VERSION_time(1,5,0)
parseTimeM = TF.parseTimeM
#else
parseTimeM _ = TF.parseTime
#endif