{-# LANGUAGE OverloadedStrings #-}
module Eventlog.HtmlTemplate where

import Data.Aeson (Value, encode)
import Data.Aeson.Text (encodeToLazyText)
import Data.String
import Data.Text (Text, append)
import qualified Data.Text as T
import qualified Data.Text.Lazy.Encoding as T
import qualified Data.Text.Lazy as TL
--import Text.Blaze.Html
import Text.Blaze.Html5            as H
import Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html.Renderer.String

import Eventlog.Javascript
import Eventlog.Args
import Eventlog.Types (Header(..), HeapProfBreakdown(..))
import Eventlog.VegaTemplate
import Eventlog.AssetVersions
import Paths_eventlog2html
import Data.Version
import Control.Monad
import Data.Maybe

type VizID = Int

insertJsonData :: Value -> Html
insertJsonData :: Value -> Html
insertJsonData Value
dat = Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [
    Text
"data_json= " Text -> Text -> Text
`append` Text
dat' Text -> Text -> Text
`append` Text
";"
  , Text
"console.log(data_json);" ]
  where
    dat' :: Text
dat' = Text -> Text
TL.toStrict (ByteString -> Text
T.decodeUtf8 (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
dat))

insertJsonDesc :: Value -> Html
insertJsonDesc :: Value -> Html
insertJsonDesc Value
dat = Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [
    Text
"desc_json= " Text -> Text -> Text
`append` Text
dat' Text -> Text -> Text
`append` Text
";"
  , Text
"console.log(desc_json);" ]
  where
    dat' :: Text
dat' = Text -> Text
TL.toStrict (ByteString -> Text
T.decodeUtf8 (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
dat))

-- Dynamically bound in ccs tree
insertColourScheme :: Text -> Html
insertColourScheme :: Text -> Html
insertColourScheme Text
scheme = Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [
    Text
"colour_scheme= \"" Text -> Text -> Text
`append` Text
scheme Text -> Text -> Text
`append` Text
"\";"
  , Text
"console.log(colour_scheme);" ]


data_sets :: [Text] -> [Text]
data_sets :: [Text] -> [Text]
data_sets [Text]
itd = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map Text -> Text
forall a. (Semigroup a, IsString a) => a -> a
line [Text]
itd
 where
  line :: a -> a
line a
t = a
"res.view.insert(\"data_json_" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
t a -> a -> a
forall a. Semigroup a => a -> a -> a
<>a
"\", data_json."a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
t a -> a -> a
forall a. Semigroup a => a -> a -> a
<>a
");"

data IncludeTraceData = TraceData | NoTraceData

encloseScript :: [Text] -> VizID -> Text -> Html
encloseScript :: [Text] -> VizID -> Text -> Html
encloseScript = [Text] -> VizID -> Text -> Html
encloseScriptX

encloseRawVegaScript :: VizID -> Text -> Html
encloseRawVegaScript :: VizID -> Text -> Html
encloseRawVegaScript = [Text] -> VizID -> Text -> Html
encloseScriptX []

encloseScriptX :: [Text] -> VizID -> Text -> Html
encloseScriptX :: [Text] -> VizID -> Text -> Html
encloseScriptX [Text]
insert_data_sets VizID
vid Text
vegaspec = Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ([
  Text
"var yourVlSpec" Text -> Text -> Text
`append` Text
vidt Text -> Text -> Text
`append`Text
"= " Text -> Text -> Text
`append` Text
vegaspec  Text -> Text -> Text
`append` Text
";"
  , Text
"vegaEmbed('#vis" Text -> Text -> Text
`append` Text
vidt Text -> Text -> Text
`append` Text
"', yourVlSpec" Text -> Text -> Text
`append` Text
vidt Text -> Text -> Text
`append` Text
")"
  , Text
".then((res) => { " ]
-- For the 4 vega lite charts we dynamically insert the data after the
-- chart is created to avoid duplicating it. For the vega chart, this
-- causes a harmless error so we just don't do it.
  [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ ([Text] -> [Text]
data_sets [Text]
insert_data_sets) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++
  [ Text
"; res.view.resize()"
  , Text
"; res.view.runAsync()"
  , Text
"})" ])
  where
    vidt :: Text
vidt = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ VizID -> String
forall a. Show a => a -> String
show VizID
vid

jsScript :: String -> Html
jsScript :: String -> Html
jsScript String
url = Html -> Html
script (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
src (String -> AttributeValue
forall a. IsString a => String -> a
fromString (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ String
url) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
""
css :: AttributeValue -> Html
css :: AttributeValue -> Html
css AttributeValue
url = Html
link Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
rel AttributeValue
"stylesheet" Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href AttributeValue
url

htmlHeader :: Value -> Maybe Value -> Args -> Html
htmlHeader :: Value -> Maybe Value -> Args -> Html
htmlHeader Value
dat Maybe Value
desc Args
as =
    Html -> Html
H.head (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
H.title Html
"eventlog2html - Heap Profile"
    Html
meta Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
charset AttributeValue
"UTF-8"
    Html -> Html
script (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Value -> Html
insertJsonData Value
dat
    Html -> (Value -> Html) -> Maybe Value -> Html
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Html
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Html -> Html
script (Html -> Html) -> (Value -> Html) -> Value -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Html
insertJsonDesc) Maybe Value
desc
    Html -> Html
script (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
insertColourScheme (Args -> Text
userColourScheme Args
as)
    if Bool -> Bool
not (Args -> Bool
noIncludejs Args
as)
      then do
        Html -> Html
script (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml Text
vegaLite
        Html -> Html
script (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml Text
vega
        Html -> Html
script (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml Text
vegaEmbed
        Html -> Html
script (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml Text
jquery
        Html -> Html
H.style  (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml Text
bootstrapCSS
        Html -> Html
script (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml Text
bootstrap
        Html -> Html
script (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml Text
fancytable
        Html -> Html
script (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml Text
sparkline
      else do
        String -> Html
jsScript String
vegaURL
        String -> Html
jsScript String
vegaLiteURL
        String -> Html
jsScript String
vegaEmbedURL
        String -> Html
jsScript String
jqueryURL
        AttributeValue -> Html
css (String -> AttributeValue
preEscapedStringValue String
bootstrapCSSURL)
        String -> Html
jsScript String
bootstrapURL
        AttributeValue -> Html
css AttributeValue
"//fonts.googleapis.com/css?family=Roboto:300,300italic,700,700italic"
        String -> Html
jsScript String
fancyTableURL
        String -> Html
jsScript String
sparklinesURL
    -- Include this last to overwrite some milligram styling
    Html -> Html
H.style (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml Text
stylesheet


template :: Header -> Value -> Maybe Value -> Maybe Html -> Args -> Html
template :: Header -> Value -> Maybe Value -> Maybe Html -> Args -> Html
template Header
header' Value
dat Maybe Value
cc_descs Maybe Html
closure_descs Args
as = Html -> Html
docTypeHtml (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
  String -> Html
H.stringComment (String -> Html) -> String -> Html
forall a b. (a -> b) -> a -> b
$ String
"Generated with eventlog2html-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Version -> String
showVersion Version
version
  Value -> Maybe Value -> Args -> Html
htmlHeader Value
dat Maybe Value
cc_descs Args
as
  Html -> Html
body (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"container" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"row" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"column" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
h1 (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
href AttributeValue
"https://mpickering.github.io/eventlog2html" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"eventlog2html"

    Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"row" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"column" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html
"Options: "
        Html -> Html
code (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
toHtml (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Header -> Text
hJob Header
header'

    Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"row" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"column" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html
"Created at: "
        Html -> Html
code (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
toHtml (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Header -> Text
hDate Header
header'

    Maybe HeapProfBreakdown -> (HeapProfBreakdown -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Header -> Maybe HeapProfBreakdown
hHeapProfileType Header
header') ((HeapProfBreakdown -> Html) -> Html)
-> (HeapProfBreakdown -> Html) -> Html
forall a b. (a -> b) -> a -> b
$ \HeapProfBreakdown
prof_type -> do
      Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"row" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"column" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          Html
"Type of profile: "
          Html -> Html
code (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
toHtml (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ HeapProfBreakdown -> Text
ppHeapProfileType HeapProfBreakdown
prof_type

    Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"row" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"column" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html
"Sampling rate in seconds: "
        Html -> Html
code (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
toHtml (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Header -> Text
hSamplingRate Header
header'

    Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"row" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"column" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
button (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"tablink button-black" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
onclick AttributeValue
"changeTab('areachart', this)" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"defaultOpen" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Area Chart"
        Html -> Html
button (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"tablink button-black" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
onclick AttributeValue
"changeTab('normalizedchart', this)" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Normalized"
        Html -> Html
button (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"tablink button-black" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
onclick AttributeValue
"changeTab('streamgraph', this)" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Streamgraph"
        Html -> Html
button (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"tablink button-black" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
onclick AttributeValue
"changeTab('linechart', this)" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Linechart"
        Html -> Html
button (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"tablink button-black" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
onclick AttributeValue
"changeTab('heapchart', this)" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Heap"
        Bool -> Html -> Html
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Value -> Bool
forall a. Maybe a -> Bool
isJust Maybe Value
cc_descs) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          Html -> Html
button (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"tablink button-black" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
onclick AttributeValue
"changeTab('cost-centres', this)" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Cost Centres"
        Bool -> Html -> Html
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Html -> Bool
forall a. Maybe a -> Bool
isJust Maybe Html
closure_descs) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          Html -> Html
button (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"tablink button-black" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
onclick AttributeValue
"changeTab('closures', this)" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Detailed"
    Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"row" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"column" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        let itd :: IncludeTraceData
itd = if (Args -> Bool
noTraces Args
as) then IncludeTraceData
NoTraceData else IncludeTraceData
TraceData
        ((VizID, AttributeValue, ChartType) -> Html)
-> [(VizID, AttributeValue, ChartType)] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(VizID
vid, AttributeValue
chartname, ChartType
conf) ->
                  Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
chartname (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"tabviz" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
                    IncludeTraceData -> ChartType -> Bool -> VizID -> Text -> Html
renderChart IncludeTraceData
itd ChartType
conf Bool
True VizID
vid
                      (Text -> Text
TL.toStrict (Value -> Text
forall a. ToJSON a => a -> Text
encodeToLazyText (ChartConfig -> Value
vegaJson (Args -> ChartType -> ChartConfig
htmlConf Args
as ChartType
conf)))))
          [(VizID
1, AttributeValue
"areachart",  AreaChartType -> ChartType
AreaChart AreaChartType
Stacked)
          ,(VizID
2, AttributeValue
"normalizedchart", AreaChartType -> ChartType
AreaChart AreaChartType
Normalized)
          ,(VizID
3, AttributeValue
"streamgraph", AreaChartType -> ChartType
AreaChart AreaChartType
StreamGraph)
          ,(VizID
4, AttributeValue
"linechart", ChartType
LineChart)
          ,(VizID
5, AttributeValue
"heapchart", ChartType
HeapChart) ]

        Bool -> Html -> Html
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Value -> Bool
forall a. Maybe a -> Bool
isJust Maybe Value
cc_descs) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"cost-centres" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"tabviz" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
            IncludeTraceData -> ChartType -> Bool -> VizID -> Text -> Html
renderChart IncludeTraceData
itd ChartType
LineChart Bool
False VizID
6 Text
treevega
        Maybe Html -> (Html -> Html) -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Html
closure_descs ((Html -> Html) -> Html) -> (Html -> Html) -> Html
forall a b. (a -> b) -> a -> b
$ \Html
v -> do
          Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"closures" (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"tabviz" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
            Html
v
    Html -> Html
script (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToHtml Text
tablogic


select_data :: IncludeTraceData -> ChartType -> [Text]
select_data :: IncludeTraceData -> ChartType -> [Text]
select_data IncludeTraceData
itd ChartType
c =
  case ChartType
c of
    AreaChart {} -> [Text]
prof_data
    LineChart {} -> [Text]
prof_data
    HeapChart {} -> [Text
"heap"] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
"traces" | IncludeTraceData
TraceData <- [IncludeTraceData
itd]]
  where
    prof_data :: [Text]
prof_data =  [Text
"samples"] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
"traces" | IncludeTraceData
TraceData <- [IncludeTraceData
itd]]



htmlConf :: Args -> ChartType -> ChartConfig
htmlConf :: Args -> ChartType -> ChartConfig
htmlConf Args
as ChartType
ct = Double
-> Double
-> Bool
-> Text
-> Text
-> ChartType
-> Maybe Double
-> ChartConfig
ChartConfig Double
1200 Double
1000 (Bool -> Bool
not (Args -> Bool
noTraces Args
as)) (Args -> Text
userColourScheme Args
as) Text
"set1" ChartType
ct (VizID -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (VizID -> Double) -> Maybe VizID -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Args -> Maybe VizID
fixedYAxis Args
as))

renderChart :: IncludeTraceData -> ChartType -> Bool -> VizID -> Text -> Html
renderChart :: IncludeTraceData -> ChartType -> Bool -> VizID -> Text -> Html
renderChart IncludeTraceData
itd ChartType
ct Bool
vega_lite VizID
vid Text
vegaSpec = do
    let fields :: [Text]
fields = IncludeTraceData -> ChartType -> [Text]
select_data IncludeTraceData
itd ChartType
ct
    Html -> Html
H.div (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id (String -> AttributeValue
forall a. IsString a => String -> a
fromString (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ String
"vis" String -> String -> String
forall a. [a] -> [a] -> [a]
++ VizID -> String
forall a. Show a => a -> String
show VizID
vid) (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
class_ AttributeValue
"chart" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
""
    Html -> Html
script (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
type_ AttributeValue
"text/javascript" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      if Bool
vega_lite
        then [Text] -> VizID -> Text -> Html
encloseScript [Text]
fields VizID
vid Text
vegaSpec
        else VizID -> Text -> Html
encloseRawVegaScript VizID
vid Text
vegaSpec

renderChartWithJson :: IncludeTraceData -> ChartType -> Int -> Value -> Text -> Html
renderChartWithJson :: IncludeTraceData -> ChartType -> VizID -> Value -> Text -> Html
renderChartWithJson IncludeTraceData
itd ChartType
ct VizID
k Value
dat Text
vegaSpec = do
    Html -> Html
script (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Value -> Html
insertJsonData Value
dat
    IncludeTraceData -> ChartType -> Bool -> VizID -> Text -> Html
renderChart IncludeTraceData
itd ChartType
ct Bool
True VizID
k Text
vegaSpec


templateString :: Header -> Value -> Maybe Value -> Maybe Html -> Args -> String
templateString :: Header -> Value -> Maybe Value -> Maybe Html -> Args -> String
templateString Header
header' Value
dat Maybe Value
cc_descs Maybe Html
closure_descs Args
as =
  Html -> String
renderHtml (Html -> String) -> Html -> String
forall a b. (a -> b) -> a -> b
$ Header -> Value -> Maybe Value -> Maybe Html -> Args -> Html
template Header
header' Value
dat Maybe Value
cc_descs Maybe Html
closure_descs Args
as

ppHeapProfileType :: HeapProfBreakdown -> Text
ppHeapProfileType :: HeapProfBreakdown -> Text
ppHeapProfileType (HeapProfBreakdown
HeapProfBreakdownCostCentre) = Text
"Cost centre profiling (implied by -hc)"
ppHeapProfileType (HeapProfBreakdown
HeapProfBreakdownModule) = Text
"Profiling by module (implied by -hm)"
ppHeapProfileType (HeapProfBreakdown
HeapProfBreakdownClosureDescr) = Text
"Profiling by closure description (implied by -hd)"
ppHeapProfileType (HeapProfBreakdown
HeapProfBreakdownTypeDescr) = Text
"Profiling by type (implied by -hy)"
ppHeapProfileType (HeapProfBreakdown
HeapProfBreakdownRetainer) = Text
"Retainer profiling (implied by -hr)"
ppHeapProfileType (HeapProfBreakdown
HeapProfBreakdownBiography) = Text
"Biographical profiling (implied by -hb)"
ppHeapProfileType (HeapProfBreakdown
HeapProfBreakdownClosureType) = Text
"Basic heap profile (implied by -hT)"
ppHeapProfileType (HeapProfBreakdown
HeapProfBreakdownInfoTable) = Text
"Info table profile (implied by -hi)"