{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-|
Module      : Knit.Report.Other.Lucid
Description : freer-simple random effect
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 Lucid.  Particularly to support adding latex and hvega charts.
-}
module Knit.Report.Other.Lucid
  (
    -- * Setup, headers, scripts, etc.
    makeReportHtml
    -- * add specific report bits
  , placeVisualization
  , placeTextSection
  , latexToHtml
  -- * helpers
  , 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 Lucid                      as H
import qualified Text.Pandoc                as P

-- | Convert Latex to Lucid 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 ()
forall arg result. Term arg result => arg -> result
H.span_ (String -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
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 ()
forall arg result. Term arg result => arg -> result
H.span_ (Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
H.toHtmlRaw Text
htmlText)

-- | Convert Latex to Lucid Html
latex_ :: T.Text -> H.Html ()
latex_ :: Text -> Html ()
latex_ = Text -> Html ()
latexToHtml

-- | Add headers for MathJax
mathJaxScript :: H.Html ()
mathJaxScript :: Html ()
mathJaxScript = [Attribute] -> String -> Html ()
forall arg result. TermRaw arg result => arg -> result
H.script_ [Text -> Attribute
H.src_ "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-MML-AM_CHTML", Text -> Attribute
H.async_ ""] ("" :: String)

-- | Add headers to use vega-lite (v2)
vegaScripts2 :: H.Html ()
vegaScripts2 :: Html ()
vegaScripts2 = do
  [Attribute] -> String -> Html ()
forall arg result. TermRaw arg result => arg -> result
H.script_ [Text -> Attribute
H.src_ "https://cdn.jsdelivr.net/npm/vega@4.4.0"] ("" :: String)
  [Attribute] -> String -> Html ()
forall arg result. TermRaw arg result => arg -> result
H.script_ [Text -> Attribute
H.src_ "https://cdn.jsdelivr.net/npm/vega-lite@3.0.0-rc11"] ("" :: String)
  [Attribute] -> String -> Html ()
forall arg result. TermRaw arg result => arg -> result
H.script_ [Text -> Attribute
H.src_ "https://cdn.jsdelivr.net/npm/vega-embed@3.28.0"] ("" :: String)

-- | Add headers to use vega-lite (v3)
vegaScripts3 :: H.Html ()
vegaScripts3 :: Html ()
vegaScripts3 = do
  [Attribute] -> String -> Html ()
forall arg result. TermRaw arg result => arg -> result
H.script_ [Text -> Attribute
H.src_ "https://cdn.jsdelivr.net/npm/vega@4.4.0/build/vega.js"] ("" :: String)
  [Attribute] -> String -> Html ()
forall arg result. TermRaw arg result => arg -> result
H.script_ [Text -> Attribute
H.src_ "https://cdn.jsdelivr.net/npm/vega-lite@3.0.0-rc12/build/vega-lite.js"] ("" :: String)
  [Attribute] -> String -> Html ()
forall arg result. TermRaw arg result => arg -> result
H.script_ [Text -> Attribute
H.src_ "https://cdn.jsdelivr.net/npm/vega-embed@3.29.1/build/vega-embed.js"] ("" :: String)

-- | Add headers to use Tufte css
tufteSetup :: H.Html ()
tufteSetup :: Html ()
tufteSetup = do
   [Attribute] -> Html ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
H.link_ [Text -> Attribute
H.rel_ "stylesheet", Text -> Attribute
H.href_ "https://cdnjs.cloudflare.com/ajax/libs/tufte-css/1.4/tufte.min.css"]
   [Attribute] -> Html ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
H.meta_ [Text -> Attribute
H.name_ "viewport", Text -> Attribute
H.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 a -> H.Html a
makeReportHtml :: Text -> Html a -> Html a
makeReportHtml title :: Text
title reportHtml :: Html a
reportHtml = Html a -> Html a
forall arg result. Term arg result => arg -> result
H.html_ (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$ Html ()
htmlHead Html () -> Html a -> Html a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Html a -> Html a
forall arg result. Term arg result => arg -> result
H.body_ (Html a -> Html a
forall arg result. Term arg result => arg -> result
H.article_ Html a
reportHtml) where
  Html ()
htmlHead :: H.Html () = Html () -> Html ()
forall arg result. Term arg result => arg -> result
H.head_ (do
                                  Html () -> Html ()
forall arg result. Term arg result => arg -> result
H.title_ (Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
H.toHtmlRaw Text
title)
                                  Html ()
tufteSetup
                                  Html ()
mathJaxScript
                                  Html ()
vegaScripts2
                                  () -> Html ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                              )

-- | 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 [Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
H.figure_ [Text -> Attribute
H.id_ Text
idText] ([Attribute] -> Html () -> Html ()
forall arg result. TermRaw arg result => arg -> result
H.script_ [Text -> Attribute
H.type_ "text/javascript"]  (Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
H.toHtmlRaw Text
script))

-- | add the given Html as a new section
placeTextSection :: H.Html () -> H.Html ()
placeTextSection :: Html () -> Html ()
placeTextSection  = [Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
H.section_ [{- attributes/styles here -}]