Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
106 changes: 105 additions & 1 deletion flake.lock

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

5 changes: 3 additions & 2 deletions flake.nix
Original file line number Diff line number Diff line change
Expand Up @@ -5,9 +5,10 @@
haskell-flake.url = "github:srid/haskell-flake";
hell.url = "github:chrisdone/hell?ref=551133cecdafed1d6d3f4da7d8a466df2eed8af5";
nix2container.url = "github:nlewo/nix2container";
nixd.url = "github:nix-community/nixd";
};

outputs = inputs@{ self, nixpkgs, flake-parts, hell, nix2container, ... }:
outputs = inputs@{ self, nixpkgs, flake-parts, hell, nix2container, nixd, ... }:
flake-parts.lib.mkFlake { inherit inputs; } {
systems = nixpkgs.lib.systems.flakeExposed;
imports = [ inputs.haskell-flake.flakeModule ];
Expand Down Expand Up @@ -42,7 +43,7 @@
hpack = hp.hpack;
webook = pkgs.webhook;
hell = hell.packages.${system}.default;

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Just added this because it is a language server for nix and my editor was complaining I didnt have one but can remove

nixd = nixd.packages.${system}.default;
};

};
Expand Down
36 changes: 21 additions & 15 deletions src/Perf/Web/Chart.hs
Original file line number Diff line number Diff line change
@@ -1,25 +1,31 @@
module Perf.Web.Chart where

import Data.Aeson
import Data.Text (Text)
import Data.ByteString.Lazy as L
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Lucid

chart_ :: Text -> Value -> Html ()
chart_ idx config = do
div_ [class_ "width: 400px; height: 400px; margin: 0 auto; padding: 20px;"] do
canvas_ [id_ idx, style_ "height: 250px; max-width: 400px;"] do
pure ()
chart_ :: Text -> Value -> Value -> Html ()
chart_ idx plotData layout = do
div_ [id_ idx, style_ "height: 300px; max-width: 400px;"] do
pure ()
script_ $
T.concat [
"(() => {",
"const config = ", encode' config, ";",
"const ctx = document.getElementById(", encode' idx, ").getContext('2d');",
"new Chart(ctx, config);"
, "})();"
]
T.concat
[ "(() => {",
"const data = ",
encode' plotData,
";",
"const layout = ",
encode' layout,
";",
"const config = {responsive: true, modeBarButtonsToRemove: ['select2d', 'lasso2d']};",
"Plotly.newPlot(",
encode' idx,
", data, layout, config);",
"})();"
]

