show: LANG-77 improve presentation of perfly benchmarks

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..."

package.yaml

@@ -46,6 +46,7 @@ dependencies:
 - persistent-template
 - hspec-discover
 - containers
+- neat-interpolation
 
 ghc-options:
 - -Wall

perfly.cabal

@@ -63,6 +63,7 @@ library
     , lucid2
     , monad-logger
     , mtl
+    , neat-interpolation
     , persistent
     , persistent-sqlite
     , persistent-template

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).

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) ->

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

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;}
+  |]