{-# LANGUAGE OverloadedStrings #-}

-- | Reporting on performance, potentially checking versus a canned results.
module Perf.Report
  ( Name,
    Header (..),
    parseHeader,
    CompareLevels (..),
    defaultCompareLevels,
    parseCompareLevels,
    ReportOptions (..),
    defaultReportOptions,
    parseReportOptions,
    infoReportOptions,
    report,
    reportMain,
    reportMainWith,
    writeResult,
    readResult,
    CompareResult (..),
    compareNote,
    reportOrg2D,
    Golden (..),
    defaultGolden,
    parseGolden,
    replaceDefaultFilePath,
  )
where

import Control.Exception
import Control.Monad
import Data.Bool
import Data.Foldable
import Data.FormatN hiding (format)
import Data.List (intercalate)
import Data.List qualified as List
import Data.Map.Merge.Strict
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import GHC.Generics
import Options.Applicative
import Perf.Measure
import Perf.Stats
import Perf.Types
import System.Exit
import Text.Printf hiding (parseFormat)
import Text.Read

-- | Benchmark name
type Name = String

-- | Whether to include header information.
data Header = Header | NoHeader deriving (Header -> Header -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Header -> Header -> Bool
$c/= :: Header -> Header -> Bool
== :: Header -> Header -> Bool
$c== :: Header -> Header -> Bool
Eq, Int -> Header -> ShowS
[Header] -> ShowS
Header -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Header] -> ShowS
$cshowList :: [Header] -> ShowS
show :: Header -> FilePath
$cshow :: Header -> FilePath
showsPrec :: Int -> Header -> ShowS
$cshowsPrec :: Int -> Header -> ShowS
Show, forall x. Rep Header x -> Header
forall x. Header -> Rep Header x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Header x -> Header
$cfrom :: forall x. Header -> Rep Header x
Generic)

-- | Command-line parser for 'Header'
parseHeader :: Parser Header
parseHeader :: Parser Header
parseHeader =
  forall a. a -> Mod FlagFields a -> Parser a
flag' Header
Header (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"header" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"include headers")
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Mod FlagFields a -> Parser a
flag' Header
NoHeader (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"noheader" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"dont include headers")
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Header
Header

-- | Options for production of a performance report.
data ReportOptions = ReportOptions
  { -- | Number of times to run a benchmark.
    ReportOptions -> Int
reportN :: Int,
    ReportOptions -> StatDType
reportStatDType :: StatDType,
    ReportOptions -> MeasureType
reportMeasureType :: MeasureType,
    ReportOptions -> Golden
reportGolden :: Golden,
    ReportOptions -> Header
reportHeader :: Header,
    ReportOptions -> CompareLevels
reportCompare :: CompareLevels
  }
  deriving (ReportOptions -> ReportOptions -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReportOptions -> ReportOptions -> Bool
$c/= :: ReportOptions -> ReportOptions -> Bool
== :: ReportOptions -> ReportOptions -> Bool
$c== :: ReportOptions -> ReportOptions -> Bool
Eq, Int -> ReportOptions -> ShowS
[ReportOptions] -> ShowS
ReportOptions -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ReportOptions] -> ShowS
$cshowList :: [ReportOptions] -> ShowS
show :: ReportOptions -> FilePath
$cshow :: ReportOptions -> FilePath
showsPrec :: Int -> ReportOptions -> ShowS
$cshowsPrec :: Int -> ReportOptions -> ShowS
Show, forall x. Rep ReportOptions x -> ReportOptions
forall x. ReportOptions -> Rep ReportOptions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ReportOptions x -> ReportOptions
$cfrom :: forall x. ReportOptions -> Rep ReportOptions x
Generic)

-- | Default options
--
-- >>> defaultReportOptions
-- ReportOptions {reportN = 1000, reportStatDType = StatAverage, reportMeasureType = MeasureTime, reportGolden = Golden {golden = "other/bench.perf", check = True, record = False}, reportHeader = Header, reportCompare = CompareLevels {errorLevel = 0.2, warningLevel = 5.0e-2, improvedLevel = 5.0e-2}}
defaultReportOptions :: ReportOptions
defaultReportOptions :: ReportOptions
defaultReportOptions =
  Int
-> StatDType
-> MeasureType
-> Golden
-> Header
-> CompareLevels
-> ReportOptions
ReportOptions
    Int
1000
    StatDType
