{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}

{- |
Module      : Granite.Flame
Copyright   : (c) 2025
License     : MIT
Maintainer  : mschavinda@gmail.com

Differential flame\/icicle graphs. A 'FlameNode' tree carries, per frame, the
summed positive delta ('fnPos', an increase) and the magnitude of the summed
negative delta ('fnNeg', a decrease, kept non-negative). 'flameDiff' lays the
tree out top→down by depth and emits a standalone @\<svg\>@ document.

A frame's width is its /churn/ (@fnPos + fnNeg@) relative to the root churn.
Within a frame a red part (the increase) and a blue part (the decrease) are
drawn side by side, so a relocation — equal @+x@\/@-x@ — reads as half-red\/
half-blue rather than as a net regression.
-}
module Granite.Flame (
    FlameNode (..),
    FlameOpts (..),
    defFlameOpts,
    flameDiff,
) where

import Data.List (sortOn)
import Data.Ord (Down (..))
import Data.Text (Text)
import Data.Text qualified as T

import Granite.Color (Color (..), colorHex)
import Granite.Internal.Util (escXml, showD, truncatePx)
import Granite.Render.Svg (attr, svgDoc)

data FlameNode = FlameNode
    { FlameNode -> Text
fnLabel :: Text
    -- ^ Frame name.
    , FlameNode -> Double
fnPos :: Double
    {- ^ Summed positive self-delta in this subtree (an increase), in bytes
    (tooltips format it as MB).
    -}
    , FlameNode -> Double
fnNeg :: Double
    {- ^ Summed negative magnitude in this subtree (a decrease, @>= 0@), in bytes
    (tooltips format it as MB).
    -}
    , FlameNode -> [FlameNode]
fnChildren :: [FlameNode]
    }
    deriving (FlameNode -> FlameNode -> Bool
(FlameNode -> FlameNode -> Bool)
-> (FlameNode -> FlameNode -> Bool) -> Eq FlameNode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FlameNode -> FlameNode -> Bool
== :: FlameNode -> FlameNode -> Bool
$c/= :: FlameNode -> FlameNode -> Bool
/= :: FlameNode -> FlameNode -> Bool
Eq, Int -> FlameNode -> ShowS
[FlameNode] -> ShowS
FlameNode -> String
(Int -> FlameNode -> ShowS)
-> (FlameNode -> String)
-> ([FlameNode] -> ShowS)
-> Show FlameNode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FlameNode -> ShowS
showsPrec :: Int -> FlameNode -> ShowS
$cshow :: FlameNode -> String
show :: FlameNode -> String
$cshowList :: [FlameNode] -> ShowS
showList :: [FlameNode] -> ShowS
Show)

data FlameOpts = FlameOpts
    { FlameOpts -> Double
foWidth :: Double
    -- ^ Total SVG width in px.
    , FlameOpts -> Double
foRowH :: Double
    -- ^ Height of one depth row in px.
    , FlameOpts -> Int
foMaxDepth :: Int
    -- ^ Deepest depth drawn (root is depth 0).
    , FlameOpts -> Text
foTitle :: Text
    -- ^ Heading drawn above the chart.
    , FlameOpts -> Double
foMinPx :: Double
    -- ^ Frames narrower than this (in px) are dropped.
    }
    deriving (FlameOpts -> FlameOpts -> Bool
(FlameOpts -> FlameOpts -> Bool)
-> (FlameOpts -> FlameOpts -> Bool) -> Eq FlameOpts
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FlameOpts -> FlameOpts -> Bool
== :: FlameOpts -> FlameOpts -> Bool
$c/= :: FlameOpts -> FlameOpts -> Bool
/= :: FlameOpts -> FlameOpts -> Bool
Eq, Int -> FlameOpts -> ShowS
[FlameOpts] -> ShowS
FlameOpts -> String
(Int -> FlameOpts -> ShowS)
-> (FlameOpts -> String)
-> ([FlameOpts] -> ShowS)
-> Show FlameOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FlameOpts -> ShowS
showsPrec :: Int -> FlameOpts -> ShowS
$cshow :: FlameOpts -> String
show :: FlameOpts -> String
$cshowList :: [FlameOpts] -> ShowS
showList :: [FlameOpts] -> ShowS
Show)

defFlameOpts :: FlameOpts
defFlameOpts :: FlameOpts
defFlameOpts =
    FlameOpts
        { foWidth :: Double
foWidth = Double
1200
        , foRowH :: Double
foRowH = Double
18
        , foMaxDepth :: Int
foMaxDepth = Int
24
        , foTitle :: Text
foTitle = Text
"Differential flame graph"
        , foMinPx :: Double
foMinPx = Double
1.5
        }

flameRed :: Color
flameRed :: Color
flameRed = Word8 -> Word8 -> Word8 -> Color
Color Word8
206 Word8
80 Word8
80

flameBlue :: Color
flameBlue :: Color
flameBlue = Word8 -> Word8 -> Word8 -> Color
Color Word8
80 Word8
100 Word8
206

