{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
module Hakyll.Web.Template.Context
( ContextField (..)
, Context (..)
, field
, boolField
, constField
, listField
, listFieldWith
, functionField
, mapContext
, defaultContext
, bodyField
, metadataField
, urlField
, pathField
, titleField
, snippetField
, dateField
, dateFieldWith
, getItemUTC
, getItemModificationTime
, modificationTimeField
, modificationTimeFieldWith
, teaserField
, teaserFieldWithSeparator
, missingField
) where
import Control.Applicative (Alternative (..))
import Control.Monad (msum)
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
#endif
import Data.List (intercalate, tails)
import Data.Time.Clock (UTCTime (..))
import Data.Time.Format (formatTime, parseTimeM)
import Data.Time.Locale.Compat (TimeLocale, defaultTimeLocale)
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
import Prelude hiding (id)
import System.FilePath (dropExtension, splitDirectories,
takeBaseName)
data ContextField
= EmptyField
| StringField String
| forall a. ListField (Context a) [Item a]
newtype Context a = Context
{ forall a.
Context a -> String -> [String] -> Item a -> Compiler ContextField
unContext :: String -> [String] -> Item a -> Compiler ContextField
}
instance Semigroup (Context a) where
<> :: Context a -> Context a -> Context a
(<>) (Context String -> [String] -> Item a -> Compiler ContextField
f) (Context String -> [String] -> Item a -> Compiler ContextField
g) = forall a.
(String -> [String] -> Item a -> Compiler ContextField)
-> Context a
Context forall a b. (a -> b) -> a -> b
$ \String
k [String]
a Item a
i -> String -> [String] -> Item a -> Compiler ContextField
f String
k [String]
a Item a
i forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> [String] -> Item a -> Compiler ContextField
g String
k [String]
a Item a
i
instance Monoid (Context a) where
mempty :: Context a
mempty = forall a. Context a
missingField
mappend :: Context a -> Context a -> Context a
mappend = forall a. Semigroup a => a -> a -> a
(<>)
field' :: String -> (Item a -> Compiler ContextField) -> Context a
field' :: forall a. String -> (Item a -> Compiler ContextField) -> Context a
field' String
key Item a -> Compiler ContextField
value = forall a.
(String -> [String] -> Item a -> Compiler ContextField)
-> Context a
Context forall a b. (a -> b) -> a -> b
$ \String
k [String]
_ Item a
i ->
if String
k forall a. Eq a => a -> a -> Bool
== String
key
then Item a -> Compiler ContextField
value Item a
i
else forall a. String -> Compiler a
noResult forall a b. (a -> b) -> a -> b
$ String
"Tried field " forall a. [a] -> [a] -> [a]
++ String
key
field
:: String
-> (Item a -> Compiler String)
-> Context a
field :: forall a. String -> (Item a -> Compiler String) -> Context a
field String
key Item a -> Compiler String
value = forall a. String -> (Item a -> Compiler ContextField) -> Context a
field' String
key (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> ContextField
StringField forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item a -> Compiler String
value)
boolField
:: String
-> (Item a -> Bool)
-> Context a
boolField :: forall a. String -> (Item a -> Bool) -> Context a
boolField String
name Item a -> Bool
f = forall a. String -> (Item a -> Compiler ContextField) -> Context a
field' String
name (\Item a
i -> if Item a -> Bool
f Item a
i
then forall (m :: * -> *) a. Monad m => a -> m a
return ContextField
EmptyField
else forall a. String -> Compiler a
noResult forall a b. (a -> b) -> a -> b
$ String
"Field " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
" is false")
constField :: String
-> String
-> Context a
constField :: forall a. String -> String -> Context a
constField String
key = forall a. String -> (Item a -> Compiler String) -> Context a
field String
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return
listField :: String -> Context a -> Compiler [Item a] -> Context b
listField :: forall a b. String -> Context a -> Compiler [Item a] -> Context b
listField String
key Context a
c Compiler [Item a]
xs = forall a b.
String -> Context a -> (Item b -> Compiler [Item a]) -> Context b
listFieldWith String
key Context a
c (forall a b. a -> b -> a
const Compiler [Item a]
xs)
listFieldWith
:: String -> Context a -> (Item b -> Compiler [Item a]) -> Context b
listFieldWith :: forall a b.
String -> Context a -> (Item b -> Compiler [Item a]) -> Context b
listFieldWith String
key Context a
c Item b -> Compiler [Item a]
f = forall a. String -> (Item a -> Compiler ContextField) -> Context a
field' String
key forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Context a -> [Item a] -> ContextField
ListField Context a
c) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item b -> Compiler [Item a]
f
functionField :: String
-> ([String] -> Item a -> Compiler String)
-> Context a
functionField :: forall a.
String -> ([String] -> Item a -> Compiler String) -> Context a
functionField String
name [String] -> Item a -> Compiler String
value = forall a.
(String -> [String] -> Item a -> Compiler ContextField)
-> Context a
Context forall a b. (a -> b) -> a -> b
$ \String
k [String]
args Item a
i ->
if String
k forall a. Eq a => a -> a -> Bool
== String
name
then String -> ContextField
StringField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Item a -> Compiler String
value [String]
args Item a
i
else forall a. String -> Compiler a
noResult forall a b. (a -> b) -> a -> b
$ String
"Tried function field " forall a. [a] -> [a] -> [a]
++ String
name
mapContext :: (String -> String) -> Context a -> Context a
mapContext :: forall a. (String -> String) -> Context a -> Context a
mapContext String -> String
f (Context String -> [String] -> Item a -> Compiler ContextField
c) = forall a.
(String -> [String] -> Item a -> Compiler ContextField)
-> Context a
Context forall a b. (a -> b) -> a -> b
$ \String
k [String]
a Item a
i -> do
ContextField
fld <- String -> [String] -> Item a -> Compiler ContextField
c String
k [String]
a Item a
i
case ContextField
fld of
ContextField
EmptyField -> forall {m :: * -> *} {a}. MonadFail m => String -> m a
wrongType String
"boolField"
StringField String
str -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> ContextField
StringField (String -> String
f String
str)
ContextField
_ -> forall {m :: * -> *} {a}. MonadFail m => String -> m a
wrongType String
"ListField"
where
wrongType :: String -> m a
wrongType String
typ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Hakyll.Web.Template.Context.mapContext: " forall a. [a] -> [a] -> [a]
++
String
"can't map over a " forall a. [a] -> [a] -> [a]
++ String
typ forall a. [a] -> [a] -> [a]
++ String
"!"
snippetField :: Context String
snippetField :: Context String
snippetField = forall a.
String -> ([String] -> Item a -> Compiler String) -> Context a
functionField String
"snippet" forall {a} {p}.
(Binary a, Typeable a) =>
[String] -> p -> Compiler a
f
where
f :: [String] -> p -> Compiler a
f [String
contentsPath] p
_ = forall a. (Binary a, Typeable a) => Identifier -> Compiler a
loadBody (String -> Identifier
fromFilePath String
contentsPath)
f [] p
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No argument to function 'snippet()'"
f [String]
_ p
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Too many arguments to function 'snippet()'"
defaultContext :: Context String
defaultContext :: Context String
defaultContext =
String -> Context String
bodyField String
"body" forall a. Monoid a => a -> a -> a
`mappend`
forall a. Context a
metadataField forall a. Monoid a => a -> a -> a
`mappend`
forall a. String -> Context a
urlField String
"url" forall a. Monoid a => a -> a -> a
`mappend`
forall a. String -> Context a
pathField String
"path" forall a. Monoid a => a -> a -> a
`mappend`
forall a. String -> Context a
titleField String
"title"
teaserSeparator :: String
teaserSeparator :: String
teaserSeparator = String
"<!--more-->"
bodyField :: String -> Context String
bodyField :: String -> Context String
bodyField String
key = forall a. String -> (Item a -> Compiler String) -> Context a
field String
key forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Item a -> a
itemBody
metadataField :: Context a
metadataField :: forall a. Context a
metadataField = forall a.
(String -> [String] -> Item a -> Compiler ContextField)
-> Context a
Context forall a b. (a -> b) -> a -> b
$ \String
k [String]
_ Item a
i -> do
let id :: Identifier
id = forall a. Item a -> Identifier
itemIdentifier Item a
i
empty' :: Compiler a
empty' = forall a. String -> Compiler a
noResult forall a b. (a -> b) -> a -> b
$ String
"No '" forall a. [a] -> [a] -> [a]
++ String
k forall a. [a] -> [a] -> [a]
++ String
"' field in metadata " forall a. [a] -> [a] -> [a]
++
String
"of item " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Identifier
id
Maybe String
value <- forall (m :: * -> *).
MonadMetadata m =>
Identifier -> String -> m (Maybe String)
getMetadataField Identifier
id String
k
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. Compiler a
empty' (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ContextField
StringField) Maybe String
value
urlField :: String -> Context a
urlField :: forall a. String -> Context a
urlField String
key = forall a. String -> (Item a -> Compiler String) -> Context a
field String
key forall a b. (a -> b) -> a -> b
$ \Item a
i -> do
let id :: Identifier
id = forall a. Item a -> Identifier
itemIdentifier Item a
i
empty' :: [a]
empty' = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"No route url found for item " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Identifier
id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. [a]
empty' String -> String
toUrl) forall a b. (a -> b) -> a -> b
$ Identifier -> Compiler (Maybe String)
getRoute Identifier
id
pathField :: String -> Context a
pathField :: forall a. String -> Context a
pathField String
key = forall a. String -> (Item a -> Compiler String) -> Context a
field String
key forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> String
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Item a -> Identifier
itemIdentifier
titleField :: String -> Context a
titleField :: forall a. String -> Context a
titleField = forall a. (String -> String) -> Context a -> Context a
mapContext String -> String
takeBaseName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> Context a
pathField
dateField :: String
-> String
-> Context a
dateField :: forall a. String -> String -> Context a
dateField = forall a. TimeLocale -> String -> String -> Context a
dateFieldWith TimeLocale
defaultTimeLocale
dateFieldWith :: TimeLocale
-> String
-> String
-> Context a
dateFieldWith :: forall a. TimeLocale -> String -> String -> Context a
dateFieldWith TimeLocale
locale String
key String
format = forall a. String -> (Item a -> Compiler String) -> Context a
field String
key forall a b. (a -> b) -> a -> b
$ \Item a
i -> do
UTCTime
time <- forall (m :: * -> *).
(MonadMetadata m, MonadFail m) =>
TimeLocale -> Identifier -> m UTCTime
getItemUTC TimeLocale
locale forall a b. (a -> b) -> a -> b
$ forall a. Item a -> Identifier
itemIdentifier Item a
i
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
locale String
format UTCTime
time
getItemUTC :: (MonadMetadata m, MonadFail m)
=> TimeLocale
-> Identifier
-> m UTCTime
getItemUTC :: forall (m :: * -> *).
(MonadMetadata m, MonadFail m) =>
TimeLocale -> Identifier -> m UTCTime
getItemUTC TimeLocale
locale Identifier
id' = do
Metadata
metadata <- forall (m :: * -> *). MonadMetadata m => Identifier -> m Metadata
getMetadata Identifier
id'
let tryField :: String -> String -> Maybe UTCTime
tryField String
k String
fmt = String -> Metadata -> Maybe String
lookupString String
k Metadata
metadata forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> String -> Maybe UTCTime
parseTime' String
fmt
paths :: [String]
paths = String -> [String]
splitDirectories forall a b. (a -> b) -> a -> b
$ (String -> String
dropExtension forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> String
toFilePath) Identifier
id'
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall {a}. m a
empty' forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$
[String -> String -> Maybe UTCTime
tryField String
"published" String
fmt | String
fmt <- [String]
formats] forall a. [a] -> [a] -> [a]
++
[String -> String -> Maybe UTCTime
tryField String
"date" String
fmt | String
fmt <- [String]
formats] forall a. [a] -> [a] -> [a]
++
[String -> String -> Maybe UTCTime
parseTime' String
"%Y-%m-%d" forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
"-" forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
3 forall a b. (a -> b) -> a -> b
$ String -> String -> [String]
splitAll String
"-" String
fnCand | String
fnCand <- forall a. [a] -> [a]
reverse [String]
paths] forall a. [a] -> [a] -> [a]
++
[String -> String -> Maybe UTCTime
parseTime' String
"%Y-%m-%d" forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
"-" forall a b. (a -> b) -> a -> b
$ [String]
fnCand | [String]
fnCand <- forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
take Int
3) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]]
tails forall a b. (a -> b) -> a -> b
$ [String]
paths]
where
empty' :: m a
empty' = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Hakyll.Web.Template.Context.getItemUTC: " forall a. [a] -> [a] -> [a]
++
String
"could not parse time for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Identifier
id'
parseTime' :: String -> String -> Maybe UTCTime
parseTime' = forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
locale
formats :: [String]
formats =
[ String
"%a, %d %b %Y %H:%M:%S %Z"
, String
"%a, %d %b %Y %H:%M:%S"
, String
"%Y-%m-%dT%H:%M:%S%Z"
, String
"%Y-%m-%dT%H:%M:%S"
, String
"%Y-%m-%d %H:%M:%S%Z"
, String
"%Y-%m-%d %H:%M:%S"
, String
"%Y-%m-%d"
, String
"%d.%m.%Y"
, String
"%B %e, %Y %l:%M %p"
, String
"%B %e, %Y"
, String
"%b %d, %Y"
]
getItemModificationTime
:: Identifier
-> Compiler UTCTime
getItemModificationTime :: Identifier -> Compiler UTCTime
getItemModificationTime Identifier
identifier = do
Provider
provider <- CompilerRead -> Provider
compilerProvider forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Compiler CompilerRead
compilerAsk
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Provider -> Identifier -> UTCTime
resourceModificationTime Provider
provider Identifier
identifier
modificationTimeField :: String
-> String
-> Context a
modificationTimeField :: forall a. String -> String -> Context a
modificationTimeField = forall a. TimeLocale -> String -> String -> Context a
modificationTimeFieldWith TimeLocale
defaultTimeLocale
modificationTimeFieldWith :: TimeLocale
-> String
-> String
-> Context a
modificationTimeFieldWith :: forall a. TimeLocale -> String -> String -> Context a
modificationTimeFieldWith TimeLocale
locale String
key String
fmt = forall a. String -> (Item a -> Compiler String) -> Context a
field String
key forall a b. (a -> b) -> a -> b
$ \Item a
i -> do
UTCTime
mtime <- Identifier -> Compiler UTCTime
getItemModificationTime forall a b. (a -> b) -> a -> b
$ forall a. Item a -> Identifier
itemIdentifier Item a
i
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
locale String
fmt UTCTime
mtime
teaserField :: String
-> Snapshot
-> Context String
teaserField :: String -> String -> Context String
teaserField = String -> String -> String -> Context String
teaserFieldWithSeparator String
teaserSeparator
teaserFieldWithSeparator :: String
-> String
-> Snapshot
-> Context String
teaserFieldWithSeparator :: String -> String -> String -> Context String
teaserFieldWithSeparator String
separator String
key String
snapshot = forall a. String -> (Item a -> Compiler String) -> Context a
field String
key forall a b. (a -> b) -> a -> b
$ \Item String
item -> do
String
body <- forall a. Item a -> a
itemBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
(Binary a, Typeable a) =>
Identifier -> String -> Compiler (Item a)
loadSnapshot (forall a. Item a -> Identifier
itemIdentifier Item String
item) String
snapshot
case String -> String -> Maybe String
needlePrefix String
separator String
body of
Maybe String
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
String
"Hakyll.Web.Template.Context: no teaser defined for " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show (forall a. Item a -> Identifier
itemIdentifier Item String
item)
Just String
t -> forall (m :: * -> *) a. Monad m => a -> m a
return String
t
missingField :: Context a
missingField :: forall a. Context a
missingField = forall a.
(String -> [String] -> Item a -> Compiler ContextField)
-> Context a
Context forall a b. (a -> b) -> a -> b
$ \String
k [String]
_ Item a
_ -> forall a. String -> Compiler a
noResult forall a b. (a -> b) -> a -> b
$
String
"Missing field '" forall a. [a] -> [a] -> [a]
++ String
k forall a. [a] -> [a] -> [a]
++ String
"' in context"