StatAverage
    MeasureType
MeasureTime
    Golden
defaultGolden
    Header
Header
    CompareLevels
defaultCompareLevels

-- | Command-line parser for 'ReportOptions'
parseReportOptions :: Parser ReportOptions
parseReportOptions :: Parser ReportOptions
parseReportOptions =
  Int
-> StatDType
-> MeasureType
-> Golden
-> Header
-> CompareLevels
-> ReportOptions
ReportOptions
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto (forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Int
1000 forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"runs" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'n' forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"number of runs to perform")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser StatDType
parseStatD
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser MeasureType
parseMeasure
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Golden
parseGolden
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Header
parseHeader
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CompareLevels -> Parser CompareLevels
parseCompareLevels CompareLevels
defaultCompareLevels

-- | Default command-line parser.
infoReportOptions :: ParserInfo ReportOptions
infoReportOptions :: ParserInfo ReportOptions
infoReportOptions =
  forall a. Parser a -> InfoMod a -> ParserInfo a
info
    (Parser ReportOptions
parseReportOptions forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> forall a. Parser (a -> a)
helper)
    (forall a. InfoMod a
fullDesc forall a. Semigroup a => a -> a -> a
<> forall a. FilePath -> InfoMod a
progDesc FilePath
"perf benchmarking" forall a. Semigroup a => a -> a -> a
<> forall a. FilePath -> InfoMod a
header FilePath
"reporting options")

-- | Run and report a benchmark to the console. For example,
--
-- @reportMain "foo" (fap "sum" sum [1..1000])@ would:
--
-- - run a benchmark for summing the numbers 1 to a thousand.
--
-- - look for saved performance data in other/foo-1000-MeasureTime-StatAverage.perf
--
-- - report on performance in isolation or versus the canned data file if it exists.
--
-- - exit with failure if the performace had degraded.
reportMain :: Name -> PerfT IO [[Double]] a -> IO ()
reportMain :: forall a. FilePath -> PerfT IO [[Double]] a -> IO ()
reportMain FilePath
name PerfT IO [[Double]] a
t = do
  ReportOptions
o <- forall a. ParserInfo a -> IO a
execParser ParserInfo ReportOptions
infoReportOptions
  forall a.
ReportOptions -> FilePath -> PerfT IO [[Double]] a -> IO ()
reportMainWith ReportOptions
o FilePath
name PerfT IO [[Double]] a
t

-- | Run and report a benchmark to the console with the supplied options.
reportMainWith :: ReportOptions -> Name -> PerfT IO [[Double]] a -> IO ()
reportMainWith :: forall a.
ReportOptions -> FilePath -> PerfT IO [[Double]] a -> IO ()
reportMainWith ReportOptions
o FilePath
name PerfT IO [[Double]] a
t = do
  let !n :: Int
n = ReportOptions -> Int
reportN ReportOptions
o
  let s :: StatDType
s = ReportOptions -> StatDType
reportStatDType ReportOptions
o
  let mt :: MeasureType
mt = ReportOptions -> MeasureType
reportMeasureType ReportOptions
o
  let o' :: ReportOptions
o' = FilePath -> ReportOptions -> ReportOptions
replaceDefaultFilePath (forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"-" [FilePath
name, forall a. Show a => a -> FilePath
show Int
n, forall a. Show a => a -> FilePath
show MeasureType
mt, forall a. Show a => a -> FilePath
show StatDType
s]) ReportOptions
o
  Map Text [[Double]]
m <- forall (m :: * -> *) t a.
Monad m =>
Measure m t -> PerfT m t a -> m (Map Text t)
execPerfT (MeasureType -> Int -> Measure IO [[Double]]
measureDs MeasureType
mt Int
n) PerfT IO [[Double]] a
t
  ReportOptions -> Map [Text] [Double] -> IO ()
report ReportOptions
o' (forall a.
Ord a =>
StatDType -> Map a [[Double]] -> Map [a] [Double]
statify StatDType
s Map Text [[Double]]
m)

