{-# LANGUAGE QuasiQuotes #-}

module Futhark.Profile.Html (securedHashPath, generateHeatmapHtml, generateCCOverviewHtml, generateHtmlIndex, generateSourceIndex) where

import Control.Monad (join)
import Control.Monad.State.Strict (State, evalState, get, modify)
import Data.Bifunctor (bimap, first, second)
import Data.Function ((&))
import Data.List (sortOn)
import Data.Loc (posFile)
import Data.Map qualified as M
import Data.Ord (Down (Down))
import Data.Set (Set)
import Data.String (IsString (fromString))
import Data.Text qualified as T
import Data.Word (Word8)
import Futhark.Profile.Details (CostCentreDetails (CostCentreDetails, summary), CostCentreName (CostCentreName, getCostCentreName), SourceRangeDetails (SourceRangeDetails, containingCostCentres), SourceRanges, sourceRangeDetailsFraction)
import Futhark.Profile.Details qualified as D
import Futhark.Profile.EventSummary qualified as ES
import Futhark.Profile.SourceRange qualified as SR
import Futhark.Util (hashText, showText)
import Futhark.Util.Html (headHtml, headHtmlWithCss, relativise)
import NeatInterpolation qualified as NI (text, trimming)
import System.FilePath (takeFileName, (<.>), (</>))
import Text.Blaze.Html5 ((!))
import Text.Blaze.Html5 qualified as H
import Text.Blaze.Html5.Attributes qualified as A
import Text.Printf (printf)
import Prelude hiding (span)

securedHashPath :: FilePath -> FilePath
securedHashPath :: String -> String
securedHashPath String
p =
  Text -> String
T.unpack (Text -> Text
hashText (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
p) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
takeFileName String
p

type SourcePos = (Int, Int)

data RenderState = RenderState
  { RenderState -> SourcePos
_renderPos :: !SourcePos,
    RenderState -> Text
remainingText :: !T.Text
  }

-- | A dataset report with browser-readable logs and timeline.  The source
-- index may instead explain why source analysis was unavailable.
generateHtmlIndex ::
  -- | Path of the bench dir
  FilePath ->
  Maybe T.Text ->
  Maybe T.Text ->
  H.Html ->
  H.Html
generateHtmlIndex :: String -> Maybe Text -> Maybe Text -> Html -> Html
generateHtmlIndex String
benchDir Maybe Text
logText Maybe Text
timelineText Html
sourceIndex =
  Html -> Html
H.docTypeHtml (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    String -> String -> Html
headHtmlWithCss (String
benchDir String -> String -> String
</> String
"style.css") String
"Profiling Report"
    Html -> Html
H.body (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.main (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.h1 Html
"Profiling Report"
      Html -> Html
H.nav (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.ul (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
H.li (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
"#log" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Log"
        Html -> Html
H.li (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
"#timeline" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Timeline"
        Html -> Html
H.li (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href AttributeValue
"#sources" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
"Source information"
      Html -> Html
H.section (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"log" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
H.h2 Html
"Log"
        Html -> Html
H.p Html
"The running log produced during execution."
        Html -> (Text -> Html) -> Maybe Text -> Html
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (Html -> Html
H.p Html
"No log recorded.")
          ((Html -> Html
H.pre (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"log-text") (Html -> Html) -> (Text -> Html) -> Text -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Html
H.code (Html -> Html) -> (Text -> Html) -> Text -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html
H.text)
          Maybe Text
logText
      Html -> Html
H.section (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"timeline" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
H.h2 Html
"Timeline"
        Html -> Html
H.p Html
"Recorded events in order, with durations in microseconds."
        Html -> (Text -> Html) -> Maybe Text -> Html
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (Html -> Html
H.p Html
"No profiling information recorded.")
          ((Html -> Html
H.pre (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"timeline-text") (Html -> Html) -> (Text -> Html) -> Text -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Html
H.code (Html -> Html) -> (Text -> Html) -> Text -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html
H.text)
          Maybe Text
timelineText
      Html -> Html
H.section (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.id AttributeValue
"sources" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
H.h2 Html
"Source information"
        Html
sourceIndex

-- | Navigation to the successfully generated source and cost centre pages.
generateSourceIndex :: FilePath -> M.Map FilePath SourceRanges -> H.Html
generateSourceIndex :: String -> Map String SourceRanges -> Html
generateSourceIndex String
benchDir Map String SourceRanges
pathToSourceRanges = do
  Text -> Html
introductionIndex (String -> Text
T.pack String
benchDir)
  String -> Set String -> Html
sourceFileIndex String
benchDir (Map String SourceRanges -> Set String
forall k a. Map k a -> Set k
M.keysSet Map String SourceRanges
pathToSourceRanges)

introductionIndex :: T.Text -> H.Html
introductionIndex :: Text -> Html
introductionIndex Text
benchDir = do
  Text -> Html
H.text
    [NI.trimming|
          This is the index file for the benchmark files in $benchDir.
          The generated profile markup consists of highlighted source files
          and the cost centre overview.
          |]
  Html -> Html
H.h4 Html
"Highlighted Source Files"
  Text -> Html
H.text
    [NI.trimming|
          All the source files that were contained in any cost centre for this
          benchmark were higlighted and rendered.
          This means that source ranges are shown with a background
          color progressing from green to yellow to red, depending on the
          amount of total time spent in cost centres containing this range.
          Not every source location gets a color, that is because some parts
          are simply optimized out or were not needed for the compilation of
          this benchmark.
          At the bottom of each Source File there is a listing of all ranges
          in the source file and which cost centres affected the coloring.
          |]
  Html -> Html
H.h4 (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
    Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (String -> AttributeValue
forall a. IsString a => String -> a
fromString (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
benchDir String -> String -> String
</> String
"cost-centres.html") (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
      Text -> Html
H.text Text
"Cost Centre Overview"
  Text -> Html
H.text
    [NI.trimming|
          The Cost Centre Overview contains all the cost centres recorded
          during the last run of the benchmark. For every cost centre, there
          is a table with statistics and also a list with links to all
          relevant source ranges.
          |]

sourceFileIndex :: FilePath -> Set FilePath -> H.Html
sourceFileIndex :: String -> Set String -> Html
sourceFileIndex String
benchDir Set String
paths = do
  Html -> Html
H.h3 (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.text Text
"Source Files (ordered alphabetically)"
  Html -> Html
H.ul (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    (String -> Html) -> Set String -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Html
pathListEntry Set String
paths
  where
    pathListEntry :: String -> Html
pathListEntry String
path =
      Html -> Html
H.li
        (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a
          (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (String -> AttributeValue
forall a. IsString a => String -> a
fromString String
pathRef)
        (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ String -> Html
H.string String
path
      where
        pathRef :: String
pathRef = String
benchDir String -> String -> String
</> String -> String
securedHashPath String
path String -> String -> String
<.> String
".html"

generateHeatmapHtml ::
  -- | Path where this Html will be placed
  FilePath ->
  -- | Path where the corresponding source was
  FilePath ->
  -- | Source File Text
  T.Text ->
  -- | Non-Overlapping Source Ranges
  M.Map SR.SourceRange SourceRangeDetails ->
  H.Html
generateHeatmapHtml :: String -> String -> Text -> SourceRanges -> Html
generateHeatmapHtml String
htmlPath String
sourcePath Text
sourceText SourceRanges
sourceRanges =
  Html -> Html
H.docTypeHtml (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    String -> String -> Html
headHtml String
htmlPath (String
sourcePath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" - Source-Heatmap")
    String -> Text -> SourceRanges -> Html
heatmapBodyHtml String
htmlPath Text
sourceText SourceRanges
sourceRanges

generateCCOverviewHtml :: M.Map CostCentreName CostCentreDetails -> H.Html
generateCCOverviewHtml :: Map CostCentreName CostCentreDetails -> Html
generateCCOverviewHtml Map CostCentreName CostCentreDetails
costCentres = do
  String -> String -> Html
headHtml String
"cost-centres.html" String
"Cost Centre Overview"
  Html -> Html
H.body (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html -> Html
H.h2 (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.text Text
"Cost Centre Table (ordered by fraction)"
    Html
ccTable

    Html -> Html
H.h2 (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.text Text
"Cost Centre Details (ordered by fraction)"
    Html
ccDetailTables
  where
    orderAscending :: [(a, CostCentreDetails)] -> [(a, CostCentreDetails)]
orderAscending = ((a, CostCentreDetails) -> Down Double)
-> [(a, CostCentreDetails)] -> [(a, CostCentreDetails)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Double -> Down Double
forall a. a -> Down a
Down (Double -> Down Double)
-> ((a, CostCentreDetails) -> Double)
-> (a, CostCentreDetails)
-> Down Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CostCentreDetails -> Double
D.fraction (CostCentreDetails -> Double)
-> ((a, CostCentreDetails) -> CostCentreDetails)
-> (a, CostCentreDetails)
-> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, CostCentreDetails) -> CostCentreDetails
forall a b. (a, b) -> b
snd)
    ccTable :: Html
ccTable = Html -> Html
H.table (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"cctable" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
      Html -> Html
H.tr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
        (Html -> Html) -> [Html] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
          Html -> Html
H.th
          [ Html
"Name",
            Html
"Fraction",
            Html
"Event Count",
            Html
"Total Time (µs)",
            Html
"Minimum Time (µs)",
            Html
"Maximum Time (µs)"
          ]
      ((CostCentreName, CostCentreDetails) -> Html)
-> [(CostCentreName, CostCentreDetails)] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((CostCentreName -> CostCentreDetails -> Html)
-> (CostCentreName, CostCentreDetails) -> Html
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CostCentreName -> CostCentreDetails -> Html
row) ([(CostCentreName, CostCentreDetails)] -> Html)
-> ([(CostCentreName, CostCentreDetails)]
    -> [(CostCentreName, CostCentreDetails)])
-> [(CostCentreName, CostCentreDetails)]
-> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CostCentreName, CostCentreDetails)]
-> [(CostCentreName, CostCentreDetails)]
forall {a}. [(a, CostCentreDetails)] -> [(a, CostCentreDetails)]
orderAscending ([(CostCentreName, CostCentreDetails)] -> Html)
-> [(CostCentreName, CostCentreDetails)] -> Html
forall a b. (a -> b) -> a -> b
$ Map CostCentreName CostCentreDetails
-> [(CostCentreName, CostCentreDetails)]
forall k a. Map k a -> [(k, a)]
M.toList Map CostCentreName CostCentreDetails
costCentres
      where
        row :: CostCentreName -> CostCentreDetails -> Html
row (CostCentreName Text
name) (CostCentreDetails Double
fraction SourceRanges
_ EvSummary
summary) =
          Html -> Html
H.tr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
            Html -> Html
H.td
              (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Double -> Html -> Html
fractionColored Double
fraction
              (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a
                (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (String -> AttributeValue
forall a. IsString a => String -> a
fromString (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Char
'#' Char -> String -> String
forall a. a -> [a] -> [a]
: Text -> String
T.unpack Text
name)
                (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"silent-anchor"
                (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.title AttributeValue
"Click to jump to details"
              (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.text Text
name
            (String -> Html) -> [String] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
              (Html -> Html
H.td (Html -> Html) -> (String -> Html) -> String -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Html
H.string)
              [ String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.4f" Double
fraction,
                Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> Integer -> String
forall a b. (a -> b) -> a -> b
$ EvSummary -> Integer
ES.evCount EvSummary
summary,
                String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.2f" (Double -> String) -> Double -> String
forall a b. (a -> b) -> a -> b
$ EvSummary -> Double
ES.evSum EvSummary
summary,
                String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.2f" (Double -> String) -> Double -> String
forall a b. (a -> b) -> a -> b
$ EvSummary -> Double
ES.evMin EvSummary
summary,
                String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.2f" (Double -> String) -> Double -> String
forall a b. (a -> b) -> a -> b
$ EvSummary -> Double
ES.evMax EvSummary
summary
              ]

    ccDetailTables :: Html
ccDetailTables =
      Map CostCentreName CostCentreDetails
-> [(CostCentreName, CostCentreDetails)]
forall k a. Map k a -> [(k, a)]
M.toList Map CostCentreName CostCentreDetails
costCentres
        [(CostCentreName, CostCentreDetails)]
-> ([(CostCentreName, CostCentreDetails)]
    -> [(CostCentreName, CostCentreDetails)])
-> [(CostCentreName, CostCentreDetails)]
forall a b. a -> (a -> b) -> b
& [(CostCentreName, CostCentreDetails)]
-> [(CostCentreName, CostCentreDetails)]
forall {a}. [(a, CostCentreDetails)] -> [(a, CostCentreDetails)]
orderAscending
        [(CostCentreName, CostCentreDetails)]
-> ([(CostCentreName, CostCentreDetails)] -> Html) -> Html
forall a b. a -> (a -> b) -> b
& ((CostCentreName, CostCentreDetails) -> Html)
-> [(CostCentreName, CostCentreDetails)] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((CostCentreName -> CostCentreDetails -> Html)
-> (CostCentreName, CostCentreDetails) -> Html
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CostCentreName -> CostCentreDetails -> Html
renderCostCentreDetails)

renderCostCentreDetails :: CostCentreName -> CostCentreDetails -> H.Html
renderCostCentreDetails :: CostCentreName -> CostCentreDetails -> Html
renderCostCentreDetails (CostCentreName Text
ccName) (CostCentreDetails Double
ratio SourceRanges
sourceRanges EvSummary
summary) = do
  Html
title
  Html
summaryTable
  Html
sourceRangeListing
  where
    title :: Html
title =
      Html -> Html
H.h3
        (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
$ Text -> String
T.unpack Text
ccName)
        (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Double -> Html -> Html
fractionColored Double
ratio
        (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a
          (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (String -> AttributeValue
forall a. IsString a => String -> a
fromString (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Char
'#' Char -> String -> String
forall a. a -> [a] -> [a]
: Text -> String
T.unpack Text
ccName)
          (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"silent-anchor"
        (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.text Text
ccName

    summaryTable :: Html
summaryTable =
      Html -> Html
H.table (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"cctable" (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
        ((Text, Text) -> Html) -> [(Text, Text)] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
          (Text, Text) -> Html
row
          [ (Text
"Fraction", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.4f" Double
ratio),
            (Text
"Event Count", Integer -> Text
forall a. Show a => a -> Text
showText Integer
count),
            (Text
"Total Time (µs)", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.2f" Double
sum_),
            (Text
"Minimum Time (µs)", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.2f" Double
min_),
            (Text
"Maximum Time (µs)", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.2f" Double
max_)
          ]
      where
        (ES.EvSummary Integer
count Double
sum_ Double
min_ Double
max_) = EvSummary
summary
        row :: (Text, Text) -> Html
row (Text
h, Text
d) = Html -> Html
H.tr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          Html -> Html
H.th (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.text Text
h
          Html -> Html
H.td (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.text Text
d

    sourceRangeListing :: Html
sourceRangeListing = do
      Html -> Html
H.h4 (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.text Text
"Source Ranges"
      Html -> Html
H.ol (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
        ((SourceRange, SourceRangeDetails) -> Html)
-> [(SourceRange, SourceRangeDetails)] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((SourceRange -> SourceRangeDetails -> Html)
-> (SourceRange, SourceRangeDetails) -> Html
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SourceRange -> SourceRangeDetails -> Html
entry) (SourceRanges -> [(SourceRange, SourceRangeDetails)]
forall k a. Map k a -> [(k, a)]
M.toList SourceRanges
sourceRanges)
      where
        entry :: SourceRange -> SourceRangeDetails -> Html
entry SourceRange
range SourceRangeDetails
details =
          Html -> Html
H.li
            (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Double -> Html -> Html
fractionColored (SourceRangeDetails -> Double
sourceRangeDetailsFraction SourceRangeDetails
details)
            (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a
              (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (String -> AttributeValue
forall a. IsString a => String -> a
fromString String
entryRef)
              (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"silent-anchor"
              (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.title AttributeValue
"Click to Jump to Source"
            (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.text
            (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ SourceRange -> Text
sourceRangeText SourceRange
range Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
rangeFile
          where
            rangeFile :: String
rangeFile = Pos -> String
posFile (Pos -> String) -> Pos -> String
forall a b. (a -> b) -> a -> b
$ SourceRange -> Pos
SR.startPos SourceRange
range
            rangeHtmlFile :: String
rangeHtmlFile = String -> String
securedHashPath String
rangeFile
            entryRef :: String
entryRef = String
rangeHtmlFile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".html#" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SourceRange -> String
sourceRangeSpanCssId SourceRange
range

heatmapBodyHtml :: FilePath -> T.Text -> M.Map SR.SourceRange SourceRangeDetails -> H.Html
heatmapBodyHtml :: String -> Text -> SourceRanges -> Html
heatmapBodyHtml String
sourcePath Text
sourceText SourceRanges
sourceRanges =
  Html -> Html
H.body (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Html
sourceCodeListing
    Html
detailTables
  where
    rangeList :: [(SourceRange, SourceRangeDetails)]
rangeList = SourceRanges -> [(SourceRange, SourceRangeDetails)]
forall k a. Map k a -> [(k, a)]
M.toAscList SourceRanges
sourceRanges

    sourceCodeListing :: Html
sourceCodeListing =
      Html -> Html
H.code (Html -> Html) -> (Html -> Html) -> Html -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Html
H.pre (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$
        RenderState -> [(SourceRange, SourceRangeDetails)] -> Html
renderRanges (SourcePos -> Text -> RenderState
RenderState (Int
1, Int
1) Text
sourceText) [(SourceRange, SourceRangeDetails)]
rangeList

    detailTables :: Html
detailTables = ((SourceRange, SourceRangeDetails) -> Html)
-> [(SourceRange, SourceRangeDetails)] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((SourceRange -> SourceRangeDetails -> Html)
-> (SourceRange, SourceRangeDetails) -> Html
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((SourceRange -> SourceRangeDetails -> Html)
 -> (SourceRange, SourceRangeDetails) -> Html)
-> (SourceRange -> SourceRangeDetails -> Html)
-> (SourceRange, SourceRangeDetails)
-> Html
forall a b. (a -> b) -> a -> b
$ String -> SourceRange -> SourceRangeDetails -> Html
sourceRangeDetails String
sourcePath) [(SourceRange, SourceRangeDetails)]
rangeList

sourceRangeDetails :: FilePath -> SR.SourceRange -> SourceRangeDetails -> H.Html
sourceRangeDetails :: String -> SourceRange -> SourceRangeDetails -> Html
sourceRangeDetails String
currentPath SourceRange
range details :: SourceRangeDetails
details@(SourceRangeDetails Map CostCentreName CostCentreDetails
ccs) = Html -> Html
detailDiv (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
  Html -> Html
H.h3 (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
    Text -> Html
H.text Text
"Source Range from "
    Html -> Html
toSpanAnchor (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Double -> Html -> Html
fractionColored Double
ratio (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.span (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.text Text
rangeText

  Html
costCentreTable
  where
    ratio :: Double
ratio = SourceRangeDetails -> Double
sourceRangeDetailsFraction SourceRangeDetails
details
    costCentreTable :: Html
costCentreTable = do
      Html -> Html
H.h4 (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.text Text
"Cost Centres"
      Html -> Html
H.table (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
        Html -> Html
H.tr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          (Html -> Html) -> [Html] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
            Html -> Html
H.th
            [ Html
"Name",
              Html
"Event Count",
              Html
"Total Time (µs)",
              Html
"Minimum Time (µs)",
              Html
"Maximum Time (µs)",
              Html
"Fraction"
            ]

        ((Text, CostCentreDetails) -> Html)
-> [(Text, CostCentreDetails)] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text, CostCentreDetails) -> Html
evRow ([(Text, CostCentreDetails)] -> Html)
-> [(Text, CostCentreDetails)] -> Html
forall a b. (a -> b) -> a -> b
$
          Map CostCentreName CostCentreDetails
-> [(CostCentreName, CostCentreDetails)]
forall k a. Map k a -> [(k, a)]
M.toAscList Map CostCentreName CostCentreDetails
ccs
            [(CostCentreName, CostCentreDetails)]
-> ([(CostCentreName, CostCentreDetails)]
    -> [(Text, CostCentreDetails)])
-> [(Text, CostCentreDetails)]
forall a b. a -> (a -> b) -> b
& ((CostCentreName, CostCentreDetails) -> (Text, CostCentreDetails))
-> [(CostCentreName, CostCentreDetails)]
-> [(Text, CostCentreDetails)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CostCentreName -> Text)
-> (CostCentreName, CostCentreDetails) -> (Text, CostCentreDetails)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first CostCentreName -> Text
getCostCentreName)

        Html -> Html
H.tr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          Html -> Html
H.td (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.text Text
"Total"
          Html -> Html
H.td (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.text (Text -> Html) -> Text -> Html
forall a b. (a -> b) -> a -> b
$ Integer -> Text
forall a. Show a => a -> Text
showText (Integer -> Text) -> Integer -> Text
forall a b. (a -> b) -> a -> b
$ EvSummary -> Integer
ES.evCount EvSummary
evTotal
          (Double -> Html) -> [Double] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
            (Html -> Html
H.td (Html -> Html) -> (Double -> Html) -> Double -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Html
H.text (Text -> Html) -> (Double -> Text) -> Double -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Double -> String) -> Double -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.2f")
            [ EvSummary -> Double
ES.evSum EvSummary
evTotal,
              EvSummary -> Double
ES.evMin EvSummary
evTotal,
              EvSummary -> Double
ES.evMax EvSummary
evTotal,
              Double
ratio
            ]
      where
        evRow :: (Text, CostCentreDetails) -> Html
evRow (Text
ccName, CostCentreDetails Double
fraction SourceRanges
_ EvSummary
ev) = Html -> Html
H.tr (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ do
          (Html -> Html) -> [Html] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
            Html -> Html
H.td
            [ Double -> Html -> Html
fractionColored Double
fraction
                (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.span
                  (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.title AttributeValue
"Click to jump to Cost Centre Overview"
                (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.a
                  (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href
                    ( String -> AttributeValue
forall a. IsString a => String -> a
fromString (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$
                        String -> String -> String
relativise String
"cost-centres.html" String
currentPath
                          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"#"
                          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
ccName
                    )
                  (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"silent-anchor"
                (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
H.text Text
ccName,
              Text -> Html
H.text (Text -> Html) -> (EvSummary -> Text) -> EvSummary -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Text
forall a. Show a => a -> Text
showText (Integer -> Text) -> (EvSummary -> Integer) -> EvSummary -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvSummary -> Integer
ES.evCount (EvSummary -> Html) -> EvSummary -> Html
forall a b. (a -> b) -> a -> b
$ EvSummary
ev,
              Text -> Html
H.text (Text -> Html) -> (EvSummary -> Text) -> EvSummary -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (EvSummary -> String) -> EvSummary -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.2f" (Double -> String) -> (EvSummary -> Double) -> EvSummary -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvSummary -> Double
ES.evSum (EvSummary -> Html) -> EvSummary -> Html
forall a b. (a -> b) -> a -> b
$ EvSummary
ev,
              Text -> Html
H.text (Text -> Html) -> (EvSummary -> Text) -> EvSummary -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (EvSummary -> String) -> EvSummary -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.2f" (Double -> String) -> (EvSummary -> Double) -> EvSummary -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvSummary -> Double
ES.evMin (EvSummary -> Html) -> EvSummary -> Html
forall a b. (a -> b) -> a -> b
$ EvSummary
ev,
              Text -> Html
H.text (Text -> Html) -> (EvSummary -> Text) -> EvSummary -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (EvSummary -> String) -> EvSummary -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.2f" (Double -> String) -> (EvSummary -> Double) -> EvSummary -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvSummary -> Double
ES.evMax (EvSummary -> Html) -> EvSummary -> Html
forall a b. (a -> b) -> a -> b
$ EvSummary
ev,
              Text -> Html
H.text (Text -> Html) -> (Double -> Text) -> Double -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Double -> String) -> Double -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.4f" (Double -> Html) -> Double -> Html
forall a b. (a -> b) -> a -> b
$ Double
fraction
            ]
        evTotal :: EvSummary
evTotal =
          Map CostCentreName CostCentreDetails
-> [(CostCentreName, CostCentreDetails)]
forall k a. Map k a -> [(k, a)]
M.toList Map CostCentreName CostCentreDetails
ccs
            [(CostCentreName, CostCentreDetails)]
-> ([(CostCentreName, CostCentreDetails)] -> [EvSummary])
-> [EvSummary]
forall a b. a -> (a -> b) -> b
& ((CostCentreName, CostCentreDetails) -> EvSummary)
-> [(CostCentreName, CostCentreDetails)] -> [EvSummary]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CostCentreDetails -> EvSummary
summary (CostCentreDetails -> EvSummary)
-> ((CostCentreName, CostCentreDetails) -> CostCentreDetails)
-> (CostCentreName, CostCentreDetails)
-> EvSummary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CostCentreName, CostCentreDetails) -> CostCentreDetails
forall a b. (a, b) -> b
snd)
            [EvSummary] -> ([EvSummary] -> EvSummary) -> EvSummary
forall a b. a -> (a -> b) -> b
& (EvSummary -> EvSummary -> EvSummary)
-> EvSummary -> [EvSummary] -> EvSummary
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' EvSummary -> EvSummary -> EvSummary
combine (Integer -> Double -> Double -> Double -> EvSummary
ES.EvSummary Integer
0 Double
0 Double
infPos Double
infNeg)
          where
            combine :: EvSummary -> EvSummary -> EvSummary
combine (ES.EvSummary Integer
c Double
s Double
lo Double
hi) (ES.EvSummary Integer
c' Double
s' Double
lo' Double
hi') =
              Integer -> Double -> Double -> Double -> EvSummary
ES.EvSummary (Integer
c Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
c') (Double
s Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
s') (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
lo Double
lo') (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
hi Double
hi')
            infPos :: Double
infPos = String -> Double
forall a. Read a => String -> a
read String
"Infinity"
            infNeg :: Double
infNeg = Double -> Double
forall a. Num a => a -> a
negate Double
infPos

    toSpanAnchor :: Html -> Html
toSpanAnchor =
      Html -> Html
H.a
        (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (String -> AttributeValue
forall a. IsString a => String -> a
fromString (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Char
'#' Char -> String -> String
forall a. a -> [a] -> [a]
: SourceRange -> String
sourceRangeSpanCssId SourceRange
range)
        (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"silent-anchor"
        (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.title AttributeValue
"Click to jump to source"

    detailDiv :: Html -> Html
detailDiv =
      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
$ SourceRange -> String
sourceRangeDetailsCssId SourceRange
range)

    rangeText :: Text
rangeText = SourceRange -> Text
sourceRangeText SourceRange
range

sourceRangeText :: SR.SourceRange -> T.Text
sourceRangeText :: SourceRange -> Text
sourceRangeText SourceRange
range = [NI.text|$lineStart:$colStart to $lineEnd:$colEnd|]
  where
    (Text
lineStart, Text
colStart) = ((Int -> Text) -> (Int -> Text) -> SourcePos -> (Text, Text))
-> (Int -> Text) -> SourcePos -> (Text, Text)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Int -> Text) -> (Int -> Text) -> SourcePos -> (Text, Text)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Int -> Text
forall a. Show a => a -> Text
showText (SourcePos -> (Text, Text)) -> SourcePos -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ SourceRange -> SourcePos
SR.startLineCol SourceRange
range
    (Text
lineEnd, Text
colEnd) = ((Int -> Text) -> (Int -> Text) -> SourcePos -> (Text, Text))
-> (Int -> Text) -> SourcePos -> (Text, Text)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Int -> Text) -> (Int -> Text) -> SourcePos -> (Text, Text)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Int -> Text
forall a. Show a => a -> Text
showText (SourcePos -> (Text, Text)) -> SourcePos -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ SourceRange -> SourcePos
SR.endLineCol SourceRange
range

-- | Assumes that the annotated ranges are non-overlapping and in ascending order
renderRanges ::
  RenderState ->
  [(SR.SourceRange, SourceRangeDetails)] ->
  -- range, fraction, costCentreCount
  H.Html
renderRanges :: RenderState -> [(SourceRange, SourceRangeDetails)] -> Html
renderRanges RenderState
state [] = Text -> Html
H.text (Text -> Html) -> (RenderState -> Text) -> RenderState -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderState -> Text
remainingText (RenderState -> Html) -> RenderState -> Html
forall a b. (a -> b) -> a -> b
$ RenderState
state
renderRanges (RenderState SourcePos
pos Text
text) rs :: [(SourceRange, SourceRangeDetails)]
rs@((SourceRange
range, SourceRangeDetails
details) : [(SourceRange, SourceRangeDetails)]
rest) =
  let rangePos :: SourcePos
rangePos = SourceRange -> SourcePos
SR.startLineCol SourceRange
range
   in case SourcePos
pos SourcePos -> SourcePos -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` SourcePos
rangePos of
        Ordering
GT -> String -> Html
forall a. HasCallStack => String -> a
error String
"Impossible: Ranges were not in ascending order"
        Ordering
EQ -> do
          let rangeEndPos :: SourcePos
rangeEndPos = SourceRange -> SourcePos
SR.endLineCol SourceRange
range
          let (Html
textHtml, Text
text') = SourcePos -> SourcePos -> Text -> (Html, Text)
renderTextFromUntil SourcePos
pos SourcePos
rangeEndPos Text
text
          let fraction :: Double
fraction = SourceRangeDetails -> Double
sourceRangeDetailsFraction SourceRangeDetails
details
          let evCount :: Int
evCount = Map CostCentreName CostCentreDetails -> Int
forall k a. Map k a -> Int
M.size (Map CostCentreName CostCentreDetails -> Int)
-> Map CostCentreName CostCentreDetails -> Int
forall a b. (a -> b) -> a -> b
$ SourceRangeDetails -> Map CostCentreName CostCentreDetails
containingCostCentres SourceRangeDetails
details

          SourceRange -> Double -> Int -> Html -> Html
decorateSpan SourceRange
range Double
fraction Int
evCount Html
textHtml
          RenderState -> [(SourceRange, SourceRangeDetails)] -> Html
renderRanges (SourcePos -> Text -> RenderState
RenderState SourcePos
rangeEndPos Text
text') [(SourceRange, SourceRangeDetails)]
rest
        Ordering
LT -> do
          let (Html
textHtml, Text
text') = SourcePos -> SourcePos -> Text -> (Html, Text)
renderTextFromUntil SourcePos
pos SourcePos
rangePos Text
text
          Html
textHtml
          RenderState -> [(SourceRange, SourceRangeDetails)] -> Html
renderRanges (SourcePos -> Text -> RenderState
RenderState SourcePos
rangePos Text
text') [(SourceRange, SourceRangeDetails)]
rs

sourceRangeSpanCssId :: SR.SourceRange -> String
sourceRangeSpanCssId :: SourceRange -> String
sourceRangeSpanCssId SourceRange
range = String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"range-l%i-c%i" Int
startLine Int
startCol
  where
    (Int
startLine, Int
startCol) = SourceRange -> SourcePos
SR.startLineCol SourceRange
range

sourceRangeDetailsCssId :: SR.SourceRange -> String
sourceRangeDetailsCssId :: SourceRange -> String
sourceRangeDetailsCssId SourceRange
range = String
"detail-table-" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SourceRange -> String
sourceRangeSpanCssId SourceRange
range

decorateSpan :: SR.SourceRange -> Double -> Int -> H.Html -> H.Html
decorateSpan :: SourceRange -> Double -> Int -> Html -> Html
decorateSpan SourceRange
range Double
fraction Int
evCount = Html -> Html
span (Html -> Html) -> (Html -> Html) -> Html -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Html
anchor
  where
    anchor :: Html -> Html
anchor =
      Html -> Html
H.a
        (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ AttributeValue
"silent-anchor"
        (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (String -> AttributeValue
forall a. IsString a => String -> a
fromString (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Char
'#' Char -> String -> String
forall a. a -> [a] -> [a]
: SourceRange -> String
sourceRangeDetailsCssId SourceRange
range)

    spanCssId :: String
spanCssId = SourceRange -> String
sourceRangeSpanCssId SourceRange
range

    span :: Html -> Html
span =
      Double -> Html -> Html
fractionColored Double
fraction
        (Html -> Html) -> (Html -> Html) -> Html -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( Html -> Html
H.span
              (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
spanCssId)
              (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.title (String -> AttributeValue
forall a. IsString a => String -> a
fromString (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
cssHoverText)
          )
      where
        cssHoverText :: Text
cssHoverText =
          [NI.trimming|Fraction of the total runtime: $textFraction
          Part of $textEvCount cost centres.
          (Click to jump to detail table)
          |]
          where
            textEvCount :: Text
textEvCount = Int -> Text
forall a. Show a => a -> Text
showText Int
evCount
            textFraction :: Text
textFraction = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.4f" Double
fraction

fractionColored :: Double -> H.Html -> H.Html
fractionColored :: Double -> Html -> Html
fractionColored Double
fraction = (Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.style AttributeValue
cssColorValue)
  where
    cssColorValue :: AttributeValue
cssColorValue =
      String -> AttributeValue
forall a. IsString a => String -> a
fromString (String -> AttributeValue)
-> (Text -> String) -> Text -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$
        [NI.text|background: rgba($textR, $textG, $textB, 1)|]
      where
        (Text
textR, Text
textG, Text
textB) = (Word8 -> Text
forall a. Show a => a -> Text
showText Word8
r, Word8 -> Text
forall a. Show a => a -> Text
showText Word8
g, Word8 -> Text
forall a. Show a => a -> Text
showText Word8
b)
        (Word8
r, Word8
g, Word8
b) = Double -> (Word8, Word8, Word8)
interpolateHeatmapColor Double
fraction

-- | Percentage Argument must be smaller in [0; 1]
interpolateHeatmapColor :: Double -> (Word8, Word8, Word8)
interpolateHeatmapColor :: Double -> (Word8, Word8, Word8)
interpolateHeatmapColor Double
percentage =
  if Double
percentage Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0.5
    then
      let point :: Double
point = (Double
percentage Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
0.5) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2
          -- less is more red, interpolate towards 0
          g :: Double
g = Double
255 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
point Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
255
       in (Word8
255, Double -> Word8
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
g, Word8
0)
    else
      let point :: Double
point = Double
percentage Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
2
          r :: Double
r = Double
128 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
127 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
point
       in (Double -> Word8
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
r, Word8
255, Word8
0)
  where
    _red, _yellow, _green :: (Word8, Word8, Word8)
    _red :: (Word8, Word8, Word8)
_red = (Word8
255, Word8
0, Word8
0)
    _yellow :: (Word8, Word8, Word8)
_yellow = (Word8
255, Word8
255, Word8
0)
    _green :: (Word8, Word8, Word8)
_green = (Word8
128, Word8
255, Word8
0)

-- >>> splitTextFromTo (4, 40) (4, 43) "abc\ndef"
-- ("abc","\ndef")

splitTextFromTo :: SourcePos -> (Int, Int) -> T.Text -> (T.Text, T.Text)
splitTextFromTo :: SourcePos -> SourcePos -> Text -> (Text, Text)
splitTextFromTo SourcePos
startPos SourcePos
endPos Text
t =
  (State SourcePos (Text, Text) -> SourcePos -> (Text, Text))
-> SourcePos -> State SourcePos (Text, Text) -> (Text, Text)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State SourcePos (Text, Text) -> SourcePos -> (Text, Text)
forall s a. State s a -> s -> a
evalState SourcePos
startPos (State SourcePos (Text, Text) -> (Text, Text))
-> State SourcePos (Text, Text) -> (Text, Text)
forall a b. (a -> b) -> a -> b
$
    (Char -> StateT SourcePos Identity Bool)
-> Text -> State SourcePos (Text, Text)
forall (m :: * -> *).
Monad m =>
(Char -> m Bool) -> Text -> m (Text, Text)
T.spanM Char -> StateT SourcePos Identity Bool
stepChar Text
t
  where
    -- general category @LineSeparator@ is not used for Newlines
    isNewline :: Char -> Bool
isNewline Char
c = case Char
c of
      Char
'\n' -> Bool
True
      Char
'\r' -> Bool
True
      Char
_ -> Bool
False

    stepChar :: Char -> State SourcePos Bool
    stepChar :: Char -> StateT SourcePos Identity Bool
stepChar Char
char = do
      -- do the check at the start, this way the last character is always included
      oldPos <- StateT SourcePos Identity SourcePos
forall s (m :: * -> *). MonadState s m => m s
get

      modify $
        if isNewline char
          then \(Int
l, Int
_) -> (Int -> Int
forall a. Enum a => a -> a
succ Int
l, Int
1)
          else second succ

      pure (oldPos /= endPos)

renderTextFromUntil :: SourcePos -> SourcePos -> T.Text -> (H.Html, T.Text)
renderTextFromUntil :: SourcePos -> SourcePos -> Text -> (Html, Text)
renderTextFromUntil SourcePos
startPos SourcePos
endPos Text
t =
  let (Text
included, Text
rest) = SourcePos -> SourcePos -> Text -> (Text, Text)
splitTextFromTo SourcePos
startPos SourcePos
endPos Text
t
   in (Text -> Html
H.text Text
included, Text
rest)