{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
module Knit.Report.Input.Visualization.Hvega
(
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
addHvega
:: ( PM.PandocEffects effs
, P.Member PE.ToPandoc effs
, P.Member KUI.UnusedId effs
)
=> Maybe T.Text
-> Maybe T.Text
-> 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
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