-- | Levels of geometric difference in compared performance that triggers reporting.
data CompareLevels = CompareLevels {CompareLevels -> Double
errorLevel :: Double, CompareLevels -> Double
warningLevel :: Double, CompareLevels -> Double
improvedLevel :: Double} deriving (CompareLevels -> CompareLevels -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CompareLevels -> CompareLevels -> Bool
$c/= :: CompareLevels -> CompareLevels -> Bool
== :: CompareLevels -> CompareLevels -> Bool
$c== :: CompareLevels -> CompareLevels -> Bool
Eq, Int -> CompareLevels -> ShowS
[CompareLevels] -> ShowS
CompareLevels -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [CompareLevels] -> ShowS
$cshowList :: [CompareLevels] -> ShowS
show :: CompareLevels -> FilePath
$cshow :: CompareLevels -> FilePath
showsPrec :: Int -> CompareLevels -> ShowS
$cshowsPrec :: Int -> CompareLevels -> ShowS
Show)

-- |
-- >>> defaultCompareLevels
-- CompareLevels {errorLevel = 0.2, warningLevel = 5.0e-2, improvedLevel = 5.0e-2}
defaultCompareLevels :: CompareLevels
defaultCompareLevels :: CompareLevels
defaultCompareLevels = Double -> Double -> Double -> CompareLevels
CompareLevels Double
0.2 Double
0.05 Double
0.05

-- | Command-line parser for 'CompareLevels'
parseCompareLevels :: CompareLevels -> Parser CompareLevels
parseCompareLevels :: CompareLevels -> Parser CompareLevels
parseCompareLevels CompareLevels
c =
  Double -> Double -> Double -> CompareLevels
CompareLevels
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto (forall (f :: * -> *) a. HasValue f => a -> Mod f a
value (CompareLevels -> Double
errorLevel CompareLevels
c) forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"error" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"error level")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto (forall (f :: * -> *) a. HasValue f => a -> Mod f a
value (CompareLevels -> Double
warningLevel CompareLevels
c) forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"warning" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"warning level")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto (forall (f :: * -> *) a. HasValue f => a -> Mod f a
value (CompareLevels -> Double
improvedLevel CompareLevels
c) forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"improved" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"improved level")

-- | Write results to file
writeResult :: FilePath -> Map.Map [Text] Double -> IO ()
writeResult :: FilePath -> Map [Text] Double -> IO ()
writeResult FilePath
f Map [Text] Double
m = FilePath -> FilePath -> IO ()
writeFile FilePath
f (forall a. Show a => a -> FilePath
show Map [Text] Double
m)

-- | Read results from a file.
readResult :: FilePath -> IO (Either String (Map.Map [Text] Double))
readResult :: FilePath -> IO (Either FilePath (Map [Text] Double))
readResult FilePath
f = do
  Either SomeException FilePath
a :: Either SomeException String <- forall e a. Exception e => IO a -> IO (Either e a)
try (FilePath -> IO FilePath
readFile FilePath
f)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
show) forall a. Read a => FilePath -> Either FilePath a
readEither Either SomeException FilePath
a

-- | Comparison data between two results.
data CompareResult = CompareResult {CompareResult -> Maybe Double
oldResult :: Maybe Double, CompareResult -> Maybe Double
newResult :: Maybe Double, CompareResult -> Text
noteResult :: Text} deriving (Int -> CompareResult -> ShowS
[CompareResult] -> ShowS
CompareResult -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [CompareResult] -> ShowS
$cshowList :: [CompareResult] -> ShowS
show :: CompareResult -> FilePath
$cshow :: CompareResult -> FilePath
showsPrec :: Int -> CompareResult -> ShowS
$cshowsPrec :: Int -> CompareResult -> ShowS
Show, CompareResult -> CompareResult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CompareResult -> CompareResult -> Bool
$c/= :: CompareResult -> CompareResult -> Bool
== :: CompareResult -> CompareResult -> Bool
$c== :: CompareResult -> CompareResult -> Bool
Eq)

hasDegraded :: Map.Map a CompareResult -> Bool
hasDegraded :: forall a. Map a CompareResult -> Bool
hasDegraded Map a CompareResult
m = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall a. Eq a => a -> a -> Bool
== Text
"degraded") forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompareResult -> Text
noteResult) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd (forall k a. Map k a -> [(k, a)]
Map.toList Map a CompareResult
m)

-- | Compare two results and produce some notes given level triggers.
compareNote :: (Ord a) => CompareLevels -> Map.Map a Double -> Map.Map a Double -> Map.Map a CompareResult
compareNote :: forall a.
Ord a =>
CompareLevels
-> Map a Double -> Map a Double -> Map a CompareResult
compareNote CompareLevels
cfg Map a Double
x Map a Double
y =
  forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
