{-# LANGUAGE CPP #-}
{-# 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.Time (defaultClock)
import Perf.Types
import System.Clock
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
(Header -> Header -> Bool)
-> (Header -> Header -> Bool) -> Eq Header
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Header -> Header -> Bool
== :: Header -> Header -> Bool
$c/= :: Header -> Header -> Bool
/= :: Header -> Header -> Bool
Eq, Int -> Header -> ShowS
[Header] -> ShowS
Header -> FilePath
(Int -> Header -> ShowS)
-> (Header -> FilePath) -> ([Header] -> ShowS) -> Show Header
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Header -> ShowS
showsPrec :: Int -> Header -> ShowS
$cshow :: Header -> FilePath
show :: Header -> FilePath
$cshowList :: [Header] -> ShowS
showList :: [Header] -> ShowS
Show, (forall x. Header -> Rep Header x)
-> (forall x. Rep Header x -> Header) -> Generic Header
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
$cfrom :: forall x. Header -> Rep Header x
from :: forall x. Header -> Rep Header x
$cto :: forall x. Rep Header x -> Header
to :: forall x. Rep Header x -> Header
Generic)

-- | Command-line parser for 'Header'
parseHeader :: Parser Header
parseHeader :: Parser Header
parseHeader =
  Header -> Mod FlagFields Header -> Parser Header
forall a. a -> Mod FlagFields a -> Parser a
flag' Header
Header (FilePath -> Mod FlagFields Header
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"header" Mod FlagFields Header
-> Mod FlagFields Header -> Mod FlagFields Header
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Header
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"include headers")
    Parser Header -> Parser Header -> Parser Header
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Header -> Mod FlagFields Header -> Parser Header
forall a. a -> Mod FlagFields a -> Parser a
flag' Header
NoHeader (FilePath -> Mod FlagFields Header
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"noheader" Mod FlagFields Header
-> Mod FlagFields Header -> Mod FlagFields Header
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Header
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"dont include headers")
    Parser Header -> Parser Header -> Parser Header
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Header -> Parser Header
forall a. a -> Parser 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 -> Clock
reportClock :: Clock,
    ReportOptions -> StatDType
reportStatDType :: StatDType,
    ReportOptions -> MeasureType
reportMeasureType :: MeasureType,
    ReportOptions -> Golden
reportGolden :: Golden,
    ReportOptions -> Header
reportHeader :: Header,
    ReportOptions -> CompareLevels
reportCompare :: CompareLevels
  }
  deriving (ReportOptions -> ReportOptions -> Bool
(ReportOptions -> ReportOptions -> Bool)
-> (ReportOptions -> ReportOptions -> Bool) -> Eq ReportOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReportOptions -> ReportOptions -> Bool
== :: ReportOptions -> ReportOptions -> Bool
$c/= :: ReportOptions -> ReportOptions -> Bool
/= :: ReportOptions -> ReportOptions -> Bool
Eq, Int -> ReportOptions -> ShowS
[ReportOptions] -> ShowS
ReportOptions -> FilePath
(Int -> ReportOptions -> ShowS)
-> (ReportOptions -> FilePath)
-> ([ReportOptions] -> ShowS)
-> Show ReportOptions
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReportOptions -> ShowS
showsPrec :: Int -> ReportOptions -> ShowS
$cshow :: ReportOptions -> FilePath
show :: ReportOptions -> FilePath
$cshowList :: [ReportOptions] -> ShowS
showList :: [ReportOptions] -> ShowS
Show, (forall x. ReportOptions -> Rep ReportOptions x)
-> (forall x. Rep ReportOptions x -> ReportOptions)
-> Generic ReportOptions
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
$cfrom :: forall x. ReportOptions -> Rep ReportOptions x
from :: forall x. ReportOptions -> Rep ReportOptions x
$cto :: forall x. Rep ReportOptions x -> ReportOptions
to :: forall x. Rep ReportOptions x -> ReportOptions
Generic)

