diff --git a/src/Eventlog/HtmlTemplate.hs b/src/Eventlog/HtmlTemplate.hs
index 16805e9..1ee7265 100644
--- a/src/Eventlog/HtmlTemplate.hs
+++ b/src/Eventlog/HtmlTemplate.hs
@@ -56,14 +56,14 @@ data_sets itd = Prelude.map line itd
where
line t = "res.view.insert(\"data_json_" <> t <>"\", data_json."<> t <>");"
-encloseScript :: [Text] -> VizID -> Text -> Html
+encloseScript :: [Text] -> TabID -> Text -> Html
encloseScript = encloseScriptX
-encloseRawVegaScript :: VizID -> Text -> Html
+encloseRawVegaScript :: TabID -> Text -> Html
encloseRawVegaScript = encloseScriptX []
-encloseScriptX :: [Text] -> VizID -> Text -> Html
-encloseScriptX insert_data_sets vid vegaspec = preEscapedToHtml $ T.unlines ([
+encloseScriptX :: [Text] -> TabID -> Text -> Html
+encloseScriptX insert_data_sets (TabID vidt) vegaspec = preEscapedToHtml $ T.unlines ([
"var yourVlSpec" `append` vidt `append`"= " `append` vegaspec `append` ";"
, "vegaEmbed('#vis" `append` vidt `append` "', yourVlSpec" `append` vidt `append` ")"
, ".then((res) => { " ]
@@ -74,8 +74,6 @@ encloseScriptX insert_data_sets vid vegaspec = preEscapedToHtml $ T.unlines ([
[ "; res.view.resize()"
, "; res.view.runAsync()"
, "})" ])
- where
- vidt = T.pack vid
jsScript :: String -> Html
jsScript url = script ! src (fromString $ url) $ ""
@@ -133,29 +131,25 @@ htmlHeader mb_hpd mb_ticky as =
has_ticky = isJust mb_ticky
template :: Header -> Maybe HeapProfileData -> Maybe TickyProfileData -> Args -> [TabGroup] -> Html
-template header' x y as tabs = docTypeHtml $ do
+template header' x y as tab_groups = docTypeHtml $ do
H.stringComment $ "Generated with eventlog2html-" <> showVersion version
htmlHeader x y as
body $ H.div ! class_ "container-fluid" $ do
- H.div ! class_ "row" $ navbar indexed_tabs
+ H.div ! class_ "row" $ navbar tab_groups
H.div ! class_ "row" $ do
H.div ! class_ "col tab-content custom-tab" $ do
- forM_ indexed_tabs $ \(_, group) -> do
+ forM_ tab_groups $ \group -> do
case group of
SingleTab tab -> renderTab header' tab
ManyTabs _ tabs -> mapM_ (renderTab header') tabs
script $ preEscapedToHtml tablogic
- where
- indexed_tabs :: [(Int, TabGroup)]
- indexed_tabs = zip [1..] tabs
-
renderTab :: Header -> Tab -> Html
renderTab header' tab =
- H.div ! A.id (toValue (tabId tab)) ! class_ ("tab-pane fade tabviz " <> status) $ H.div ! class_ "row" $ do
+ H.div ! A.id (toValue (tabIDToTabID (tabId tab))) ! class_ ("tab-pane fade tabviz " <> status) $ H.div ! class_ "row" $ do
forM_ (tabContent tab) $ \stuff -> H.div ! class_ "col" $ do
- stuff (tabId tab)
+ stuff
perTabFooter header'
forM_ (tabDocs tab) $ \docs -> H.div ! class_ "col" $ docs
where
@@ -195,16 +189,16 @@ htmlConf as ct =
, fixedYAxisExtent = fromIntegral <$> fixedYAxis as
}
-renderChart :: IncludeTraceData -> ChartType -> Bool -> VizID -> Text -> Html
+renderChart :: IncludeTraceData -> ChartType -> Bool -> TabID -> Text -> Html
renderChart itd ct vega_lite vid vegaSpec = do
let fields = select_data itd ct
- H.div ! A.id (fromString $ "vis" ++ vid) ! class_ "chart" $ ""
+ H.div ! A.id (toValue (tabIDToVizID vid)) ! class_ "chart" $ ""
script ! type_ "text/javascript" $ do
if vega_lite
then encloseScript fields vid vegaSpec
else encloseRawVegaScript vid vegaSpec
-renderChartWithJson :: IncludeTraceData -> ChartType -> VizID -> Value -> Text -> Html
+renderChartWithJson :: IncludeTraceData -> ChartType -> TabID -> Value -> Text -> Html
renderChartWithJson itd ct k dat vegaSpec = do
script $ insertJsonData dat
renderChart itd ct True k vegaSpec
@@ -234,7 +228,7 @@ allTabs h x y as =
metaTab :: Header -> Args -> Tab
metaTab header' _as =
- Tab "Meta" "meta" (Just (const metadata)) Nothing True False
+ (mkTab "Meta" "meta" metadata Nothing) { tabActive = True }
where
metadata = do
"Rendered by "
@@ -258,7 +252,9 @@ allHeapTabs header' as x =
]
heapTab :: Args -> TabGroup
-heapTab as = SingleTab $ Tab "Heap" "heapchart" (Just (mk as HeapChart)) (Just heapDocs) False False
+heapTab as = SingleTab $ mkTab "Heap" tabid (mk as HeapChart tabid) (Just heapDocs)
+ where
+ tabid = "heapchart"
heapDocs :: Html
heapDocs = H.div $ preEscapedToHtml $ T.decodeUtf8 $(embedFile "inline-docs/heap.html")
@@ -267,52 +263,48 @@ heapDocs = H.div $ preEscapedToHtml $ T.decodeUtf8 $(embedFile "inline-docs/heap
heapProfileTabs :: Header -> Args -> HeapProfileData -> TabGroup
heapProfileTabs header' as _
| has_heap_profile header' = ManyTabs "Heap Profile" $
- [ Tab "Area Chart" "areachart" (Just (mk as (AreaChart Stacked))) noDocs False False
- , Tab "Normalized" "normalizedchart" (Just (mk as (AreaChart Normalized))) noDocs False False
- , Tab "Streamgraph" "streamgraph" (Just (mk as (AreaChart StreamGraph))) noDocs False False
- , Tab "Linechart" "linechart" (Just (mk as LineChart)) noDocs False False
+ [ mkTab "Area Chart" "areachart" (mk as (AreaChart Stacked) "areachart") noDocs
+ , mkTab "Normalized" "normalizedchart" (mk as (AreaChart Normalized) "normalizedchart") noDocs
+ , mkTab "Streamgraph" "streamgraph" (mk as (AreaChart StreamGraph) "streamgraph") noDocs
+ , mkTab "Linechart" "linechart" (mk as LineChart "linechart") noDocs
]
| otherwise = SingleTab noHeapProfileTab
noHeapProfileTab :: Tab
-noHeapProfileTab = Tab "Heap Profile" "heap_profile" Nothing (Just noHeapProfileDocs) False True
+noHeapProfileTab = mkUnavailableTab "Heap Profile" "heap_profile" noHeapProfileDocs
noHeapProfileDocs :: Html
noHeapProfileDocs = H.div $ preEscapedToHtml $ T.decodeUtf8 $(embedFile "inline-docs/no-heap-profile.html")
-mk :: Args -> ChartType -> VizID -> Html
+mk :: Args -> ChartType -> TabID -> Html
mk as conf vid = renderChart itd conf True vid
(TL.toStrict (encodeToLazyText (vegaJson (htmlConf as conf))))
where
itd = if noTraces as then NoTraceData else TraceData
detailedTab :: HeapProfileData -> TabGroup
-detailedTab (HeapProfileData _dat _cc_descs closure_descs) = case closure_descs of
- Just v -> SingleTab $ Tab "Detailed" "closures" (Just (const v)) noDocs False False
- Nothing -> SingleTab $ Tab "Detailed" "closures" Nothing (Just noDetailedDocs) False True
+detailedTab (HeapProfileData _dat _cc_descs closure_descs) =
+ SingleTab $ mkOptionalTab "Detailed" "closures" Prelude.id noDocs noDetailedDocs closure_descs
noDetailedDocs :: Html
noDetailedDocs = H.div $ preEscapedToHtml $ T.decodeUtf8 $(embedFile "inline-docs/no-detailed.html")
costCentresTab :: Args -> HeapProfileData -> TabGroup
-costCentresTab as (HeapProfileData _dat cc_descs _) = case cc_descs of
- Just _ -> SingleTab $ Tab "Cost Centres" "costcentres" (Just (\tabIx -> renderChart itd LineChart False tabIx treevega)) noDocs False False
- Nothing -> SingleTab noCostCentresTab
+costCentresTab as (HeapProfileData _dat cc_descs _) =
+ SingleTab $ mkOptionalTab "Cost Centres" "costcentres" (const stuff) noDocs noCostCentresDocs cc_descs
where
+ tabIx = "costcentres"
itd = if noTraces as then NoTraceData else TraceData
-
-noCostCentresTab :: Tab
-noCostCentresTab = Tab "Cost Centres" "costcentres" Nothing (Just noCostCentresDocs) False True
+ stuff = renderChart itd LineChart False tabIx treevega
noCostCentresDocs :: Html
noCostCentresDocs = H.div $ preEscapedToHtml $ T.decodeUtf8 $(embedFile "inline-docs/no-cost-centres.html")
tickyProfileTabs :: Maybe TickyProfileData -> TabGroup
-tickyProfileTabs (Just y) = SingleTab $ Tab "Ticky" "ticky" (Just (const (tickyTab y))) Nothing False False
-tickyProfileTabs Nothing = SingleTab $ Tab "Ticky" "ticky" Nothing (Just noTickyDocs) False True
+tickyProfileTabs = SingleTab . mkOptionalTab "Ticky" "ticky" tickyTab noDocs noTickyDocs
noTickyDocs :: Html
noTickyDocs = H.div $ preEscapedToHtml $ T.decodeUtf8 $(embedFile "inline-docs/no-ticky.html")
diff --git a/src/Eventlog/Rendering/Bootstrap.hs b/src/Eventlog/Rendering/Bootstrap.hs
index 5b516b1..d6a3434 100644
--- a/src/Eventlog/Rendering/Bootstrap.hs
+++ b/src/Eventlog/Rendering/Bootstrap.hs
@@ -30,18 +30,18 @@ ariaLabel :: AttributeValue -> Attribute
ariaLabel = attribute "aria-label" " aria-label=\""
{-# INLINE ariaLabel #-}
-navbar :: [(Int, TabGroup)] -> Html
-navbar tabs = do
+navbar :: [TabGroup] -> Html
+navbar tab_groups = do
H.ul ! A.id "vizTabs" ! class_ "nav nav-tabs" $ do
- forM_ tabs $ \(_, group) -> do
+ forM_ tab_groups $ \group -> do
case group of
SingleTab tab ->
H.li ! class_ "nav-item" $
- H.a ! A.id (fromString $ tabId tab <> "-tab")
+ H.a ! A.id (toValue (tabIDToNavItemID (tabId tab)))
! class_ (tabClasses tab)
- ! href ("#" <> fromString (tabId tab))
+ ! href (toValue (tabIDToHref (tabId tab)))
! dataToggle "tab"
- ! dataTarget (toValue $ "#" <> tabId tab)
+ ! dataTarget (toValue (tabIDToHref (tabId tab)))
$ fromString (tabName tab)
ManyTabs group_name tabs ->
H.li ! class_ "nav-item dropdown" $ do
@@ -51,11 +51,11 @@ navbar tabs = do
$ fromString group_name
H.div ! class_ "dropdown-menu" $
forM_ tabs $ \tab ->
- H.a ! A.id (fromString $ tabId tab <> "-tab")
+ H.a ! A.id (toValue (tabIDToNavItemID (tabId tab)))
! class_ "dropdown-item"
- ! href ("#" <> fromString (tabId tab))
+ ! href (toValue (tabIDToHref (tabId tab)))
! dataToggle "tab"
- ! dataTarget (toValue $ "#" <> tabId tab)
+ ! dataTarget (toValue (tabIDToHref (tabId tab)))
$ fromString (tabName tab)
tabClasses :: Tab -> AttributeValue
diff --git a/src/Eventlog/Rendering/Types.hs b/src/Eventlog/Rendering/Types.hs
index fe37c3c..8f5e2d7 100644
--- a/src/Eventlog/Rendering/Types.hs
+++ b/src/Eventlog/Rendering/Types.hs
@@ -1,26 +1,62 @@
+{-# LANGUAGE OverloadedStrings #-}
module Eventlog.Rendering.Types where
+import Data.Char
+import Data.String
+import qualified Data.Text as T
import Text.Blaze.Html5
data IncludeTraceData
= TraceData
| NoTraceData
-type VizID = String
+-- | Tab IDs must be usable as HTML and Javascript identifiers, so we allow a
+-- limited selection of characters. This is enforced only at runtime by the
+-- 'IsString' instance, but that seems good enough for now.
+newtype TabID = TabID T.Text
+
+instance IsString TabID where
+ fromString s
+ | all valid s = TabID (T.pack s)
+ | otherwise = error $ "mkTabID: invalid tab ID: " ++ s
+ where
+ valid c = isAscii c && (isAlpha c || isDigit c || c == '_')
+
+tabIDToVizID :: TabID -> T.Text
+tabIDToVizID (TabID t) = "vis" <> t
+
+tabIDToNavItemID :: TabID -> T.Text
+tabIDToNavItemID (TabID t) = t <> "-tab"
+
+tabIDToTabID :: TabID -> T.Text
+tabIDToTabID (TabID t) = t
+
+tabIDToHref :: TabID -> T.Text
+tabIDToHref (TabID t) = "#" <> t
-type Tabs = [TabGroup]
data TabGroup = ManyTabs String [Tab]
| SingleTab Tab
data Tab = Tab { tabName :: String
- , tabId :: VizID
- , tabContent :: Maybe (VizID -> Html)
+ , tabId :: TabID
+ , tabContent :: Maybe Html
, tabDocs :: Maybe Html
, tabActive :: Bool -- ^ Active by default?
, tabDisabled :: Bool
}
+mkTab :: String -> TabID -> Html -> Maybe Html -> Tab
+mkTab name id_ content docs = Tab name id_ (Just content) docs False False
+
+mkUnavailableTab :: String -> TabID -> Html -> Tab
+mkUnavailableTab name id_ docs = Tab name id_ Nothing (Just docs) False True
+
+mkOptionalTab :: String -> TabID -> (a -> Html) -> Maybe Html -> Html -> Maybe a -> Tab
+mkOptionalTab name id_ mk_content docs no_docs mb = case mb of
+ Nothing -> mkUnavailableTab name id_ no_docs
+ Just v -> mkTab name id_ (mk_content v) docs
+
noDocs :: Maybe Html
noDocs = Nothing