diff --git a/app/BenchmarkDisplay.hs b/app/BenchmarkDisplay.hs index 3cf3e2b..3d10788 100644 --- a/app/BenchmarkDisplay.hs +++ b/app/BenchmarkDisplay.hs @@ -2,13 +2,13 @@ import Data.Aeson (eitherDecodeFileStrict') import Data.Char (isHexDigit) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty -import Data.Maybe (catMaybes) import Data.Text (Text) +import Data.Text.IO qualified as TIO import Data.Text qualified as T import Data.Text.Lazy.IO qualified as LTIO -import Database.Persist +import Database.Persist (SelectOpt (Asc), entityVal, selectList) import Database.Persist.Sqlite (runMigration, runSqlite) -import Lucid (renderText) +import Lucid (Html, renderText) import Options.Applicative import Perf.DB.Materialize import Perf.Types.DB qualified as DB @@ -26,41 +26,65 @@ data Cli = Cli sqlitePath :: Maybe FilePath, branchName :: Text, maxCommits :: Int, + listBranches :: Bool, jsonFiles :: [FilePath] } data Source = JsonFiles (NonEmpty FilePath) | Sqlite FilePath Text Int + | ListBranches FilePath main :: IO () main = do cli <- execParser parserInfo source <- validateSource cli - html <- case source of + case source of + ListBranches sqlite -> listBranchesFromSqlite sqlite JsonFiles files -> do snapshots <- mapM loadSnapshot $ NonEmpty.toList files - pure $ - staticLayout_ "Benchmarks" $ - generateExternalPlots $ - materializeExternalSnapshots $ - NonEmpty.fromList snapshots + let html = + staticLayout_ "Benchmarks" $ + generateExternalPlots $ + materializeExternalSnapshots $ + NonEmpty.fromList snapshots + writeAndOpen cli.outputPath html Sqlite sqlite branch limit -> do - benchmarks <- loadBenchmarksFromSqlite sqlite branch limit - pure $ - staticLayout_ ("Benchmarks: " <> branch) $ - generateCommitPlots benchmarks - absoluteOutput <- makeAbsolute cli.outputPath + mplotData <- loadBenchmarksFromSqlite sqlite branch limit + let htmlBody = case mplotData of + Nothing -> mempty + Just plotData -> + generateCommitPlotsWith + (MasterComparisonEnabled plotData.masterCommits) + plotData.branchCommits + plotData.benchmarks + writeAndOpen cli.outputPath $ + staticLayout_ ("Benchmarks: " <> branch) htmlBody + +writeAndOpen :: FilePath -> Html () -> IO () +writeAndOpen outputPath html = do + absoluteOutput <- makeAbsolute outputPath LTIO.writeFile absoluteOutput (renderText html) openFile absoluteOutput validateSource :: Cli -> IO Source validateSource cli = - case (cli.sqlitePath, NonEmpty.nonEmpty cli.jsonFiles) of - (Just sqlite, Nothing) -> pure $ Sqlite sqlite cli.branchName cli.maxCommits - (Nothing, Just files) -> pure $ JsonFiles files - (Just _, Just _) -> die "Use either JSON files or --sqlite, not both." - (Nothing, Nothing) -> die "Provide one or more JSON files, or use --sqlite." + case (cli.listBranches, cli.sqlitePath, NonEmpty.nonEmpty cli.jsonFiles) of + (True, Just sqlite, Nothing) -> pure $ ListBranches sqlite + (True, Nothing, _) -> die "--list-branches requires --sqlite PATH." + (True, Just _, Just _) -> die "Use --list-branches with --sqlite only, not with JSON files." + (False, Just sqlite, Nothing) -> pure $ Sqlite sqlite cli.branchName cli.maxCommits + (False, Nothing, Just files) -> pure $ JsonFiles files + (False, Just _, Just _) -> die "Use either JSON files or --sqlite, not both." + (False, Nothing, Nothing) -> die "Provide one or more JSON files, or use --sqlite." + +listBranchesFromSqlite :: FilePath -> IO () +listBranchesFromSqlite sqlite = do + names <- runSqlite (T.pack sqlite) do + runMigration DB.migrateAll + branches <- selectList @DB.Branch [] [Asc DB.BranchName] + pure $ map ((.branchName) . entityVal) branches + mapM_ TIO.putStrLn names loadSnapshot :: FilePath -> IO (Text, [EX.Benchmark]) loadSnapshot path = do @@ -78,22 +102,15 @@ labelFromPath path = then T.pack suffix else T.pack base -loadBenchmarksFromSqlite :: FilePath -> Text -> Int -> IO (BenchmarkSeries DB.Commit DB.Metric) +-- | Load plot data from sqlite (no HTML). +loadBenchmarksFromSqlite :: FilePath -> Text -> Int -> IO (Maybe BranchPlotData) loadBenchmarksFromSqlite sqlite branch limit = runSqlite (T.pack sqlite) do runMigration DB.migrateAll - mbranch <- selectFirst [DB.BranchName ==. branch] [] - case mbranch of - Nothing -> pure mempty - Just (Entity branchId _) -> do - mappings <- - selectList - [DB.MapBranchCommitBranchId ==. branchId] - [Desc DB.MapBranchCommitId, LimitTo limit] - commits <- mapM (\mapping -> selectFirst [DB.CommitId ==. mapping.entityVal.mapBranchCommitCommitId] []) mappings - case NonEmpty.nonEmpty $ reverse $ catMaybes commits of - Nothing -> pure mempty - Just existingCommits -> materializeCommits existingCommits + loadBranchPlotData + branch + limit + (if branch == "master" then maxMasterCommits else maxMasterCommitsOnBranch) openFile :: FilePath -> IO () openFile path = @@ -102,8 +119,8 @@ openFile path = "linux" -> runOpen "xdg-open" _ -> putStrLn $ "Wrote " <> path where - runOpen command = do - status <- rawSystem command [path] + runOpen openCommand = do + status <- rawSystem openCommand [path] case status of ExitSuccess -> pure () _ -> putStrLn $ "Wrote " <> path @@ -148,6 +165,10 @@ cliParser = <> showDefault <> help "Number of most recent commits in sqlite mode." ) + <*> switch + ( long "list-branches" + <> help "With --sqlite, print available branch names and exit." + ) <*> many (strArgument ( metavar "JSON_FILES..." diff --git a/package.yaml b/package.yaml index ba9d8ea..5a39c96 100644 --- a/package.yaml +++ b/package.yaml @@ -46,6 +46,7 @@ dependencies: - persistent-template - hspec-discover - containers +- neat-interpolation ghc-options: - -Wall diff --git a/perfly.cabal b/perfly.cabal index 45794da..66b88f1 100644 --- a/perfly.cabal +++ b/perfly.cabal @@ -63,6 +63,7 @@ library , lucid2 , monad-logger , mtl + , neat-interpolation , persistent , persistent-sqlite , persistent-template diff --git a/readme.md b/readme.md index 9090026..abbe6f3 100644 --- a/readme.md +++ b/readme.md @@ -93,6 +93,7 @@ cabal run benchmark-display -- --output benchmark.html run-1.json run-2.json Notes: +- To get the sqlite DB file, use a command like this: `scp your.deployed.host:/root/perfly/perf.sqlite3 .` - adjust directories as needed. - The generated file defaults to `benchmark-display.html`. - After writing, the tool runs `open benchmark-display.html` on macOS (or `xdg-open` on Linux). diff --git a/src/Perf/DB/Materialize.hs b/src/Perf/DB/Materialize.hs index d205316..a17dca8 100644 --- a/src/Perf/DB/Materialize.hs +++ b/src/Perf/DB/Materialize.hs @@ -1,5 +1,6 @@ module Perf.DB.Materialize where +import Data.Maybe (catMaybes) import qualified Data.List as List import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty @@ -25,6 +26,105 @@ data DisplayMetric = DisplayMetric } deriving (Eq, Show) +-- | Most recent commits on a branch, returned in historical order (oldest first). +loadBranchCommits :: Text -> Int -> DB.DB [Entity DB.Commit] +loadBranchCommits branchName limit = do + mbranch <- selectFirst [DB.BranchName ==. branchName] [] + case mbranch of + Nothing -> pure [] + Just (Entity branchId _) -> do + mappings <- + selectList + [DB.MapBranchCommitBranchId ==. branchId] + [Desc DB.MapBranchCommitId, LimitTo limit] + commits <- + mapM + (\mapping -> selectFirst [DB.CommitId ==. mapping.entityVal.mapBranchCommitCommitId] []) + mappings + pure $ reverse $ catMaybes commits + +-- | Merge master metrics into branch subjects only (drop master-only subjects). +mergeMasterIntoBranch :: + Ord key => + BenchmarkSeries key metric -> + BenchmarkSeries key metric -> + BenchmarkSeries key metric +mergeMasterIntoBranch masterBenchmarks branchBenchmarks = + Map.mapWithKey + ( \subject branchTests -> + case Map.lookup subject masterBenchmarks of + Nothing -> branchTests + Just masterTests -> + Map.unionWith (Map.unionWith Map.union) masterTests branchTests + ) + branchBenchmarks + +-- | Loaded plot series for a branch page / CLI report. +data BranchPlotData = BranchPlotData + { masterCommits :: [DB.Commit], + -- ^ Master commits in historical order (oldest first). + branchCommits :: [DB.Commit], + -- ^ Current-branch commits in historical order; empty when viewing master. + benchmarks :: BenchmarkSeries DB.Commit DB.Metric, + tableCommitEntities :: [Entity DB.Commit] + -- ^ Commits for the branch commits table (historical order). + } + +-- | Load master + branch series for plotting. +-- +-- When @branchName == "master"@, @branchCommits@ is empty and @benchmarks@ +-- contains only master data. Otherwise master metrics are merged into branch +-- subjects (master-only subjects are dropped). +loadBranchPlotData :: + Text -> + Int -> + Int -> + DB.DB (Maybe BranchPlotData) +loadBranchPlotData branchName branchLimit masterLimit = do + let isMaster = branchName == "master" + masterEntities <- loadBranchCommits "master" masterLimit + branchEntities <- + if isMaster + then pure [] + else loadBranchCommits branchName branchLimit + let masterCommits = map entityVal masterEntities + branchCommits = map entityVal branchEntities + tableCommitEntities = if isMaster then masterEntities else branchEntities + case (isMaster, NonEmpty.nonEmpty masterEntities, NonEmpty.nonEmpty branchEntities) of + (True, Nothing, _) -> pure Nothing + (True, Just masterNE, _) -> do + benchmarks <- materializeCommits masterNE + pure $ + Just + BranchPlotData + { masterCommits, + branchCommits = [], + benchmarks, + tableCommitEntities + } + (False, _, Nothing) -> pure Nothing + (False, Nothing, Just branchNE) -> do + benchmarks <- materializeCommits branchNE + pure $ + Just + BranchPlotData + { masterCommits, + branchCommits, + benchmarks, + tableCommitEntities + } + (False, Just masterNE, Just branchNE) -> do + masterBenchmarks <- materializeCommits masterNE + branchBenchmarks <- materializeCommits branchNE + pure $ + Just + BranchPlotData + { masterCommits, + branchCommits, + benchmarks = mergeMasterIntoBranch masterBenchmarks branchBenchmarks, + tableCommitEntities + } + -- Materialize a set of commits into a data set we can work with. materializeCommits :: NonEmpty (Entity DB.Commit) -> diff --git a/src/Perf/Web/Chart.hs b/src/Perf/Web/Chart.hs index 9187562..0e6e204 100644 --- a/src/Perf/Web/Chart.hs +++ b/src/Perf/Web/Chart.hs @@ -6,26 +6,41 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T import Lucid +import Lucid.Base (makeAttributes) -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 data = ", - encode' plotData, - ";", - "const layout = ", - encode' layout, - ";", - "const config = {responsive: true, modeBarButtonsToRemove: ['select2d', 'lasso2d']};", - "Plotly.newPlot(", - encode' idx, - ", data, layout, config);", - "})();" - ] +data ChartOptions = ChartOptions + { chartId :: Text, + plotData :: Value, + layout :: Value, + masterCount :: Int, + heightPx :: Int + } + +-- | Shared Plotly config (also embedded in the plot-controls script). +plotlyConfig :: Value +plotlyConfig = + object + [ "responsive" .= True, + "modeBarButtonsToRemove" .= (["select2d", "lasso2d"] :: [Text]) + ] + +plotlyConfigJson :: Text +plotlyConfigJson = encode' plotlyConfig + +-- | Emit a plot container. The shared controls script in 'Perf.Web.Plot' calls +-- @Plotly.newPlot@ / @Plotly.react@ using the data-* attributes (so master-commit +-- slicing and legend toggles can update plots in the browser). +chart_ :: ChartOptions -> Html () +chart_ opts = do + div_ + [ id_ opts.chartId, + class_ "benchmark-plot", + style_ $ "height: " <> T.pack (show opts.heightPx) <> "px;", + makeAttributes "data-full" (encode' opts.plotData), + makeAttributes "data-layout" (encode' opts.layout), + makeAttributes "data-master-count" (T.pack (show opts.masterCount)) + ] + (pure ()) encode' :: ToJSON a => a -> Text encode' = T.decodeUtf8 . L.toStrict . encode diff --git a/src/Perf/Web/Layout.hs b/src/Perf/Web/Layout.hs index 50ac3d9..538b763 100644 --- a/src/Perf/Web/Layout.hs +++ b/src/Perf/Web/Layout.hs @@ -2,8 +2,8 @@ module Perf.Web.Layout where import Data.List qualified as List import Data.Text (Text) -import Data.Text qualified as T import Lucid.Base +import NeatInterpolation (trimming) import Perf.Types.Web import Yesod.Lucid @@ -34,15 +34,29 @@ headCommon_ :: Monad m => Text -> HtmlT m () headCommon_ title = head_ do meta_ [charset_ "utf-8"] + meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1"] title_ $ toHtml title - style_ $ - T.unwords - [ "body {font-family: monospace; margin: 0 auto; max-width: 800px;}", - "table.metrics td, table.metrics th {border: 1px solid black; padding: 2px;}" - ] + style_ commonStyles script_ [ src_ "https://cdn.jsdelivr.net/npm/plotly.js-dist-min@2.35.2/plotly.min.js", crossorigin_ "anonymous", makeAttributes "referrerpolicy" "no-referrer" ] (mempty :: Text) + +commonStyles :: Text +commonStyles = + [trimming| + body {font-family: monospace; margin: 24px; max-width: none; background: #f6f7f9; color: #111827;} + table.metrics td, table.metrics th {border: 1px solid black; padding: 2px;} + .benchmark-subject {background: #ffffff; border: 1px solid #e5e7eb; border-radius: 10px; padding: 14px 14px 18px 14px; margin-bottom: 1.25rem;} + .benchmark-subject > h2 {margin: 0 0 8px 0;} + .chart-grid {display: grid; grid-template-columns: repeat(auto-fit, minmax(420px, 1fr)); gap: 1.75rem 12px; align-items: start;} + .chart-cell {min-width: 0; margin-bottom: 0.5rem;} + .benchmark-plot {width: 100%; min-height: 340px;} + .factor-lines {margin-top: 2px; margin-bottom: 0.75rem; color: #6b7280; font-size: 0.92rem; line-height: 1.35;} + .factor-line {margin-top: 4px;} + .factor-toggle {border: none; background: transparent; color: #4b5563; cursor: pointer; font: inherit; display: inline-flex; align-items: center; gap: 8px; padding: 0; text-align: left;} + .factor-toggle.off {opacity: 0.5; text-decoration: line-through;} + .factor-swatch {width: 14px; height: 2px; border-radius: 2px; flex: 0 0 auto;} + |] diff --git a/src/Perf/Web/Plot.hs b/src/Perf/Web/Plot.hs index 798e413..6b0afba 100644 --- a/src/Perf/Web/Plot.hs +++ b/src/Perf/Web/Plot.hs @@ -1,7 +1,6 @@ module Perf.Web.Plot where import Data.Aeson -import Data.Coerce import Data.Foldable qualified as Foldable import Data.Map qualified as Map import Data.Set (Set) @@ -10,50 +9,290 @@ import Data.Text (Text) import Data.Text qualified as T import Control.Monad import Lucid +import Lucid.Base (makeAttributes) +import NeatInterpolation (trimming) import Perf.DB.Materialize import Perf.Types.DB qualified as DB import Perf.Types.Prim qualified as Prim import Perf.Web.Chart +-- | Whether the "Show master branch commits" control is available. +data MasterPlotContext key + = MasterComparisonDisabled + | MasterComparisonEnabled [key] + -- ^ Master keys in historical order (oldest first), at most 'maxMasterCommits'. + +-- | Selectable values for the master-commits control. +masterCommitOptions :: Bool -> [Int] +masterCommitOptions viewingMaster + | viewingMaster = [0, 1, 2, 3, 5, 10, 20, 30, 50, 100] + | otherwise = [0, 1, 2, 3, 5, 10, 20] + +-- | How many master commits to load when viewing master. +maxMasterCommits :: Int +maxMasterCommits = maximum (masterCommitOptions True) + +-- | How many master commits to load when viewing a non-master branch. +maxMasterCommitsOnBranch :: Int +maxMasterCommitsOnBranch = maximum (masterCommitOptions False) + generateCommitPlots :: BenchmarkSeries DB.Commit DB.Metric -> Html () -generateCommitPlots = +generateCommitPlots benchmarks = + generateCommitPlotsWith + MasterComparisonDisabled + (collectKeys benchmarks) + benchmarks + +generateCommitPlotsWith :: + MasterPlotContext DB.Commit -> + [DB.Commit] -> + BenchmarkSeries DB.Commit DB.Metric -> + Html () +generateCommitPlotsWith masterCtx branchCommits = generatePlotsWith - (T.take 8 . (coerce :: Prim.Hash -> Text) . (.commitHash)) + masterCtx + branchCommits + shortCommitLabel (.metricMean) generateExternalPlots :: BenchmarkSeries Text DisplayMetric -> Html () -generateExternalPlots = - generatePlotsWith id (.mean) +generateExternalPlots benchmarks = + generatePlotsWith + MasterComparisonDisabled + (collectKeys benchmarks) + id + (.mean) + benchmarks generatePlotsWith :: Ord key => + MasterPlotContext key -> + [key] -> (key -> Text) -> (metric -> Double) -> BenchmarkSeries key metric -> Html () -generatePlotsWith renderKey metricMean benchmarks = do - unless (Map.null benchmarks) $ h1_ "Plots" +generatePlotsWith masterCtx branchKeys renderKey metricMean benchmarks = do + let masterKeys = case masterCtx of + MasterComparisonDisabled -> [] + MasterComparisonEnabled cs -> cs + masterCount = length masterKeys + orderedKeys = masterKeys <> branchKeys + masterEnabled = case masterCtx of + MasterComparisonDisabled -> False + MasterComparisonEnabled {} -> True + -- On master itself there is no trailing branch series. + viewingMaster = masterEnabled && null branchKeys + defaultMasterShow + | viewingMaster = 20 + | masterEnabled = 1 + | otherwise = 0 + unless (Map.null benchmarks) $ + plotControls_ masterEnabled defaultMasterShow (masterCommitOptions viewingMaster) Foldable.for_ (zip [0 :: Int ..] (Map.toList benchmarks)) \(benchmarkIdx, (subject, tests)) -> do - h2_ $ toHtml subject - let keys = - Set.fromList $ concatMap (concatMap Map.keys . Map.elems) $ Map.elems tests - let orderedKeys = Set.toList keys - let labels = map renderKey orderedKeys let metrics :: Set Prim.MetricLabel = Set.fromList $ concatMap Map.keys $ Map.elems tests - div_ [style_ "display: flex; flex-wrap: wrap;"] do - Foldable.for_ (zip [0 :: Int ..] (Set.toList metrics)) \(metricIdx, metricLabel) -> do - let dataSets = - flip map (Map.toList tests) \(factors, allMetrics) -> - (factors, toSeries orderedKeys (Map.findWithDefault Map.empty metricLabel allMetrics)) - let (plotData, layout) = makePlotlyConfig metricLabel labels dataSets - chart_ (T.pack (show benchmarkIdx) <> "-" <> T.pack (show metricIdx)) plotData layout + div_ + [ class_ "benchmark-subject", + makeAttributes "data-plot-title" (subjectText subject), + -- Match the visible subject heading only (not metric labels like "time"). + makeAttributes "data-search-text" (T.toLower (subjectText subject)) + ] + do + h2_ $ toHtml subject + div_ [class_ "chart-grid"] do + Foldable.for_ (zip [0 :: Int ..] (Set.toList metrics)) \(metricIdx, metricLabel) -> do + let dataSets = + flip map (Map.toList tests) \(factors, allMetrics) -> + (factors, toSeries orderedKeys (Map.findWithDefault Map.empty metricLabel allMetrics)) + labels = map renderKey orderedKeys + (plotData, layout) = makePlotlyConfig metricLabel labels dataSets + chartId = T.pack (show benchmarkIdx) <> "-" <> T.pack (show metricIdx) + legendEntries = + zip (cycle plotColors) (map (factorsSmall . fst) dataSets) + div_ [class_ "chart-cell"] do + chart_ + ChartOptions + { chartId, + plotData, + layout, + masterCount, + heightPx = 360 + } + factorLegend_ chartId legendEntries + unless (Map.null benchmarks) do + style_ masterTickStyles + -- Script must run after plot containers are in the DOM. + script_ plotControlsScript where - toSeries orderedKeys metricMap = - flip map orderedKeys \key -> + toSeries keys metricMap = + flip map keys \key -> maybe Null (toJSON . metricMean) $ Map.lookup key metricMap +collectKeys :: Ord key => BenchmarkSeries key metric -> [key] +collectKeys benchmarks = + Set.toList $ + Set.fromList $ + concatMap (concatMap Map.keys . Map.elems) $ + concatMap Map.elems $ + Map.elems benchmarks + +plotControls_ :: Bool -> Int -> [Int] -> Html () +plotControls_ masterEnabled defaultMasterShow options = do + div_ + [ class_ "plot-controls", + style_ "display: flex; flex-wrap: wrap; gap: 1rem; align-items: center; margin: 1rem 0;" + ] + do + input_ + [ type_ "search", + id_ "plot-search", + placeholder_ "Search in plot title", + style_ "flex: 1 1 30%; min-width: 200px; max-width: 30%; padding: 0.35rem 0.5rem; font-family: monospace;" + ] + label_ + [ for_ "master-commits", + style_ "display: flex; align-items: center; gap: 0.4rem; white-space: nowrap; color: #15803d;" + ] + do + "Show master branch commits:" + select_ + ( [ id_ "master-commits", + style_ "font-family: monospace; padding: 0.25rem; color: #111111;" + ] + <> [makeAttributes "disabled" "disabled" | not masterEnabled] + ) + do + forM_ options \n -> + option_ + ( [value_ (T.pack (show n))] + <> [makeAttributes "selected" "selected" | n == defaultMasterShow] + ) + (toHtml (show n)) + +-- | Color the first N x-axis ticks green via CSS (survives Plotly resize redraws). +masterTickStyles :: Text +masterTickStyles = + T.unlines + [ ".benchmark-plot[data-shown-master=\"" + <> nText + <> "\"] g.xtick:nth-child(-n+" + <> nText + <> ") text { fill: #15803d !important; }" + | n <- masterCommitOptions True + , n > 0 + , let nText = T.pack (show n) + ] + +plotControlsScript :: Text +plotControlsScript = + [trimming| + (function () { + const search = document.getElementById('plot-search'); + const masterSelect = document.getElementById('master-commits'); + const config = ${plotlyConfigJson}; + const traceVisibility = new Map(); + const singleClickTimers = new Map(); + function applySearch() { + if (!search) return; + const q = (search.value || '').trim().toLowerCase(); + document.querySelectorAll('.benchmark-subject').forEach((el) => { + const hay = el.getAttribute('data-search-text') || ''; + el.style.display = (!q || hay.includes(q)) ? '' : 'none'; + }); + } + function masterShow() { + if (!masterSelect || masterSelect.disabled) return 0; + const n = parseInt(masterSelect.value, 10); + return Number.isFinite(n) ? n : 0; + } + function slicePlotData(fullData, masterCount, showMaster) { + const start = Math.max(0, masterCount - showMaster); + return fullData.map((trace) => Object.assign({}, trace, { + x: (trace.x || []).slice(start), + y: (trace.y || []).slice(start) + })); + } + function ensureVisibility(chartId, traceCount) { + let vis = traceVisibility.get(chartId); + if (!vis || vis.length !== traceCount) { + vis = Array.from({length: traceCount}, () => true); + traceVisibility.set(chartId, vis); + } + return vis; + } + function syncLegendUI(chartEl) { + const vis = traceVisibility.get(chartEl.id) || []; + const root = chartEl.parentElement; + if (!root) return; + root.querySelectorAll('.factor-toggle').forEach((btn, i) => { + btn.classList.toggle('off', !vis[i]); + }); + } + function applyVisibility(chartEl) { + const count = (chartEl.data && chartEl.data.length) || 0; + if (!count) return Promise.resolve(); + const vis = ensureVisibility(chartEl.id, count); + syncLegendUI(chartEl); + return Plotly.restyle(chartEl, {visible: vis.slice()}); + } + function redrawPlots() { + const show = masterShow(); + document.querySelectorAll('.benchmark-plot').forEach((el) => { + const fullData = JSON.parse(el.getAttribute('data-full') || '[]'); + const layout = JSON.parse(el.getAttribute('data-layout') || '{}'); + const masterCount = parseInt(el.getAttribute('data-master-count') || '0', 10) || 0; + const data = slicePlotData(fullData, masterCount, show); + ensureVisibility(el.id, data.length); + const shownMaster = Math.min(show, masterCount); + el.setAttribute('data-shown-master', String(shownMaster)); + const finish = () => applyVisibility(el); + const plotted = el.getAttribute('data-plotted') === '1' + ? Plotly.react(el, data, layout, config) + : Plotly.newPlot(el, data, layout, config).then(() => el.setAttribute('data-plotted', '1')); + Promise.resolve(plotted).then(finish); + }); + } + function isolateTrace(chartEl, onlyIdx) { + const count = (chartEl.data && chartEl.data.length) || 0; + const vis = ensureVisibility(chartEl.id, count); + for (let i = 0; i < vis.length; i++) vis[i] = i === onlyIdx; + applyVisibility(chartEl); + } + document.addEventListener('click', (e) => { + const btn = e.target.closest('.factor-toggle'); + if (!btn) return; + const chartId = btn.getAttribute('data-chart-id'); + const traceIdx = parseInt(btn.getAttribute('data-trace-idx'), 10); + const chartEl = chartId ? document.getElementById(chartId) : null; + if (!chartEl || !Number.isFinite(traceIdx)) return; + if (e.detail === 2) { + const prev = singleClickTimers.get(btn); + if (prev) clearTimeout(prev); + singleClickTimers.delete(btn); + isolateTrace(chartEl, traceIdx); + return; + } + if (e.detail === 1) { + const prev = singleClickTimers.get(btn); + if (prev) clearTimeout(prev); + singleClickTimers.set(btn, setTimeout(() => { + singleClickTimers.delete(btn); + const count = (chartEl.data && chartEl.data.length) || 0; + const vis = ensureVisibility(chartEl.id, count); + vis[traceIdx] = !vis[traceIdx]; + applyVisibility(chartEl); + }, 280)); + } + }); + if (search) search.addEventListener('input', applySearch); + if (masterSelect) masterSelect.addEventListener('change', redrawPlots); + applySearch(); + redrawPlots(); + })(); + |] + makePlotlyConfig :: Prim.MetricLabel -> [Text] -> @@ -69,39 +308,71 @@ makePlotlyConfig metricName labels dataSets = "type" .= ("scatter" :: Text), "mode" .= ("lines+markers" :: Text), "name" .= factorsSmall factors, - "line" .= object ["color" .= color] + "line" .= object ["color" .= color, "width" .= (2 :: Int)], + "marker" .= object ["size" .= (7 :: Int), "color" .= color] ] - | ((factors, series), color) <- zip dataSets $ cycle colors + | ((factors, series), color) <- zip dataSets $ cycle plotColors ] layout = object - [ "title" + [ "title" .= object - [ "text" .= coerce @_ @Text metricName, + [ "text" .= metricText metricName, "font" .= object ["family" .= ("monospace" :: Text), "size" .= (16 :: Int)] ], "xaxis" .= object [ "title" .= ("" :: Text), - "tickfont" .= object ["family" .= ("monospace" :: Text)] + "tickangle" .= (-30 :: Int), + "automargin" .= True, + "tickfont" .= object ["family" .= ("monospace" :: Text), "color" .= ("#111111" :: Text)] ], "yaxis" .= object - [ "title" .= coerce @_ @Text metricName, + [ "title" .= metricText metricName, "rangemode" .= ("tozero" :: Text), + "automargin" .= True, "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)] + "showlegend" .= False, + "margin" .= object ["t" .= (40 :: Int), "b" .= (56 :: Int), "l" .= (64 :: Int), "r" .= (40 :: Int)] ] - colors :: [Text] = - T.words "#4394E5 #87BB62 #876FD4 #F5921B" + +plotColors :: [Text] +plotColors = T.words "#4394E5 #87BB62 #876FD4 #F5921B #1f77b4 #ff7f0e #2ca02c #d62728" + +factorLegend_ :: Text -> [(Text, Text)] -> Html () +factorLegend_ chartId entries = + div_ [class_ "factor-lines"] do + Foldable.for_ (zip [0 :: Int ..] entries) \(idx, (color, name)) -> + div_ [class_ "factor-line"] do + button_ + [ type_ "button", + class_ "factor-toggle", + title_ "Click to show or hide this line. Double-click to show only this line.", + makeAttributes "data-chart-id" chartId, + makeAttributes "data-trace-idx" (T.pack (show idx)) + ] + do + span_ [class_ "factor-swatch", style_ ("background-color: " <> color)] (pure ()) + span_ (toHtml name) factorSmall :: Prim.GeneralFactor -> Text factorSmall factor = T.concat [T.strip factor.name, "=", T.strip factor.value] factorsSmall :: Set Prim.GeneralFactor -> Text factorsSmall = T.intercalate "," . map factorSmall . Set.toList + +subjectText :: Prim.SubjectName -> Text +subjectText (Prim.SubjectName t) = t + +metricText :: Prim.MetricLabel -> Text +metricText (Prim.MetricLabel t) = t + +shortCommitLabel :: DB.Commit -> Text +shortCommitLabel commit = + T.take 8 $ + case commit.commitHash of + Prim.Hash h -> h diff --git a/src/Perf/Web/Routes.hs b/src/Perf/Web/Routes.hs index f4fe809..86fc9b3 100644 --- a/src/Perf/Web/Routes.hs +++ b/src/Perf/Web/Routes.hs @@ -11,7 +11,6 @@ import Data.Maybe import Data.Set (Set) import Data.Text (Text) import Data.Text qualified as T -import Data.Traversable import Database.Persist import Lucid.Base import Perf.DB.Import @@ -19,7 +18,7 @@ import Perf.DB.Materialize import Perf.Types.DB qualified as DB import Perf.Types.External qualified as EX import Perf.Types.Prim qualified as Prim -import Perf.Types.Web +import Perf.Types.Web import Perf.Web.Db import Perf.Web.Foundation import Perf.Web.Layout @@ -54,24 +53,25 @@ getBranchR name = do mbranch <- db $ selectFirst [DB.BranchName ==. name] [] case mbranch of Nothing -> notFound - Just (Entity branchId branch) -> do + Just (Entity _branchId branch) -> do mmaxGraph <- fmap (>>= (RIO.readMaybe @Int . T.unpack)) $ lookupGetParam "limit" let maxGraph :: Int = fromMaybe 28 $ mmaxGraph - mappings <- - db $ - selectList - [DB.MapBranchCommitBranchId ==. branchId] - [Desc DB.MapBranchCommitId, LimitTo maxGraph] - commits <- fmap catMaybes $ RIO.for mappings \mapping -> - db $ selectFirst [DB.CommitId ==. mapping.entityVal.mapBranchCommitCommitId] [] - mbenchmarks <- db $ for (NonEmpty.nonEmpty $ reverse commits) materializeCommits + isMaster = name == "master" + let masterLimit = if isMaster then maxMasterCommits else maxMasterCommitsOnBranch + mplotData <- db $ loadBranchPlotData name maxGraph masterLimit lucid do defaultLayout_ branch.branchName do - for_ mbenchmarks $ generalizeHtmlT . generatePlots + for_ mplotData \plotData -> + generalizeHtmlT $ + generateCommitPlotsWith + (MasterComparisonEnabled plotData.masterCommits) + plotData.branchCommits + plotData.benchmarks h1_ "Commits" table_ do - let prevCommits = map Just (drop 1 commits) <> repeat Nothing - for_ (zip commits prevCommits) \(Entity _ commit, mprev) -> do + let commitsNewestFirst = maybe [] (reverse . (.tableCommitEntities)) mplotData + prevCommits = map Just (drop 1 commitsNewestFirst) <> repeat Nothing + for_ (zip commitsNewestFirst prevCommits) \(Entity _ commit, mprev) -> do let mprevious = fmap (.entityVal) mprev url <- asks (.url) tr_ do @@ -94,14 +94,9 @@ getBranchR name = do $ "compare previous" p_ $ small_ do "(limited to most recent " - toHtml $ show maxGraph + toHtml $ show $ if isMaster then maxMasterCommits else maxGraph " commits)" -generatePlots :: - BenchmarkSeries DB.Commit DB.Metric -> - Html () -generatePlots = generateCommitPlots - getCommitR :: Prim.Hash -> Handler (Html ()) getCommitR hash = do mcommit <- db $ selectFirst [DB.CommitHash ==. hash] []