-- | Default options
--
-- >>> defaultReportOptions
-- ReportOptions {reportN = 1000, reportClock = MonotonicRaw, 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
-> Clock
-> StatDType
-> MeasureType
-> Golden
-> Header
-> CompareLevels
-> ReportOptions
ReportOptions
    Int
1000
    Clock
defaultClock
    StatDType
StatAverage
    MeasureType
MeasureTime
    Golden
defaultGolden
    Header
Header
    CompareLevels
defaultCompareLevels

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

-- | Parse command-line 'Clock' options.
parseClock :: Parser Clock
parseClock :: Parser Clock
parseClock =
  Clock -> Mod FlagFields Clock -> Parser Clock
forall a. a -> Mod FlagFields a -> Parser a
flag' Clock
Monotonic (FilePath -> Mod FlagFields Clock
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"Monotonic")
    Parser Clock -> Parser Clock -> Parser Clock
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Clock -> Mod FlagFields Clock -> Parser Clock
forall a. a -> Mod FlagFields a -> Parser a
flag' Clock
Realtime (FilePath -> Mod FlagFields Clock
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"Realtime")
    Parser Clock -> Parser Clock -> Parser Clock
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Clock -> Mod FlagFields Clock -> Parser Clock
forall a. a -> Mod FlagFields a -> Parser a
flag' Clock
ProcessCPUTime (FilePath -> Mod FlagFields Clock
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"ProcessCPUTime")
    Parser Clock -> Parser Clock -> Parser Clock
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Clock -> Mod FlagFields Clock -> Parser Clock
forall a. a -> Mod FlagFields a -> Parser a
flag' Clock
ThreadCPUTime (FilePath -> Mod FlagFields Clock
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"ThreadCPUTime")
#ifdef mingw32_HOST_OS
    <|> pure ThreadCPUTime
#else
    Parser Clock -> Parser Clock -> Parser Clock
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Clock -> Mod FlagFields Clock -> Parser Clock
forall a. a -> Mod FlagFields a -> Parser a
flag' Clock
MonotonicRaw (FilePath -> Mod FlagFields Clock
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"MonotonicRaw")
    Parser Clock -> Parser Clock -> Parser Clock
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Clock -> Parser Clock
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Clock
MonotonicRaw
#endif

-- | Default command-line parser.
infoReportOptions :: ParserInfo ReportOptions
infoReportOptions :: ParserInfo ReportOptions
infoReportOptions =
  Parser ReportOptions
-> InfoMod ReportOptions -> ParserInfo ReportOptions
forall a. Parser a -> InfoMod a -> ParserInfo a
info
    (Parser ReportOptions
parseReportOptions Parser ReportOptions
-> Parser (ReportOptions -> ReportOptions) -> Parser ReportOptions
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (ReportOptions -> ReportOptions)
forall a. Parser (a -> a)
helper)
    (InfoMod ReportOptions
forall a. InfoMod a
fullDesc InfoMod ReportOptions
-> InfoMod ReportOptions -> InfoMod ReportOptions
forall a. Semigroup a => a -> a -> a
<> FilePath -> InfoMod ReportOptions
forall a. FilePath -> InfoMod a
progDesc FilePath
"perf benchmarking" InfoMod ReportOptions
-> InfoMod ReportOptions -> InfoMod ReportOptions
forall a. Semigroup a => a -> a -> a
<> FilePath -> InfoMod ReportOptions
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 <- ParserInfo ReportOptions -> IO ReportOptions
forall a. ParserInfo a -> IO a
execParser ParserInfo ReportOptions
infoReportOptions
  ReportOptions -> FilePath -> PerfT IO [[Double]] a -> IO ()
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 c :: Clock
c = ReportOptions -> Clock
reportClock ReportOptions
o
  let mt :: MeasureType
mt = ReportOptions -> MeasureType
reportMeasureType ReportOptions
o
  let o' :: ReportOptions
o' = FilePath -> ReportOptions -> ReportOptions
replaceDefaultFilePath (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"-" [FilePath
name, Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n, MeasureType -> FilePath
forall a. Show a => a -> FilePath
show MeasureType
mt, StatDType -> FilePath
forall a. Show a => a -> FilePath
show StatDType
s]) ReportOptions
o
  Map Text [[Double]]
m <- Measure IO [[Double]]
-> PerfT IO [[Double]] a -> IO (Map Text [[Double]])
forall (m :: * -> *) t a.
Monad m =>
Measure m t -> PerfT m t a -> m (Map Text t)
execPerfT (MeasureType -> Clock -> Int -> Measure IO [[Double]]
measureDs MeasureType
mt Clock
c Int
n) PerfT IO [[Double]] a
t
  ReportOptions -> Map [Text] [Double] -> IO ()
report ReportOptions
o' (StatDType -> Map Text [[Double]] -> Map [Text] [Double]
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
(CompareLevels -> CompareLevels -> Bool)
-> (CompareLevels -> CompareLevels -> Bool) -> Eq CompareLevels
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompareLevels -> CompareLevels -> Bool
== :: CompareLevels -> CompareLevels -> Bool
$c/= :: CompareLevels -> CompareLevels -> Bool
/= :: CompareLevels -> CompareLevels -> Bool
Eq, Int -> CompareLevels -> ShowS
[CompareLevels] -> ShowS
CompareLevels -> FilePath
(Int -> CompareLevels -> ShowS)
-> (CompareLevels -> FilePath)
-> ([CompareLevels] -> ShowS)
-> Show CompareLevels
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompareLevels -> ShowS
showsPrec :: Int -> CompareLevels -> ShowS
$cshow :: CompareLevels -> FilePath
show :: CompareLevels -> FilePath
$cshowList :: [CompareLevels] -> ShowS
showList :: [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
    (Double -> Double -> Double -> CompareLevels)
-> Parser Double -> Parser (Double -> Double -> CompareLevels)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM Double -> Mod OptionFields Double -> Parser Double
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Double
forall a. Read a => ReadM a
auto (Double -> Mod OptionFields Double
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value (CompareLevels -> Double
errorLevel CompareLevels
c) Mod OptionFields Double
-> Mod OptionFields Double -> Mod OptionFields Double
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Double
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"error" Mod OptionFields Double
-> Mod OptionFields Double -> Mod OptionFields Double
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Double
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"error level")
    Parser (Double -> Double -> CompareLevels)
-> Parser Double -> Parser (Double -> CompareLevels)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM Double -> Mod OptionFields Double -> Parser Double
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Double
forall a. Read a => ReadM a
auto (Double -> Mod OptionFields Double
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value (CompareLevels -> Double
warningLevel CompareLevels
c) Mod OptionFields Double
-> Mod OptionFields Double -> Mod OptionFields Double
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Double
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"warning" Mod OptionFields Double
-> Mod OptionFields Double -> Mod OptionFields Double
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Double
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"warning level")
    Parser (Double -> CompareLevels)
-> Parser Double -> Parser CompareLevels
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM Double -> Mod OptionFields Double -> Parser Double
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Double
forall a. Read a => ReadM a
auto (Double -> Mod OptionFields Double
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value (CompareLevels -> Double
improvedLevel CompareLevels
c) Mod OptionFields Double
-> Mod OptionFields Double -> Mod OptionFields Double
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Double
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"improved" Mod OptionFields Double
-> Mod OptionFields Double -> Mod OptionFields Double
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields Double
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 (Map [Text] Double -> FilePath
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 <- IO FilePath -> IO (Either SomeException FilePath)
forall e a. Exception e => IO a -> IO (Either e a)
try (FilePath -> IO FilePath
readFile FilePath
f)
  Either FilePath (Map [Text] Double)
-> IO (Either FilePath (Map [Text] Double))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath (Map [Text] Double)
 -> IO (Either FilePath (Map [Text] Double)))
-> Either FilePath (Map [Text] Double)
-> IO (Either FilePath (Map [Text] Double))
forall a b. (a -> b) -> a -> b
$ (SomeException -> Either FilePath (Map [Text] Double))
-> (FilePath -> Either FilePath (Map [Text] Double))
-> Either SomeException FilePath
-> Either FilePath (Map [Text] Double)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> Either FilePath (Map [Text] Double)
forall a b. a -> Either a b
Left (FilePath -> Either FilePath (Map [Text] Double))
-> (SomeException -> FilePath)
-> SomeException
-> Either FilePath (Map [Text] Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> FilePath
forall a. Show a => a -> FilePath
show) FilePath -> Either FilePath (Map [Text] Double)
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
(Int -> CompareResult -> ShowS)
-> (CompareResult -> FilePath)
-> ([CompareResult] -> ShowS)
-> Show CompareResult
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompareResult -> ShowS
showsPrec :: Int -> CompareResult -> ShowS
$cshow :: CompareResult -> FilePath
show :: CompareResult -> FilePath
$cshowList :: [CompareResult] -> ShowS
showList :: [CompareResult] -> ShowS
Show, CompareResult -> CompareResult -> Bool
(CompareResult -> CompareResult -> Bool)
-> (CompareResult -> CompareResult -> Bool) -> Eq CompareResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompareResult -> CompareResult -> Bool
== :: CompareResult -> CompareResult -> Bool
$c/= :: CompareResult -> CompareResult -> Bool
/= :: CompareResult -> CompareResult -> Bool
Eq)

hasDegraded :: Map.Map a CompareResult -> Bool
hasDegraded :: forall a. Map a CompareResult -> Bool
hasDegraded Map a CompareResult
m = ((a, CompareResult) -> Bool) -> [(a, CompareResult)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"degraded") (Text -> Bool) -> (CompareResult -> Text) -> CompareResult -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompareResult -> Text
noteResult) (CompareResult -> Bool)
-> ((a, CompareResult) -> CompareResult)
-> (a, CompareResult)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, CompareResult) -> CompareResult
forall a b. (a, b) -> b
snd) (Map a CompareResult -> [(a, CompareResult)]
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 =
  SimpleWhenMissing a Double CompareResult
-> SimpleWhenMissing a Double CompareResult
-> SimpleWhenMatched a Double Double CompareResult
-> Map a Double
-> Map a Double
-> Map a CompareResult
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
    ((a -> Double -> CompareResult)
-> SimpleWhenMissing a Double CompareResult
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 Maybe Double
forall a. Maybe a
Nothing (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
x') Text
"new result"))
    ((a -> Double -> CompareResult)
-> SimpleWhenMissing a Double CompareResult
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 (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
x') Maybe Double
forall a. Maybe a
Nothing Text
"old result not found"))
    ( (a -> Double -> Double -> CompareResult)
-> SimpleWhenMatched a Double Double CompareResult
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 (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
x') (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
y') (Double -> Double -> Text
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' Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
x' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ CompareLevels -> Double
errorLevel CompareLevels
cfg = a
"degraded"
      | Double
y' Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
x' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ CompareLevels -> Double
warningLevel CompareLevels
cfg = a
"slightly-degraded"
      | Double
y' Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
x' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< (Double
1 Double -> Double -> Double
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 =
  [[Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Text.pack (FilePath -> Text) -> (Text -> FilePath) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%-16s" (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((Text
"label" <>) (Text -> Text) -> (Int -> Text) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack (FilePath -> Text) -> (Int -> FilePath) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> Text) -> [Int] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
1 .. Int
labelCols]) [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
ts), Text
forall a. Monoid a => a
mempty]
  where
    labelCols :: Int
