    {-# LANGUAGE OverloadedStrings #-}

    {- |

    JSON-LD metadata, using <https://schema.org/ Schema.org> vocabulary
    for articles.  Google applications and other search engines use
    these data to improve search results and links.

    This implementation supports the following fields:

    +-------------------+----------------------------------------------------+
    | @\@type@          | __Hardcoded__ value @\"Article"@.                  |
    +-------------------+----------------------------------------------------+
    | @headline@        | __Required__ taken from context field @title@.     |
    +-------------------+----------------------------------------------------+
    | @datePublished@   | __Required__ date of publication, via 'dateField'. |
    +-------------------+----------------------------------------------------+

    To use, add a 'jsonldField' to your template context:

    @
    let
      context = 'defaultContext' <> …
      postContext =
        context
        <> 'jsonldField' "jsonld" context
    @

    And update the template:

    @
    \<head>
      \<title>$title$\</title>
      \<link rel="stylesheet" type="text\/css" href="\/css\/default.css" />
      $if(jsonld)$$jsonld("embed")$$endif$
    \</head>
    @

    The @"embed"@ argument generates a @\<script …>@ tag to be directly
    included in page HTML.  To get the raw JSON string, use @"raw"@
    instead.

    -}
    module Hakyll.Web.Meta.JSONLD
      ( jsonldField
      ) where

    import Data.Aeson ((.=), pairs)
    import Data.Aeson.Encoding (encodingToLazyByteString)
    import qualified Data.Text.Lazy as LT
    import qualified Data.Text.Lazy.Encoding as LT

    import Hakyll.Core.Compiler
    import Hakyll.Core.Compiler.Internal
    import Hakyll.Core.Item
    import Hakyll.Web.Template
    import Hakyll.Web.Template.Context

    runContext :: Context String -> String -> Compiler String
    runContext :: Context String -> String -> Compiler String
    runContext Context String
    ctx String
    k = do
      Item String
    i <- String -> Compiler (Item String)
    forall a. a -> Compiler (Item a)
    makeItem String
    "dummy"
      Context String
    -> String -> [String] -> Item String -> Compiler ContextField
    forall a.
    Context a -> String -> [String] -> Item a -> Compiler ContextField
    unContext Context String
    ctx String
    k [] Item String
    i Compiler ContextField
    -> (ContextField -> Compiler String) -> Compiler String
    forall a b. Compiler a -> (a -> Compiler b) -> Compiler b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \ContextField
    cf -> case ContextField
    cf of
        StringField String
    s -> String -> Compiler String
    forall a. a -> Compiler a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure String
    s
        ContextField
    _             -> String -> Compiler String
    forall a. String -> Compiler a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Compiler String) -> String -> Compiler String
    forall a b. (a -> b) -> a -> b
    $ String
    "Error: '" String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    k String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "' is not a StringField"

    getContext :: Context String -> String -> Compiler String
    getContext :: Context String -> String -> Compiler String
    getContext Context String
    ctx String
    k = Compiler String -> Compiler (Either (CompilerErrors String) String)
    forall a. Compiler a -> Compiler (Either (CompilerErrors String) a)
    compilerTry (Context String -> String -> Compiler String
    runContext Context String
    ctx String
    k) Compiler (Either (CompilerErrors String) String)
    -> (Either (CompilerErrors String) String -> Compiler String)
    -> Compiler String
    forall a b. Compiler a -> (a -> Compiler b) -> Compiler b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (CompilerErrors String -> Compiler String)
    -> (String -> Compiler String)
    -> Either (CompilerErrors String) String
    -> Compiler String
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either CompilerErrors String -> Compiler String
    forall {a}. CompilerErrors String -> Compiler a
    f String -> Compiler String
    forall a. a -> Compiler a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure
      where
      f :: CompilerErrors String -> Compiler a
    f (CompilationNoResult [String]
    _) = CompilerResult a -> Compiler a
    forall a. CompilerResult a -> Compiler a
    compilerResult (CompilerResult a -> Compiler a)
    -> (String -> CompilerResult a) -> String -> Compiler a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CompilerErrors String -> CompilerResult a
    forall a. CompilerErrors String -> CompilerResult a
    CompilerError (CompilerErrors String -> CompilerResult a)
    -> (String -> CompilerErrors String) -> String -> CompilerResult a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . NonEmpty String -> CompilerErrors String
    forall a. NonEmpty a -> CompilerErrors a
    CompilationFailure (NonEmpty String -> CompilerErrors String)
    -> (String -> NonEmpty String) -> String -> CompilerErrors String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> NonEmpty String
    forall a. a -> NonEmpty a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (String -> Compiler a) -> String -> Compiler a
    forall a b. (a -> b) -> a -> b
    $
                                  String
    "missing required field '" String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    k String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "'"
      f CompilerErrors String
    err = CompilerResult a -> Compiler a
    forall a. CompilerResult a -> Compiler a
    compilerResult (CompilerErrors String -> CompilerResult a
    forall a. CompilerErrors String -> CompilerResult a
    CompilerError CompilerErrors String
    err)

    -- This may come in handy later
    _lookupContext :: Context String -> String -> Compiler (Maybe String)
    _lookupContext :: Context String -> String -> Compiler (Maybe String)
    _lookupContext Context String
    ctx String
    k = Compiler String -> Compiler (Either (CompilerErrors String) String)
    forall a. Compiler a -> Compiler (Either (CompilerErrors String) a)
    compilerTry (Context String -> String -> Compiler String
    runContext Context String
    ctx String
    k) Compiler (Either (CompilerErrors String) String)
    -> (Either (CompilerErrors String) String
        -> Compiler (Maybe String))
    -> Compiler (Maybe String)
    forall a b. Compiler a -> (a -> Compiler b) -> Compiler b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (CompilerErrors String -> Compiler (Maybe String))
    -> (String -> Compiler (Maybe String))
    -> Either (CompilerErrors String) String
    -> Compiler (Maybe String)
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either CompilerErrors String -> Compiler (Maybe String)
    forall {a}. CompilerErrors String -> Compiler (Maybe a)
    f (Maybe String -> Compiler (Maybe String)
    forall a. a -> Compiler a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Maybe String -> Compiler (Maybe String))
    -> (String -> Maybe String) -> String -> Compiler (Maybe String)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Maybe String
    forall a. a -> Maybe a
    Just)
      where
      f :: CompilerErrors String -> Compiler (Maybe a)
    f (CompilationNoResult [String]
    _) = Maybe a -> Compiler (Maybe a)
    forall a. a -> Compiler a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Maybe a
    forall a. Maybe a
    Nothing
      f CompilerErrors String
    err = CompilerResult (Maybe a) -> Compiler (Maybe a)
    forall a. CompilerResult a -> Compiler a
    compilerResult (CompilerErrors String -> CompilerResult (Maybe a)
    forall a. CompilerErrors String -> CompilerResult a
    CompilerError CompilerErrors String
    err)

    -- | Render JSON-LD for an article.
    -- Requires context with "title", and the item must be able to yield
    -- a valid date via 'getItemUTC'
    --
    renderJSONLD :: Context String -> Compiler (Item String)
    renderJSONLD :: Context String -> Compiler (Item String)
    renderJSONLD Context String
    ctx = do
      String
    dateString <- Context String -> String -> Compiler String
    getContext (String -> String -> Context String
    forall a. String -> String -> Context a
    dateField String
    "" String
    "%Y-%m-%dT%H:%M:%S") String
    ""
      String
    titleString <- Context String -> String -> Compiler String
    getContext Context String
    ctx String
    "title"

      let
        obj :: Encoding
    obj = Series -> Encoding
    pairs (Series -> Encoding) -> Series -> Encoding
    forall a b. (a -> b) -> a -> b
    $
          Key
    "@context" Key -> String -> Series
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Series
    .= (String
    "https://schema.org" :: String)
          Series -> Series -> Series
    forall a. Semigroup a => a -> a -> a
    <> Key
    "@type" Key -> String -> Series
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Series
    .= (String
    "Article" :: String)
          Series -> Series -> Series
    forall a. Semigroup a => a -> a -> a
    <> Key
    "headline" Key -> String -> Series
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Series
    .= String
    titleString
          Series -> Series -> Series
    forall a. Semigroup a => a -> a -> a
    <> Key
    "datePublished" Key -> String -> Series
    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
    forall v. ToJSON v => Key -> v -> Series
    .= String
    dateString

      String -> Compiler (Item String)
    forall a. a -> Compiler (Item a)
    makeItem (String -> Compiler (Item String))
    -> (Encoding -> String) -> Encoding -> Compiler (Item String)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> String
    LT.unpack (Text -> String) -> (Encoding -> Text) -> Encoding -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> Text
    LT.decodeUtf8 (ByteString -> Text)
    -> (Encoding -> ByteString) -> Encoding -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Encoding -> ByteString
    forall a. Encoding' a -> ByteString
    encodingToLazyByteString (Encoding -> Compiler (Item String))
    -> Encoding -> Compiler (Item String)
    forall a b. (a -> b) -> a -> b
    $ Encoding
    obj

    jsonldField :: String -> Context String -> Context String
    jsonldField :: String -> Context String -> Context String
    jsonldField String
    k Context String
    ctx = String
    -> ([String] -> Item String -> Compiler String) -> Context String
    forall a.
    String -> ([String] -> Item a -> Compiler String) -> Context a
    functionField String
    k (\[String]
    args Item String
    _i -> [String] -> Compiler String
    forall {a}. (Eq a, IsString a) => [a] -> Compiler String
    go [String]
    args)
      where
      -- The zero argument case cannot be a compiler error,
      -- otherwise @$if(k)$@ evaluates false.
      go :: [a] -> Compiler String
    go [] = String -> Compiler String
    forall a. a -> Compiler a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (String -> Compiler String) -> String -> Compiler String
    forall a b. (a -> b) -> a -> b
    $ String
    "<!-- Whoops! Try this instead: $if(" String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    k String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    ")$$" String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    k String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "(\"embed\")$$endif$ -->"
      go [a
    "raw"] = Item String -> String
    forall a. Item a -> a
    itemBody (Item String -> String)
    -> Compiler (Item String) -> Compiler String
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Context String -> Compiler (Item String)
    renderJSONLD Context String
    ctx
      go [a
    "embed"] = do
        Template
    template <- Compiler Template
    jsonldTemplate
        Item String
    i <- Context String -> Compiler (Item String)
    renderJSONLD Context String
    ctx Compiler (Item String)
    -> (Item String -> Compiler (Item String))
    -> Compiler (Item String)
    forall a b. Compiler a -> (a -> Compiler b) -> Compiler b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Template -> Context String -> Item String -> Compiler (Item String)
    forall a. Template -> Context a -> Item a -> Compiler (Item String)
    applyTemplate Template
    template (String -> Context String
    bodyField String
    "body")
        String -> Compiler String
    forall a. a -> Compiler a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (String -> Compiler String) -> String -> Compiler String
    forall a b. (a -> b) -> a -> b
    $ Item String -> String
    forall a. Item a -> a
    itemBody Item String
    i
      go [a
    _] = String -> Compiler String
    forall a. String -> Compiler a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Compiler String) -> String -> Compiler String
    forall a b. (a -> b) -> a -> b
    $ String
    "invalid argument to jsonldField '" String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    k String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "'. use \"raw\" or \"embed\""
      go [a]
    _ = String -> Compiler String
    forall a. String -> Compiler a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Compiler String) -> String -> Compiler String
    forall a b. (a -> b) -> a -> b
    $ String
    "too many arguments to jsonldField '" String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    k String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "'"

    jsonldTemplate :: Compiler Template
    jsonldTemplate :: Compiler Template
    jsonldTemplate = do
      String -> Compiler (Item String)
    forall a. a -> Compiler (Item a)
    makeItem String
    "<script type=\"application/ld+json\">$body$</script>"
      Compiler (Item String)
    -> (Item String -> Compiler Template) -> Compiler Template
    forall a b. Compiler a -> (a -> Compiler b) -> Compiler b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Item String -> Compiler Template
    compileTemplateItem