module BuildBox.FileFormat.BuildResults
( BuildResults(..)
, mergeResults
, acceptResult
, advanceResults)
where
import BuildBox.Time
import BuildBox.Benchmark
import BuildBox.Command.Environment
import BuildBox.Pretty
import BuildBox.Aspect
import Data.List
import Data.Function
data BuildResults
= BuildResults
{ buildResultTime :: UTCTime
, buildResultEnvironment :: Environment
, buildResultBench :: [BenchResult Single] }
deriving (Show, Read)
instance Pretty BuildResults where
ppr results
= hang (ppr "BuildResults") 2 $ vcat
[ ppr "time: " <> (ppr $ buildResultTime results)
, ppr $ buildResultEnvironment results
, ppr ""
, vcat $ punctuate (ppr "\n")
$ map ppr
$ buildResultBench results ]
mergeResults :: [BuildResults] -> BuildResults
mergeResults results
= let
benchResults = concatMap buildResultBench results
benchNames
= sort $ nub
$ map benchResultName
$ concatMap buildResultBench results
Just newBenchResults
= sequence
$ [ find (\br -> benchResultName br == name) benchResults
| name <- benchNames]
(lastResults : _) = reverse results
in BuildResults
{ buildResultTime = buildResultTime lastResults
, buildResultEnvironment = buildResultEnvironment lastResults
, buildResultBench = newBenchResults }
acceptResult :: String -> BuildResults -> BuildResults -> Maybe BuildResults
acceptResult nameAccept baseline recent
| Just resultAccept
<- find (\br -> benchResultName br == nameAccept)
$ buildResultBench recent
= let resultsBaseline
= filter (\br -> benchResultName br /= nameAccept)
$ buildResultBench baseline
in Just $ BuildResults
{ buildResultTime = buildResultTime recent
, buildResultEnvironment = buildResultEnvironment recent
, buildResultBench = sortBy (compare `on` benchResultName)
$ resultAccept : resultsBaseline }
| otherwise
= Nothing
advanceResults :: Double -> BuildResults -> BuildResults -> BuildResults
advanceResults swing baseline recent
= let comparisons = compareManyBenchResults
(map statBenchResult $ buildResultBench baseline)
(map statBenchResult $ buildResultBench recent)
results = advanceBenchResults swing
comparisons
(buildResultBench baseline)
(buildResultBench recent)
in BuildResults
{ buildResultTime = buildResultTime recent
, buildResultEnvironment = buildResultEnvironment recent
, buildResultBench = results }