{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-|
Module      : Knit.Report.Other.Blaze
Description : Support functions for simple reports in Blaze
Copyright   : (c) Adam Conner-Sax 2019
License     : BSD-3-Clause
Maintainer  : adam_conner_sax@yahoo.com
Stability   : experimental

Functions to support some simple reports using only Blaze.

Using the Pandoc framework instead is recommended.  
-}
module Knit.Report.Other.Blaze
  (
    -- * Add relevant headers, scripts
    makeReportHtml
    -- * add report pieces
  , placeVisualization
  , placeTextSection
  , latexToHtml
  , latex_
  )
where

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 H
import           Text.Blaze.Html5               ( (!) )
import qualified Text.Blaze.Html5.Attributes   as HA
import qualified Text.Pandoc                   as P

-- | Convert Latex to Blaze Html
latexToHtml :: T.Text -> H.Html
latexToHtml :: Text -> Html
latexToHtml lText :: Text
lText = do
  let
    latexReadOptions :: ReaderOptions
latexReadOptions = ReaderOptions
forall a. Default a => a
P.def
    htmlWriteOptions :: WriterOptions
htmlWriteOptions = WriterOptions
forall a. Default a => a
P.def { writerHTMLMathMethod :: HTMLMathMethod
P.writerHTMLMathMethod = Text -> HTMLMathMethod
P.MathJax "" }
    asHtml :: PandocPure Text
asHtml =
      ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *).
PandocMonad m =>
ReaderOptions -> Text -> m Pandoc
P.readLaTeX ReaderOptions
latexReadOptions Text
lText PandocPure Pandoc -> (Pandoc -> PandocPure Text) -> PandocPure Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
P.writeHtml5String WriterOptions
htmlWriteOptions
  case PandocPure Text -> Either PandocError Text
forall a. PandocPure a -> Either PandocError a
P.runPure PandocPure Text
asHtml of
    Left  err :: PandocError
err      -> Html -> Html
H.span (String -> Html
forall a. ToMarkup a => a -> Html
H.toHtml (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ PandocError -> String
forall a. Show a => a -> String
show PandocError
err)
    Right htmlText :: Text
htmlText -> Html -> Html
H.span (Text -> Html
forall a. ToMarkup a => a -> Html
H.preEscapedToHtml Text
htmlText)

latex_ :: T.Text -> H.Html
latex_ :: Text -> Html
latex_ = Text -> Html
latexToHtml

mathJaxScript :: H.Html
mathJaxScript :: Html
mathJaxScript =
  Html -> Html
H.script
    (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.src
        "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-MML-AM_CHTML"
    (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.async ""
    (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ ""



vegaScripts2 :: H.Html
vegaScripts2 :: Html
vegaScripts2 = do
  Html -> Html
H.script (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.src "https://cdn.jsdelivr.net/npm/vega@4.4.0" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ ""
  Html -> Html
H.script (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.src "https://cdn.jsdelivr.net/npm/vega-lite@3.0.0-rc11" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ ""
  Html -> Html
H.script (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.src "https://cdn.jsdelivr.net/npm/vega-embed@3.28.0" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ ""

vegaScripts3 :: H.Html
vegaScripts3 :: Html
vegaScripts3 = do
  Html -> Html
H.script (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.src "https://cdn.jsdelivr.net/npm/vega@4.4.0/build/vega.js" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ ""
  Html -> Html
H.script
    (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.src
        "https://cdn.jsdelivr.net/npm/vega-lite@3.0.0-rc12/build/vega-lite.js"
    (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ ""
  Html -> Html
H.script
    (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.src
        "https://cdn.jsdelivr.net/npm/vega-embed@3.29.1/build/vega-embed.js"
    (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ ""

-- | Add headers for using Tufte css
tufteSetup :: H.Html
tufteSetup :: Html
tufteSetup = do
  Html
H.link Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.rel "stylesheet" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.href
    "https://cdnjs.cloudflare.com/ajax/libs/tufte-css/1.4/tufte.min.css"
  Html
H.meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.name "viewport" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.content "width=device-width, initial-scale=1"

-- | Wrap given html in appropriate headers for the hvega and latex functions to work
makeReportHtml :: T.Text -> H.Html -> H.Html
makeReportHtml :: Text -> Html -> Html
makeReportHtml title :: Text
title reportHtml :: Html
reportHtml = Html -> Html
H.html (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.docTypeHtml (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
  Html -> Html
H.head (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
H.title (Text -> Html
forall a. ToMarkup a => a -> Html
H.toHtml Text
title)
    Html
tufteSetup
    Html
mathJaxScript
    Html
vegaScripts2
  Html -> Html
H.body (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.article (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
reportHtml

-- | Add an hvega visualization with the given id
placeVisualization :: T.Text -> GV.VegaLite -> H.Html
placeVisualization :: Text -> VegaLite -> Html
placeVisualization idText :: Text
idText 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
H.figure
      (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.id (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
idText)
      (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.script
      (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
HA.type_ "text/javascript"
      (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
H.preEscapedToHtml Text
script

-- | Add the given Html as a new section
placeTextSection :: H.Html -> H.Html
placeTextSection :: Html -> Html
placeTextSection = Html -> Html
H.section