merge
    (forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
mapMissing (\a
_ Double
x' -> Maybe Double -> Maybe Double -> Text -> CompareResult
CompareResult forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Double
x') Text
"new result"))
    (forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
mapMissing (\a
_ Double
x' -> Maybe Double -> Maybe Double -> Text -> CompareResult
CompareResult (forall a. a -> Maybe a
Just Double
x') forall a. Maybe a
Nothing Text
"old result not found"))
    ( forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
zipWithMatched
        ( \a
_ Double
x' Double
y' ->
            Maybe Double -> Maybe Double -> Text -> CompareResult
CompareResult (forall a. a -> Maybe a
Just Double
x') (forall a. a -> Maybe a
Just Double
y') (forall {a}. IsString a => Double -> Double -> a
note' Double
x' Double
y')
        )
    )
    Map a Double
x
    Map a Double
y
  where
    note' :: Double -> Double -> a
note' Double
x' Double
y'
      | Double
y' forall a. Fractional a => a -> a -> a
/ Double
x' forall a. Ord a => a -> a -> Bool
> Double
1 forall a. Num a => a -> a -> a
+ CompareLevels -> Double
errorLevel CompareLevels
cfg = a
"degraded"
      | Double
y' forall a. Fractional a => a -> a -> a
/ Double
x' forall a. Ord a => a -> a -> Bool
> Double
1 forall a. Num a => a -> a -> a
+ CompareLevels -> Double
warningLevel CompareLevels
cfg = a
"slightly-degraded"
      | Double
y' forall a. Fractional a => a -> a -> a
/ Double
x' forall a. Ord a => a -> a -> Bool
< (Double
1 forall a. Num a => a -> a -> a
- CompareLevels -> Double
improvedLevel CompareLevels
cfg) = a
"improvement"
      | Bool
otherwise = a
""

-- | Console-style header information.
formatHeader :: Map.Map [Text] a -> [Text] -> [Text]
formatHeader :: forall a. Map [Text] a -> [Text] -> [Text]
formatHeader Map [Text] a
m [Text]
ts =
  [forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. PrintfType r => FilePath -> r
printf FilePath
"%-16s" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((Text
"label" <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> FilePath
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
1 .. Int
labelCols]) forall a. Semigroup a => a -> a -> a
<> [Text]
ts), forall a. Monoid a => a
mempty]
  where
    labelCols :: Int
labelCols = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [k]
Map.keys Map [Text] a
m

-- | Format a comparison.
formatCompare :: Header -> Map.Map [Text] CompareResult -> [Text]
formatCompare :: Header -> Map [Text] CompareResult -> [Text]
formatCompare Header
h Map [Text] CompareResult
m =
  forall a. a -> a -> Bool -> a
bool [] (forall a. Map [Text] a -> [Text] -> [Text]
formatHeader Map [Text] CompareResult
m [Text
"old result", Text
"new result", Text
"change"]) (Header
h forall a. Eq a => a -> a -> Bool
== Header
Header)
    forall a. Semigroup a => a -> a -> a
<> forall k a. Map k a -> [a]
Map.elems (forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\[Text]
k CompareResult
a -> FilePath -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => FilePath -> r
printf FilePath
"%-16s" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Text]
k forall a. Semigroup a => a -> a -> a
<> CompareResult -> [Text]
compareReport CompareResult
a)) Map [Text] CompareResult
m)
  where
    compareReport :: CompareResult -> [Text]
compareReport (CompareResult Maybe Double
x Maybe Double
y Text
n) =
      [ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (Maybe Int -> Double -> Text
expt (forall a. a -> Maybe a
Just Int
3)) Maybe Double
x,
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (Maybe Int -> Double -> Text
expt (forall a. a -> Maybe a
Just Int
3)) Maybe Double
y,
        Text
n
      ]

-- | Format a result as lines of text.
formatText :: Header -> Map.Map [Text] Text -> [Text]
formatText :: Header -> Map [Text] Text -> [Text]
formatText Header
h Map [Text] Text
m =
  forall a. a -> a -> Bool -> a
bool [] (forall a. Map [Text] a -> [Text] -> [Text]
formatHeader Map [Text] Text
m [Text
"results"]) (Header
h forall a. Eq a => a -> a -> Bool
== Header
Header)
    forall a. Semigroup a => a -> a -> a