-- | The churn (rendered width unit) of a frame: its red + blue magnitude.
churn :: FlameNode -> Double
churn :: FlameNode -> Double
churn FlameNode
n = FlameNode -> Double
fnPos FlameNode
n Double -> Double -> Double
forall a. Num a => a -> a -> a
+ FlameNode -> Double
fnNeg FlameNode
n

{- | Render a differential flame graph as a full standalone @\<svg\>@ document.
Rows go top→down by depth; a frame's width is proportional to its churn over the
root churn; children are laid left→right sorted by descending churn; frames
narrower than 'foMinPx' are dropped and recursion stops past 'foMaxDepth'.
-}
flameDiff :: FlameNode -> FlameOpts -> Text
flameDiff :: FlameNode -> FlameOpts -> Text
flameDiff FlameNode
root FlameOpts
opts =
    let titleH :: Double
titleH = if Text -> Bool
T.null (FlameOpts -> Text
foTitle FlameOpts
opts) then Double
0 else Double
24
        body :: Text
body = FlameOpts -> FlameNode -> Int -> Double -> Double -> Double -> Text
layout FlameOpts
opts FlameNode
root Int
0 Double
0 (FlameOpts -> Double
foWidth FlameOpts
opts) Double
titleH
        depthUsed :: Int
depthUsed = FlameOpts -> FlameNode -> Int -> Double -> Int
maxDepthDrawn FlameOpts
opts FlameNode
root Int
0 (FlameOpts -> Double
foWidth FlameOpts
opts)
        svgH :: Double
svgH = Double
titleH Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
depthUsed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Double -> Double -> Double
forall a. Num a => a -> a -> a
* FlameOpts -> Double
foRowH FlameOpts
opts Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
4
        heading :: Text
heading
            | Text -> Bool
T.null (FlameOpts -> Text
foTitle FlameOpts
opts) = Text
""
            | Bool
otherwise =
                Text
"<text"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
attr Text
"x" (Double -> Text
showD Double
8)
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
attr Text
"y" (Double -> Text
showD Double
16)
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
attr Text
"font-size" (Double -> Text
showD Double
13)
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
attr Text
"font-weight" Text
"600"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
attr Text
"fill" Text
"#222"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escXml (FlameOpts -> Text
foTitle FlameOpts
opts)
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</text>\n"
     in Double -> Double -> Text -> Text
svgDoc (FlameOpts -> Double
foWidth FlameOpts
opts) Double
svgH (Text
heading Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
body)

{- | Children paired with their pixel width given the parent's width @w@,
left→right in draw order (descending churn). Shared by 'layout' and
'maxDepthDrawn' so the height estimate uses the same widths that are drawn.
-}
childWidths :: FlameNode -> Double -> [(FlameNode, Double)]
childWidths :: FlameNode -> Double -> [(FlameNode, Double)]
childWidths FlameNode
node Double
w
    | Double
total Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0 = []
    | Bool
otherwise =
        [(FlameNode
k, FlameNode -> Double
churn FlameNode
k Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
total Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
w) | FlameNode
k <- (FlameNode -> Down Double) -> [FlameNode] -> [FlameNode]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Double -> Down Double
forall a. a -> Down a
Down (Double -> Down Double)
-> (FlameNode -> Double) -> FlameNode -> Down Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlameNode -> Double
churn) (FlameNode -> [FlameNode]
fnChildren FlameNode
node)]
  where
    total :: Double
total = FlameNode -> Double
churn FlameNode
node

{- | The deepest depth that will actually be drawn, so the SVG height fits the
visible frames rather than 'foMaxDepth'. Measures child widths against the
parent's narrowed width (via 'childWidths'), matching 'layout'.
-}
maxDepthDrawn :: FlameOpts -> FlameNode -> Int -> Double -> Int
maxDepthDrawn :: FlameOpts -> FlameNode -> Int -> Double -> Int
maxDepthDrawn FlameOpts
opts FlameNode
node Int
depth Double
w
    | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= FlameOpts -> Int
foMaxDepth FlameOpts
opts = Int
depth
    | Bool
otherwise = case [(FlameNode, Double)]
visible of
        [] -> Int
depth
        [(FlameNode, Double)]
