{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds     #-}
{-# LANGUAGE GADTs         #-}
{-|
Module      : Knit.Report.Input.Visualization.Hvega
Description : Support functions for simple reports using Pandoc
Copyright   : (c) Adam Conner-Sax 2019
License     : BSD-3-Clause
Maintainer  : adam_conner_sax@yahoo.com
Stability   : experimental

Functions to add hvega charts (using Blaze Html) to the current Pandoc document.
-}
module Knit.Report.Input.Visualization.Hvega
  (
    -- * Add hvega Inputs
    addHvega
  )
where

import           Knit.Report.Input.Html.Blaze   ( addBlaze )

import qualified Data.Aeson.Encode.Pretty      as A
import qualified Data.ByteString.Lazy.Char8    as BS
import qualified Data.Text                     as T
import qualified Data.Text.Encoding            as T
import qualified Graphics.Vega.VegaLite        as GV
import qualified Text.Blaze.Html5              as BH
import qualified Text.Blaze.Html5.Attributes   as BHA

import qualified Polysemy                      as P
import qualified Knit.Effect.Pandoc            as PE
import qualified Knit.Effect.PandocMonad       as PM
import qualified Knit.Effect.UnusedId          as KUI


-- TODO: Add some autogenerated unique id support

-- | Add hvega (via html). Requires html since vega-lite renders using javascript.
addHvega
  :: ( PM.PandocEffects effs
     , P.Member PE.ToPandoc effs
     , P.Member KUI.UnusedId effs
     )
  => Maybe T.Text -- ^ figure id, will get next unused with prefix "figure" if Nothing
  -> Maybe T.Text -- ^ figure caption, none if Nothing
  -> GV.VegaLite
  -> P.Sem effs T.Text
addHvega :: Maybe Text -> Maybe Text -> VegaLite -> Sem effs Text
addHvega idTextM :: Maybe Text
idTextM captionTextM :: Maybe Text
captionTextM vl :: VegaLite
vl = do
  Requirement -> Sem effs ()
forall (effs :: [(* -> *) -> * -> *]).
Member ToPandoc effs =>
Requirement -> Sem effs ()
PE.require Requirement
PE.VegaSupport
  Text
idText <- Sem effs Text
-> (Text -> Sem effs Text) -> Maybe Text -> Sem effs Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Sem effs Text
forall (r :: [(* -> *) -> * -> *]).
Member UnusedId r =>
Text -> Sem r Text
KUI.getNextUnusedId "figure") Text -> Sem effs Text
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
idTextM
  Html -> Sem effs ()
forall (effs :: [(* -> *) -> * -> *]).
(PandocEffects effs, Member ToPandoc effs) =>
Html -> Sem effs ()
addBlaze (Html -> Sem effs ()) -> Html -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> VegaLite -> Html
placeVisualization Text
idText Maybe Text
captionTextM VegaLite
vl
  Text -> Sem effs Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
idText

-- | Build (Blaze) Html for  hvega visualization with the given id
placeVisualization :: T.Text -> Maybe T.Text -> GV.VegaLite -> BH.Html
placeVisualization :: Text -> Maybe Text -> VegaLite -> Html
placeVisualization idText :: Text
idText captionTextM :: Maybe Text
captionTextM vl :: VegaLite
vl =
  let Text
vegaScript :: T.Text =
        ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encodePretty (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ VegaLite -> Value
GV.fromVL VegaLite
vl
      script :: Text
script =
        "var vlSpec=\n"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
vegaScript
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ";\n"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "vegaEmbed(\'#"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
idText
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\',vlSpec);"
  in  Html -> Html
BH.figure (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
BH.! AttributeValue -> Attribute
BHA.id (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
BH.toValue Text
idText) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
BH.script (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
BH.! AttributeValue -> Attribute
BHA.type_ "text/javascript" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
BH.preEscapedToHtml Text
script
        Html -> (Text -> Html) -> Maybe Text -> Html
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Html
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Html -> Html
BH.figcaption (Html -> Html) -> (Text -> Html) -> Text -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html
forall a. ToMarkup a => a -> Html
BH.toHtml) Maybe Text
captionTextM