labelCols = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text] -> Int) -> [[Text]] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map [Text] a -> [[Text]]
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 =
  [Text] -> [Text] -> Bool -> [Text]
forall a. a -> a -> Bool -> a
bool [] (Map [Text] CompareResult -> [Text] -> [Text]
forall a. Map [Text] a -> [Text] -> [Text]
formatHeader Map [Text] CompareResult
m [Text
"old result", Text
"new result", Text
"change"]) (Header
h Header -> Header -> Bool
forall a. Eq a => a -> a -> Bool
== Header
Header)
    [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Map [Text] Text -> [Text]
forall k a. Map k a -> [a]
Map.elems (([Text] -> CompareResult -> Text)
-> Map [Text] CompareResult -> Map [Text] Text
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\[Text]
k CompareResult
a -> FilePath -> Text
Text.pack (FilePath -> Text)
-> ([FilePath] -> FilePath) -> [FilePath] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
forall a. Monoid a => [a] -> a
mconcat ([FilePath] -> Text) -> [FilePath] -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%-16s" (Text -> FilePath) -> [Text] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Text]
k [Text] -> [Text] -> [Text]
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) =
      [ Text -> (Double -> Text) -> Maybe Double -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
forall a. Monoid a => a
mempty (Maybe Int -> Double -> Text
expt (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
3)) Maybe Double
x,
        Text -> (Double -> Text) -> Maybe Double -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
forall a. Monoid a => a
mempty (Maybe Int -> Double -> Text
expt (Int -> Maybe Int
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 =
  [Text] -> [Text] -> Bool -> [Text]
forall a. a -> a -> Bool -> a
bool [] (Map [Text] Text -> [Text] -> [Text]
forall a. Map [Text] a -> [Text] -> [Text]
formatHeader Map [Text] Text
m [Text
"results"]) (Header
h Header -> Header -> Bool
forall a. Eq a => a -> a -> Bool
== Header
Header)
    [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Map [Text] Text -> [Text]
forall k a. Map k a -> [a]
Map.elems (([Text] -> Text -> Text) -> Map [Text] Text -> Map [Text] Text
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\[Text]
k Text
a -> FilePath -> Text
Text.pack (FilePath -> Text)
-> ([FilePath] -> FilePath) -> [FilePath] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
forall a. Monoid a => [a] -> a
mconcat ([FilePath] -> Text) -> [FilePath] -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%-16s" (Text -> FilePath) -> [Text] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Text]
k [Text] -> [Text] -> [Text]
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 = [Text] -> [Text]
forall a. Eq a => [a] -> [a]
List.nub (([Text] -> Int -> Text
forall a. HasCallStack => [a] -> Int -> a
List.!! Int
1) ([Text] -> Text)
-> (([Text], Text) -> [Text]) -> ([Text], Text) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text], Text) -> [Text]
forall a b. (a, b) -> a
fst (([Text], Text) -> Text) -> [([Text], Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map [Text] Text -> [([Text], Text)]
forall k a. Map k a -> [(k, a)]
Map.toList Map [Text] Text
m)
  let cs :: [Text]
cs = [Text] -> [Text]
forall a. Eq a => [a] -> [a]
List.nub (([Text] -> Int -> Text
forall a. HasCallStack => [a] -> Int -> a
List.!! Int
0) ([Text] -> Text)
-> (([Text], Text) -> [Text]) -> ([Text], Text) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text], Text) -> [Text]
forall a b. (a, b) -> a
fst (([Text], Text) -> Text) -> [([Text], Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map [Text] Text -> [([Text], Text)]
forall k a. Map k a -> [(k, a)]
Map.toList Map [Text] Text
m)
  Text -> IO ()
Text.putStrLn (Text
"||" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"|" [Text]
rs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"|")
  (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    ( \Text
c ->
        Text -> IO ()
Text.putStrLn
          ( Text
"|"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"|"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"|" ((\Text
r -> Map [Text] Text
m Map [Text] Text -> [Text] -> Text
forall k a. Ord k => Map k a -> k -> a
Map.! [Text
c, Text
r]) (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
rs)
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"|"
          )
    )
    [Text]
cs

reportToConsole :: [Text] -> IO ()
reportToConsole :: [Text] -> IO ()
reportToConsole [Text]
xs = (Text -> IO ()) -> [Text] -> IO ()
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. Golden -> Rep Golden x)
-> (forall x. Rep Golden x -> Golden) -> Generic Golden
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
$cfrom :: forall x. Golden -> Rep Golden x
from :: forall x. Golden -> Rep Golden x
$cto :: forall x. Rep Golden x -> Golden
to :: forall x. Rep Golden x -> Golden
Generic, Golden -> Golden -> Bool
(Golden -> Golden -> Bool)
-> (Golden -> Golden -> Bool) -> Eq Golden
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Golden -> Golden -> Bool
== :: Golden -> Golden -> Bool
$c/= :: Golden -> Golden -> Bool
/= :: Golden -> Golden -> Bool
Eq, Int -> Golden -> ShowS
[Golden] -> ShowS
Golden -> FilePath
(Int -> Golden -> ShowS)
-> (Golden -> FilePath) -> ([Golden] -> ShowS) -> Show Golden
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Golden -> ShowS
showsPrec :: Int -> Golden -> ShowS
$cshow :: Golden -> FilePath
show :: Golden -> FilePath
$cshowList :: [Golden] -> ShowS
showList :: [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 = Golden -> Golden -> Bool -> Golden
forall a. a -> a -> Bool -> a
bool Golden
g Golden
g {golden = s} (Golden -> FilePath
golden Golden
g FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== Golden -> FilePath
golden Golden
defaultGolden)

defaultGoldenPath :: FilePath -> FilePath
defaultGoldenPath :: ShowS
defaultGoldenPath FilePath
fp = FilePath
"other/" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
fp FilePath -> ShowS
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 = replaceGoldenDefault (defaultGoldenPath fp) (reportGolden o)}

-- | Parse command-line golden file options.
parseGolden :: Parser Golden
parseGolden :: Parser Golden
parseGolden =
  FilePath -> Bool -> Bool -> Golden
Golden
    (FilePath -> Bool -> Bool -> Golden)
-> Parser FilePath -> Parser (Bool -> Bool -> Golden)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM FilePath -> Mod OptionFields FilePath -> Parser FilePath
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM FilePath
forall s. IsString s => ReadM s
str (FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasValue f => a -> Mod f a
Options.Applicative.value (Golden -> FilePath
golden Golden
defaultGolden) Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"golden" Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields FilePath
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'g' Mod OptionFields FilePath
-> Mod OptionFields FilePath -> Mod OptionFields FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields FilePath
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"golden file name")
    -- True is the default for 'check'.
    Parser (Bool -> Bool -> Golden)
-> Parser Bool -> Parser (Bool -> Golden)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> a -> Mod FlagFields a -> Parser a
flag Bool
True Bool
False (FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"nocheck" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"do not check versus the golden file")
    Parser (Bool -> Golden) -> Parser Bool -> Parser Golden
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch (FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"record" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'r' Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Bool
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 (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
3) (Double -> Text) -> Map [Text] Double -> Map [Text] Text
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
  Bool -> IO () -> IO ()
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'
          Bool -> IO () -> IO ()
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 = CompareLevels
-> Map [Text] Double
-> Map [Text] Double
-> Map [Text] CompareResult
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
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map [Text] CompareResult -> Bool
forall a. Map a CompareResult -> Bool
hasDegraded Map [Text] CompareResult
n) (ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1)
  where
    m' :: Map [Text] Double
m' = [([Text], Double)] -> Map [Text] Double
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([([Text], Double)] -> Map [Text] Double)
-> [([Text], Double)] -> Map [Text] Double
forall a b. (a -> b) -> a -> b
$ [[([Text], Double)]] -> [([Text], Double)]
forall a. Monoid a => [a] -> a
mconcat ([[([Text], Double)]] -> [([Text], Double)])
-> [[([Text], Double)]] -> [([Text], Double)]
forall a b. (a -> b) -> a -> b
$ (\([Text]
ks, [Double]
xss) -> (Double -> Text -> ([Text], Double))
-> [Double] -> [Text] -> [([Text], Double)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Double
x Text
l -> ([Text]
ks [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
l], Double
x)) [Double]
xss (MeasureType -> [Text]
measureLabels (ReportOptions -> MeasureType
reportMeasureType ReportOptions
o))) (([Text], [Double]) -> [([Text], Double)])
-> [([Text], [Double])] -> [[([Text], Double)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map [Text] [Double] -> [([Text], [Double])]
forall k a. Map k a -> [(k, a)]
Map.toList Map [Text] [Double]
m