kids -> [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Int
depth Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [FlameOpts -> FlameNode -> Int -> Double -> Int
maxDepthDrawn FlameOpts
opts FlameNode
k (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Double
kw | (FlameNode
k, Double
kw) <- [(FlameNode, Double)]
kids])
  where
    visible :: [(FlameNode, Double)]
visible = [(FlameNode
k, Double
kw) | (FlameNode
k, Double
kw) <- FlameNode -> Double -> [(FlameNode, Double)]
childWidths FlameNode
node Double
w, Double
kw Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= FlameOpts -> Double
foMinPx FlameOpts
opts]

{- | Emit a frame and its children. @x0@ is the frame's left edge in px, @w@ its
width in px; children share the parent's width split by churn proportion.
-}
layout :: FlameOpts -> FlameNode -> Int -> Double -> Double -> Double -> Text
layout :: FlameOpts -> FlameNode -> Int -> Double -> Double -> Double -> Text
layout FlameOpts
opts FlameNode
node Int
depth Double
x0 Double
w Double
yOff
    | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> FlameOpts -> Int
foMaxDepth FlameOpts
opts = Text
""
    | Double
w Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< FlameOpts -> Double
foMinPx FlameOpts
opts = Text
""
    | Bool
otherwise = Text
frame Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
childMarks
  where
    y :: Double
y = Double
yOff Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
depth Double -> Double -> Double
forall a. Num a => a -> a -> a
* FlameOpts -> Double
foRowH FlameOpts
opts
    frame :: Text
frame = FlameOpts -> FlameNode -> Double -> Double -> Double -> Text
drawFrame FlameOpts
opts FlameNode
node Double
x0 Double
y Double
w
    childMarks :: Text
childMarks = [Text] -> Text
T.concat (Double -> [(FlameNode, Double)] -> [Text]
go Double
x0 (FlameNode -> Double -> [(FlameNode, Double)]
childWidths FlameNode
node Double
w))
    go :: Double -> [(FlameNode, Double)] -> [Text]
go Double
_ [] = []
    go Double
cx ((FlameNode
k, Double
kw) : [(FlameNode, Double)]
ks) =
        FlameOpts -> FlameNode -> Int -> Double -> Double -> Double -> Text
layout FlameOpts
opts FlameNode
k (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Double
cx Double
kw Double
yOff Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Double -> [(FlameNode, Double)] -> [Text]
go (Double
cx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
kw) [(FlameNode, Double)]
ks

{- | One frame: a red rect (width ∝ 'fnPos') then a blue rect (width ∝ 'fnNeg')
side by side, a thin white stroke, a clipped label when wide enough, and a
@\<title\>@ tooltip carrying the full label plus the pos\/neg in MB.
-}
drawFrame :: FlameOpts -> FlameNode -> Double -> Double -> Double -> Text
drawFrame :: FlameOpts -> FlameNode -> Double -> Double -> Double -> Text
drawFrame FlameOpts
opts FlameNode
node Double
x Double
y Double
w =
    Text
"<g>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tooltip Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
redRect Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
blueRect Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
label Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</g>\n"
  where
    h :: Double
h = FlameOpts -> Double
foRowH FlameOpts
opts Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
1
    total :: Double
total = FlameNode -> Double
churn FlameNode
node
    posW :: Double
posW = if Double
total Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0 then Double
0 else FlameNode -> Double
fnPos FlameNode
node Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
total Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
w
    negW :: Double
negW = Double
w Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
posW
    redRect :: Text
redRect = Double -> Double -> Double -> Double -> Color -> Text
rectAt Double
x Double
y Double
posW Double
h Color
flameRed
    blueRect :: Text
blueRect = Double -> Double -> Double -> Double -> Color -> Text
rectAt (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
posW) Double
y Double
negW Double
h Color
flameBlue
    tooltip :: Text
tooltip = Text
"<title>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escXml Text
titleTxt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</title>"
    titleTxt :: Text
titleTxt =
        FlameNode -> Text
fnLabel FlameNode
node
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (+"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Double -> Text
mb (FlameNode -> Double
fnPos FlameNode
node)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" / -"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Double -> Text
mb (FlameNode -> Double
fnNeg FlameNode
node)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    label :: Text
label
        | Double
w Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
24 = Text
""
        | Bool
otherwise =
            let (Text
txt, Maybe Text
_) = Double -> Double -> Text -> (Text, Maybe Text)
truncatePx Double
11 (Double
w Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
6) (FlameNode -> Text
fnLabel FlameNode
node)
             in Text
"<text"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
attr Text
"x" (Double -> Text
showD (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
3))
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
attr Text
"y" (Double -> Text
showD (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
h Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
4))
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
attr Text
"font-size" (Double -> Text
showD Double
11)
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
attr Text
"fill" Text
"#fff"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">"
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
escXml Text
txt
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</text>\n"

rectAt :: Double -> Double -> Double -> Double -> Color -> Text
rectAt :: Double -> Double -> Double -> Double -> Color -> Text
rectAt Double
x Double
y Double
w Double
h Color
fill
    | Double
w Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0 = Text
""
    | Bool
otherwise =
        Text
"<rect"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
attr Text
"x" (Double -> Text
showD Double
x)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
attr Text
"y" (Double -> Text
showD Double
y)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
attr Text
"width" (Double -> Text
showD Double
w)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
attr Text
"height" (Double -> Text
showD Double
h)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
attr Text
"fill" (Color -> Text
colorHex Color
fill)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
attr Text
"stroke" Text
"#ffffff"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text
attr Text
"stroke-width" (Double -> Text
showD Double
0.5)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/>\n"

-- | Format a byte magnitude as megabytes to one decimal place (e.g. @9.4MB@).
mb :: Double -> Text
mb :: Double -> Text
mb Double
bytes = Double -> Text
showD (Int -> Double -> Double
roundTo Int
1 (Double
bytes Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"MB"

-- | Round to @n@ decimal places.
roundTo :: Int -> Double -> Double
roundTo :: Int -> Double -> Double
roundTo Int
n Double
x = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
f) :: Integer) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
f
  where
    f :: Double
f = Double
10 Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
n