encode' :: ToJSON a => a -> Text
encode' = T.decodeUtf8 . L.toStrict . encode
12 changes: 1 addition & 11 deletions src/Perf/Web/Layout.hs
Original file line number Diff line number Diff line change
Expand Up @@ -19,21 +19,11 @@ defaultLayout_ title body = do
"table.metrics td, table.metrics th {border: 1px solid black; padding: 2px;}"
]
script_
[ src_ "https://cdn.jsdelivr.net/npm/chart.js@4.5.1/dist/chart.umd.min.js",
integrity_ "sha256-SERKgtTty1vsDxll+qzd4Y2cF9swY9BCq62i9wXJ9Uo=",
[ src_ "https://cdn.jsdelivr.net/npm/plotly.js-dist-min@2.35.2/plotly.min.js",
crossorigin_ "anonymous",
makeAttributes "referrerpolicy" "no-referrer"
]
(mempty :: Text)
script_
[ src_ "https://cdn.jsdelivr.net/npm/chartjs-plugin-crosshair@2.0.0/dist/chartjs-plugin-crosshair.min.js",
integrity_ "sha256-5bTtdEYtbjO36pQbMCXOsoYW5u5jfYfyI41LelMTTbQ=",
crossorigin_ "anonymous",
makeAttributes "referrerpolicy" "no-referrer"
]
(mempty :: Text)
script_ [type_ "text/javascript"] $ do
toHtmlRaw ("Chart.defaults.font.family = 'monospace';" :: Text)
body_ do
h1_ $ toHtml title
crumbs <- asks (.crumbs)
Expand Down
116 changes: 40 additions & 76 deletions src/Perf/Web/Routes.hs
Original file line number Diff line number Diff line change
Expand Up @@ -131,88 +131,52 @@ generatePlots benchmarks = do
let dataSets =
map (second (maybe [] Map.elems . Map.lookup metricLabel)) $
Map.toList tests
chart_ (T.pack (show b_i) <> "-" <> T.pack (show m_i)) $
makeChartConfig metricLabel labels dataSets
let (plotData, layout) = makePlotlyConfig metricLabel labels dataSets
chart_ (T.pack (show b_i) <> "-" <> T.pack (show m_i)) plotData layout

makeChartConfig ::
makePlotlyConfig ::
Prim.MetricLabel ->
Set DB.Commit ->
[(Set Prim.GeneralFactor, [DB.Metric])] ->
Value
makeChartConfig metricName commits dataSets =
object
[ "type" .= ("line" :: Text),
"data" .= chartData,
"options"
.= object
[ "responsive" .= True,
"maintainAspectRatio" .= True,
"animations" .= False,
"plugins"
.= object
[ "title"
.= object
[ "display" .= True,
"text" .= coerce @_ @Text metricName,
"font"
.= object
[ "size" .= (16 :: Int)
]
],
"tooltip"
.= object
[ "mode" .= ("point" :: Text),
"intersect" .= False
],
"crosshair"
.= object
[ "sync"
.= object
[ "enabled" .= True,
"group" .= (1 :: Int)
],
"zoom"
.= object
[ "enabled" .= True
]
]
],
"scales"
.= object
[ "x"
.= object
[ "title"
.= object
[ "display" .= False,
"text" .= ("Commits" :: Text)
]
],
"y"
.= object
[ "title"
.= object
[ "display" .= True,
"text" .= coerce @_ @Text metricName
],
"beginAtZero" .= True
]
]
]
]
(Value, Value)
makePlotlyConfig metricName commits dataSets =
(toJSON traces, layout)
where
chartData =
commitLabels = List.map (T.take 8 . (coerce :: Prim.Hash -> Text) . (.commitHash)) (Set.toList commits)
traces =
[ object
[ "x" .= commitLabels,
"y" .= fillLeft (Set.size commits) Null (map (toJSON . (.metricMean)) metrics :: [Value]),
"type" .= ("scatter" :: Text),
"mode" .= ("lines+markers" :: Text),
"name" .= factorsSmall factors,
"line" .= object ["color" .= color]
]
| ((factors, metrics), color) <- zip dataSets $ cycle colors
]
layout =
object
[ "labels" .= List.map (T.take 8 . (coerce :: Prim.Hash -> Text) . (.commitHash)) (Set.toList commits),
"datasets"
.= [ object
[ "label" .= factorsSmall factors,
"data" .= fillLeft (Set.size commits) Null (map (toJSON . (.metricMean)) metrics :: [Value]),
"borderColor" .= color,
"tension" .= (0.1 :: Double),
"fill" .= False
]
| ((factors, metrics), color) <- zip dataSets $ cycle colors
]
[ "title"
.= object
[ "text" .= coerce @_ @Text metricName,
"font" .= object ["family" .= ("monospace" :: Text), "size" .= (16 :: Int)]
],
"xaxis"
.= object
[ "title" .= ("" :: Text),
"tickfont" .= object ["family" .= ("monospace" :: Text)]
],
"yaxis"
.= object
[ "title" .= coerce @_ @Text metricName,
"rangemode" .= ("tozero" :: Text),
"tickfont" .= object ["family" .= ("monospace" :: Text)]
],
"font" .= object ["family" .= ("monospace" :: Text)],
"hovermode" .= ("x unified" :: Text),
"showlegend" .= True,
"legend" .= object ["x" .= (1 :: Int), "y" .= (0 :: Int), "xanchor" .= ("right" :: Text), "bgcolor" .= ("rgba(0,0,0,0)" :: Text), "font" .= object ["color" .= ("rgba(0,0,0,0.4)" :: Text)]],
"margin" .= object ["t" .= (40 :: Int), "b" .= (40 :: Int), "l" .= (60 :: Int), "r" .= (20 :: Int)]
]
colors :: [Text] =
T.words
Expand Down