<> forall k a. Map k a -> [a]
Map.elems (forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\[Text]
k Text
a -> FilePath -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => FilePath -> r
printf FilePath
"%-16s" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Text]
k forall a. Semigroup a => a -> a -> a
<> [Text
a])) Map [Text] Text
m)

-- | Format a result as a table.
reportOrg2D :: Map.Map [Text] Text -> IO ()
reportOrg2D :: Map [Text] Text -> IO ()
reportOrg2D Map [Text] Text
m = do
  let rs :: [Text]
rs = forall a. Eq a => [a] -> [a]
List.nub ((forall a. [a] -> Int -> a
List.!! Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
Map.toList Map [Text] Text
m)
  let cs :: [Text]
cs = forall a. Eq a => [a] -> [a]
List.nub ((forall a. [a] -> Int -> a
List.!! Int
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
Map.toList Map [Text] Text
m)
  Text -> IO ()
Text.putStrLn (Text
"||" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"|" [Text]
rs forall a. Semigroup a => a -> a -> a
<> Text
"|")
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    ( \Text
c ->
        Text -> IO ()
Text.putStrLn
          ( Text
"|"
              forall a. Semigroup a => a -> a -> a
<> Text
c
              forall a. Semigroup a => a -> a -> a
<> Text
"|"
              forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"|" ((\Text
r -> Map [Text] Text
m forall k a. Ord k => Map k a -> k -> a
Map.! [Text
c, Text
r]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
rs)
              forall a. Semigroup a => a -> a -> a
<> Text
"|"
          )
    )
    [Text]
cs

reportToConsole :: [Text] -> IO ()
reportToConsole :: [Text] -> IO ()
reportToConsole [Text]
xs = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Text -> IO ()
Text.putStrLn [Text]
xs

-- | Golden file options.
data Golden = Golden {Golden -> FilePath
golden :: FilePath, Golden -> Bool
check :: Bool, Golden -> Bool
record :: Bool} deriving (forall x. Rep Golden x -> Golden
forall x. Golden -> Rep Golden x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Golden x -> Golden
$cfrom :: forall x. Golden -> Rep Golden x
Generic, Golden -> Golden -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Golden -> Golden -> Bool
$c/= :: Golden -> Golden -> Bool
== :: Golden -> Golden -> Bool
$c== :: Golden -> Golden -> Bool
Eq, Int -> Golden -> ShowS
[Golden] -> ShowS
Golden -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Golden] -> ShowS
$cshowList :: [Golden] -> ShowS
show :: Golden -> FilePath
$cshow :: Golden -> FilePath
showsPrec :: Int -> Golden -> ShowS
$cshowsPrec :: Int -> Golden -> ShowS
Show)

-- | Default filepath is "other/bench.perf"
defaultGolden :: Golden
defaultGolden :: Golden
defaultGolden = FilePath -> Bool -> Bool -> Golden
Golden FilePath
"other/bench.perf" Bool
True Bool
False

-- | Replace the golden file name stem if it's the default.
replaceGoldenDefault :: FilePath -> Golden -> Golden
replaceGoldenDefault :: FilePath -> Golden -> Golden
replaceGoldenDefault FilePath
s Golden
g = forall a. a -> a -> Bool -> a
bool Golden
g Golden
g {golden :: FilePath
golden = FilePath
s} (Golden -> FilePath
golden Golden
g forall a. Eq a => a -> a -> Bool
== Golden -> FilePath
golden Golden
defaultGolden)

defaultGoldenPath :: FilePath -> FilePath
defaultGoldenPath :: ShowS
defaultGoldenPath FilePath
fp = FilePath
"other/" forall a. Semigroup a => a -> a -> a
<> FilePath
fp forall a. Semigroup a => a -> a -> a
<> FilePath
".perf"

-- | Replace the Golden file path with the suggested stem, but only if the user did not specify a specific file path at the command line.
replaceDefaultFilePath :: FilePath -> ReportOptions -> ReportOptions
replaceDefaultFilePath :: FilePath -> ReportOptions -> ReportOptions
replaceDefaultFilePath FilePath
fp ReportOptions
o =
  ReportOptions
o {reportGolden :: Golden
reportGolden = FilePath -> Golden -> Golden
replaceGoldenDefault (ShowS
defaultGoldenPath FilePath
fp) (ReportOptions -> Golden
reportGolden ReportOptions
o)}

-- | Parse command-line golden file options.
parseGolden :: Parser Golden
parseGolden :: Parser Golden
parseGolden =
  FilePath -> Bool -> Bool -> Golden
Golden
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall s. IsString s => ReadM s
str (forall (f :: * -> *) a. HasValue f => a -> Mod f a
Options.Applicative.value (Golden -> FilePath
golden Golden
defaultGolden) forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"golden" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'g' forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"golden file name")
    -- True is the default for 'check'.
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> a -> Mod FlagFields a -> Parser a
flag Bool
True Bool
False (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"nocheck" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"do not check versus the golden file")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch (forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"record" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'r' forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"record the result to the golden file")

reportConsoleNoCompare :: Header -> Map.Map [Text] Double -> IO ()
reportConsoleNoCompare :: Header -> Map [Text] Double -> IO ()
reportConsoleNoCompare Header
h Map [Text] Double
m =
  [Text] -> IO ()
reportToConsole (Header -> Map [Text] Text -> [Text]
formatText Header
h (Maybe Int -> Double -> Text
expt (forall a. a -> Maybe a
Just Int
3) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map [Text] Double
m))

reportConsoleCompare :: Header -> Map.Map [Text] CompareResult -> IO ()
reportConsoleCompare :: Header -> Map [Text] CompareResult -> IO ()
reportConsoleCompare Header
h Map [Text] CompareResult
m =
  [Text] -> IO ()
reportToConsole (Header -> Map [Text] CompareResult -> [Text]
formatCompare Header
h Map [Text] CompareResult
m)

-- | Report results
--
-- If a goldenFile is checked, and performance has degraded, the function will exit with 'ExitFailure' so that 'cabal bench' and other types of processes can signal performance issues.
report :: ReportOptions -> Map.Map [Text] [Double] -> IO ()
report :: ReportOptions -> Map [Text] [Double] -> IO ()
report ReportOptions
o Map [Text] [Double]
m = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Golden -> Bool
record (ReportOptions -> Golden
reportGolden ReportOptions
o))
    (FilePath -> Map [Text] Double -> IO ()
writeResult (Golden -> FilePath
golden (ReportOptions -> Golden
reportGolden ReportOptions
o)) Map [Text] Double
m')
  case Golden -> Bool
check (ReportOptions -> Golden
reportGolden ReportOptions
o) of
    Bool
False -> Header -> Map [Text] Double -> IO ()
reportConsoleNoCompare (ReportOptions -> Header
reportHeader ReportOptions
o) Map [Text] Double
m'
    Bool
True -> do
      Either FilePath (Map [Text] Double)
mOrig <- FilePath -> IO (Either FilePath (Map [Text] Double))
readResult (Golden -> FilePath
golden (ReportOptions -> Golden
reportGolden ReportOptions
o))
      case Either FilePath (Map [Text] Double)
mOrig of
        Left FilePath
_ -> do
          Header -> Map [Text] Double -> IO ()
reportConsoleNoCompare (ReportOptions -> Header
reportHeader ReportOptions
o) Map [Text] Double
m'
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
            (Golden -> Bool
record (ReportOptions -> Golden
reportGolden ReportOptions
o))
            (FilePath -> IO ()
putStrLn FilePath
"No golden file found. To create one, run with '-r'")
        Right Map [Text] Double
orig -> do
          let n :: Map [Text] CompareResult
n = forall a.
Ord a =>
CompareLevels
-> Map a Double -> Map a Double -> Map a CompareResult
compareNote (ReportOptions -> CompareLevels
reportCompare ReportOptions
o) Map [Text] Double
orig Map [Text] Double
m'
          ()
_ <- Header -> Map [Text] CompareResult -> IO ()
reportConsoleCompare (ReportOptions -> Header
reportHeader ReportOptions
o) Map [Text] CompareResult
n
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Map a CompareResult -> Bool
hasDegraded Map [Text] CompareResult
n) (forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1)
  where
    m' :: Map [Text] Double
m' = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ (\([Text]
ks, [Double]
xss) -> forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Double
x Text
l -> ([Text]
ks forall a. Semigroup a => a -> a -> a
<> [Text
l], Double
x)) [Double]
xss (MeasureType -> [Text]
measureLabels (ReportOptions -> MeasureType
reportMeasureType ReportOptions
o))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
Map.toList Map [Text] [Double]
m