{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Reporting on performance, potentially checking versus a canned results.
module Perf.Report
  ( Format (..),
    parseFormat,
    Header (..),
    parseHeader,
    CompareLevels (..),
    defaultCompareLevels,
    parseCompareLevels,
    ReportConfig (..),
    defaultReportConfig,
    parseReportConfig,
    writeResult,
    readResult,
    compareNote,
    outercalate,
    reportGolden,
    reportOrg2D,
    Golden (..),
    parseGolden,
    report,
  )
where

import Box hiding (value)
import qualified Box.Csv as Csv
import Control.Monad
import qualified Data.Attoparsec.Text as A
import Data.Bool
import Data.Either (fromRight)
import Data.Foldable
import Data.FormatN hiding (format)
import qualified Data.List as List
import Data.Map.Merge.Strict
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import GHC.Generics
import Options.Applicative
import Text.Printf hiding (parseFormat)

-- | Type of format for report
data Format = OrgMode | ConsoleMode deriving (Format -> Format -> Bool
(Format -> Format -> Bool)
-> (Format -> Format -> Bool) -> Eq Format
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Format -> Format -> Bool
$c/= :: Format -> Format -> Bool
== :: Format -> Format -> Bool
$c== :: Format -> Format -> Bool
Eq, Int -> Format -> ShowS
[Format] -> ShowS
Format -> String
(Int -> Format -> ShowS)
-> (Format -> String) -> ([Format] -> ShowS) -> Show Format
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Format] -> ShowS
$cshowList :: [Format] -> ShowS
show :: Format -> String
$cshow :: Format -> String
showsPrec :: Int -> Format -> ShowS
$cshowsPrec :: Int -> Format -> ShowS
Show, (forall x. Format -> Rep Format x)
-> (forall x. Rep Format x -> Format) -> Generic Format
forall x. Rep Format x -> Format
forall x. Format -> Rep Format x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Format x -> Format
$cfrom :: forall x. Format -> Rep Format x
Generic)

-- | Command-line parser for 'Format'
parseFormat :: Format -> Parser Format
parseFormat :: Format -> Parser Format
parseFormat Format
f =
  Format -> Mod FlagFields Format -> Parser Format
forall a. a -> Mod FlagFields a -> Parser a
flag' Format
OrgMode (String -> Mod FlagFields Format
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"orgmode" Mod FlagFields Format
-> Mod FlagFields Format -> Mod FlagFields Format
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Format
forall (f :: * -> *) a. String -> Mod f a
help String
"report using orgmode table format")
    Parser Format -> Parser Format -> Parser Format
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Format -> Mod FlagFields Format -> Parser Format
forall a. a -> Mod FlagFields a -> Parser a
flag' Format
ConsoleMode (String -> Mod FlagFields Format
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"console" Mod FlagFields Format
-> Mod FlagFields Format -> Mod FlagFields Format
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Format
forall (f :: * -> *) a. String -> Mod f a
help String
"report using plain table format")
    Parser Format -> Parser Format -> Parser Format
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Format -> Parser Format
forall (f :: * -> *) a. Applicative f => a -> f a
pure Format
f

-- | 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
/= :: Header -> Header -> Bool
$c/= :: Header -> Header -> Bool
== :: Header -> Header -> Bool
$c== :: Header -> Header -> Bool
Eq, Int -> Header -> ShowS
[Header] -> ShowS
Header -> String
(Int -> Header -> ShowS)
-> (Header -> String) -> ([Header] -> ShowS) -> Show Header
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Header] -> ShowS
$cshowList :: [Header] -> ShowS
show :: Header -> String
$cshow :: Header -> String
showsPrec :: Int -> Header -> ShowS
$cshowsPrec :: Int -> 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
$cto :: forall x. Rep Header x -> Header
$cfrom :: forall x. Header -> Rep Header x
Generic)

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

-- | 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
/= :: CompareLevels -> CompareLevels -> Bool
$c/= :: CompareLevels -> CompareLevels -> Bool
== :: CompareLevels -> CompareLevels -> Bool
$c== :: CompareLevels -> CompareLevels -> Bool
Eq, Int -> CompareLevels -> ShowS
[CompareLevels] -> ShowS
CompareLevels -> String
(Int -> CompareLevels -> ShowS)
-> (CompareLevels -> String)
-> ([CompareLevels] -> ShowS)
-> Show CompareLevels
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompareLevels] -> ShowS
$cshowList :: [CompareLevels] -> ShowS
show :: CompareLevels -> String
$cshow :: CompareLevels -> String
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
    (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
<> String -> Mod OptionFields Double
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"error" Mod OptionFields Double
-> Mod OptionFields Double -> Mod OptionFields Double
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Double
forall (f :: * -> *) a. String -> Mod f a
help String
"error level")
    Parser (Double -> Double -> CompareLevels)
-> Parser Double -> Parser (Double -> CompareLevels)
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
<> String -> Mod OptionFields Double
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"warning" Mod OptionFields Double
-> Mod OptionFields Double -> Mod OptionFields Double
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Double
forall (f :: * -> *) a. String -> Mod f a
help String
"warning level")
    Parser (Double -> CompareLevels)
-> Parser Double -> Parser CompareLevels
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
<> String -> Mod OptionFields Double
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"improved" Mod OptionFields Double
-> Mod OptionFields Double -> Mod OptionFields Double
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Double
forall (f :: * -> *) a. String -> Mod f a
help String
"improved level")

-- | Report configuration options
data ReportConfig = ReportConfig
  { ReportConfig -> Format
format :: Format,
    ReportConfig -> Header
includeHeader :: Header,
    ReportConfig -> CompareLevels
levels :: CompareLevels
  }
  deriving (ReportConfig -> ReportConfig -> Bool
(ReportConfig -> ReportConfig -> Bool)
-> (ReportConfig -> ReportConfig -> Bool) -> Eq ReportConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReportConfig -> ReportConfig -> Bool
$c/= :: ReportConfig -> ReportConfig -> Bool
== :: ReportConfig -> ReportConfig -> Bool
$c== :: ReportConfig -> ReportConfig -> Bool
Eq, Int -> ReportConfig -> ShowS
[ReportConfig] -> ShowS
ReportConfig -> String
(Int -> ReportConfig -> ShowS)
-> (ReportConfig -> String)
-> ([ReportConfig] -> ShowS)
-> Show ReportConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReportConfig] -> ShowS
$cshowList :: [ReportConfig] -> ShowS
show :: ReportConfig -> String
$cshow :: ReportConfig -> String
showsPrec :: Int -> ReportConfig -> ShowS
$cshowsPrec :: Int -> ReportConfig -> ShowS
Show, (forall x. ReportConfig -> Rep ReportConfig x)
-> (forall x. Rep ReportConfig x -> ReportConfig)
-> Generic ReportConfig
forall x. Rep ReportConfig x -> ReportConfig
forall x. ReportConfig -> Rep ReportConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ReportConfig x -> ReportConfig
$cfrom :: forall x. ReportConfig -> Rep ReportConfig x
Generic)

-- |
-- >>> defaultReportConfig
-- ReportConfig {format = ConsoleMode, includeHeader = Header, levels = CompareLevels {errorLevel = 0.2, warningLevel = 5.0e-2, improvedLevel = 5.0e-2}}
defaultReportConfig :: ReportConfig
defaultReportConfig :: ReportConfig
defaultReportConfig = Format -> Header -> CompareLevels -> ReportConfig
ReportConfig Format
ConsoleMode Header
Header CompareLevels
defaultCompareLevels

-- | Parse 'ReportConfig' command line options.
parseReportConfig :: ReportConfig -> Parser ReportConfig
parseReportConfig :: ReportConfig -> Parser ReportConfig
parseReportConfig ReportConfig
c =
  Format -> Header -> CompareLevels -> ReportConfig
ReportConfig
    (Format -> Header -> CompareLevels -> ReportConfig)
-> Parser Format
-> Parser (Header -> CompareLevels -> ReportConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Format -> Parser Format
parseFormat (ReportConfig -> Format
format ReportConfig
c)
    Parser (Header -> CompareLevels -> ReportConfig)
-> Parser Header -> Parser (CompareLevels -> ReportConfig)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Header -> Parser Header
parseHeader (ReportConfig -> Header
includeHeader ReportConfig
c)
    Parser (CompareLevels -> ReportConfig)
-> Parser CompareLevels -> Parser ReportConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CompareLevels -> Parser CompareLevels
parseCompareLevels (ReportConfig -> CompareLevels
levels ReportConfig
c)

-- | Write results to file, in CSV format.
writeResult :: FilePath -> Map.Map [Text] Double -> IO ()
writeResult :: String -> Map [Text] Double -> IO ()
writeResult String
f Map [Text] Double
m = Committer IO ([Text], Double)
-> Emitter IO ([Text], Double) -> IO ()
forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue (Committer IO ([Text], Double)
 -> Emitter IO ([Text], Double) -> IO ())
-> Codensity IO (Committer IO ([Text], Double))
-> Codensity IO (Emitter IO ([Text], Double) -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CsvConfig
-> (([Text], Double) -> [Text])
-> Codensity IO (Committer IO ([Text], Double))
forall a. CsvConfig -> (a -> [Text]) -> CoCommitter IO a
Csv.rowCommitter (String -> Char -> Header -> CsvConfig
Csv.CsvConfig String
f Char
',' Header
Csv.NoHeader) (\([Text]
ls, Double
v) -> [Text]
ls [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Maybe Int -> Double -> Text
expt (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
3) Double
v]) Codensity IO (Emitter IO ([Text], Double) -> IO ())
-> Codensity IO (Emitter IO ([Text], Double)) -> IO ()
forall (m :: * -> *) a r.
Codensity m (a -> m r) -> Codensity m a -> m r
<*|> [([Text], Double)] -> Codensity IO (Emitter IO ([Text], Double))
forall (m :: * -> *) a. MonadConc m => [a] -> CoEmitter m a
qList (Map [Text] Double -> [([Text], Double)]
forall k a. Map k a -> [(k, a)]
Map.toList Map [Text] Double
m)

-- | Read results from file that are in CSV format.
readResult :: FilePath -> IO (Map.Map [Text] Double)
readResult :: String -> IO (Map [Text] Double)
readResult String
f = do
  [Either Text [Text]]
r <- CsvConfig -> (Char -> Parser [Text]) -> IO [Either Text [Text]]
forall a. CsvConfig -> (Char -> Parser a) -> IO [Either Text a]
Csv.runCsv (String -> Char -> Header -> CsvConfig
Csv.CsvConfig String
f Char
',' Header
Csv.NoHeader) Char -> Parser [Text]
Csv.fields
  let r' :: [[Text]]
r' = [[Text]
x | (Right [Text]
x) <- [Either Text [Text]]
r]
  let l :: [([Text], Double)]
l = (\[Text]
x -> ([Text] -> [Text]
forall a. [a] -> [a]
List.init [Text]
x, Double -> Either String Double -> Double
forall b a. b -> Either a b -> b
fromRight Double
0 (Parser Double -> Text -> Either String Double
forall a. Parser a -> Text -> Either String a
A.parseOnly Parser Double
Csv.double ([Text] -> Text
forall a. [a] -> a
List.last [Text]
x)))) ([Text] -> ([Text], Double)) -> [[Text]] -> [([Text], Double)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Text]]
r'
  Map [Text] Double -> IO (Map [Text] Double)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map [Text] Double -> IO (Map [Text] Double))
-> Map [Text] Double -> IO (Map [Text] Double)
forall a b. (a -> b) -> a -> b
$ [([Text], Double)] -> Map [Text] Double
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [([Text], Double)]
l

-- | 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 -> String
(Int -> CompareResult -> ShowS)
-> (CompareResult -> String)
-> ([CompareResult] -> ShowS)
-> Show CompareResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompareResult] -> ShowS
$cshowList :: [CompareResult] -> ShowS
show :: CompareResult -> String
$cshow :: CompareResult -> String
showsPrec :: Int -> CompareResult -> ShowS
$cshowsPrec :: Int -> CompareResult -> ShowS
Show, CompareResult -> CompareResult -> Bool
(CompareResult -> CompareResult -> Bool)
-> (CompareResult -> CompareResult -> Bool) -> Eq CompareResult
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)

-- | 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 :: 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 p. IsString p => Double -> Double -> p
note' Double
x' Double
y')
        )
    )
    Map a Double
x
    Map a Double
y
  where
    note' :: Double -> Double -> p
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 = p
"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 = p
"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) = p
"improvement"
      | Bool
otherwise = p
""

-- | Like intercalate, but on the outside as well.
outercalate :: Text -> [Text] -> Text
outercalate :: Text -> [Text] -> Text
outercalate Text
c [Text]
ts = Text
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
c [Text]
ts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c

-- | Report to a console, comparing the measurement versus a canned file.
reportGolden :: ReportConfig -> FilePath -> Map.Map [Text] Double -> IO ()
reportGolden :: ReportConfig -> String -> Map [Text] Double -> IO ()
reportGolden ReportConfig
cfg String
f Map [Text] Double
m = do
  Map [Text] Double
mOrig <- String -> IO (Map [Text] Double)
readResult String
f
  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 (ReportConfig -> CompareLevels
levels ReportConfig
cfg) Map [Text] Double
mOrig Map [Text] Double
m
  [Text] -> IO ()
reportToConsole ([Text] -> IO ()) -> [Text] -> IO ()
forall a b. (a -> b) -> a -> b
$ Format -> Header -> Map [Text] CompareResult -> [Text]
formatCompare (ReportConfig -> Format
format ReportConfig
cfg) (ReportConfig -> Header
includeHeader ReportConfig
cfg) Map [Text] CompareResult
n

-- | Org-mode style header.
formatOrgHeader :: Map.Map [Text] a -> [Text] -> [Text]
formatOrgHeader :: Map [Text] a -> [Text] -> [Text]
formatOrgHeader Map [Text] a
m [Text]
ts =
  [ Text -> [Text] -> Text
outercalate Text
"|" (((Text
"label" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Int -> Text) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
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 -> [Text] -> Text
outercalate Text
"|" (Int -> Text -> [Text]
forall a. Int -> a -> [a]
replicate (Int
labelCols Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
"---")
  ]
  where
    labelCols :: Int
labelCols = [Int] -> Int
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 (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

-- | Console-style header information.
formatConsoleHeader :: Map.Map [Text] a -> [Text] -> [Text]
formatConsoleHeader :: Map [Text] a -> [Text] -> [Text]
formatConsoleHeader 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
$ String -> Text
Text.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> String
forall r. PrintfType r => String -> r
printf String
"%-20s" (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((Text
"label" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Int -> Text) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
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 (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ [Text] -> 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 :: Format -> Header -> Map.Map [Text] CompareResult -> [Text]
formatCompare :: Format -> Header -> Map [Text] CompareResult -> [Text]
formatCompare Format
f Header
h Map [Text] CompareResult
m =
  case Format
f of
    Format
OrgMode ->
      [Text] -> [Text] -> Bool -> [Text]
forall a. a -> a -> Bool -> a
bool [] (Map [Text] CompareResult -> [Text] -> [Text]
forall a. Map [Text] a -> [Text] -> [Text]
formatOrgHeader Map [Text] CompareResult
m [Text
"old_result", Text
"new_result", Text
"status"]) (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 -> Text -> [Text] -> Text
outercalate Text
"|" ([Text]
k [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> CompareResult -> [Text]
compareReport CompareResult
a)) Map [Text] CompareResult
m)
    Format
ConsoleMode ->
      [Text] -> [Text] -> Bool -> [Text]
forall a. a -> a -> Bool -> a
bool [] (Map [Text] CompareResult -> [Text] -> [Text]
forall a. Map [Text] a -> [Text] -> [Text]
formatConsoleHeader Map [Text] CompareResult
m [Text
"old_result", Text
"new_result", Text
"status"]) (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 -> String -> Text
Text.pack (String -> Text) -> ([String] -> String) -> [String] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. Monoid a => [a] -> a
mconcat ([String] -> Text) -> [String] -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text -> String
forall r. PrintfType r => String -> r
printf String
"%-20s" (Text -> String) -> [Text] -> [String]
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 in org-mode style
formatOrg :: Header -> Map.Map [Text] Text -> [Text]
formatOrg :: Header -> Map [Text] Text -> [Text]
formatOrg 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]
formatOrgHeader 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 -> Text -> [Text] -> Text
outercalate Text
"|" ([Text]
k [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
a])) Map [Text] Text
m)

-- | Format a result in console-style
formatConsole :: Header -> Map.Map [Text] Text -> [Text]
formatConsole :: Header -> Map [Text] Text -> [Text]
formatConsole 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]
formatConsoleHeader 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 -> String -> Text
Text.pack (String -> Text) -> ([String] -> String) -> [String] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. Monoid a => [a] -> a
mconcat ([String] -> Text) -> [String] -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text -> String
forall r. PrintfType r => String -> r
printf String
"%-20s" (Text -> String) -> [Text] -> [String]
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. [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. [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 -> String
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
$cto :: forall x. Rep Golden x -> Golden
$cfrom :: forall x. Golden -> Rep Golden x
Generic, Golden -> Golden -> Bool
(Golden -> Golden -> Bool)
-> (Golden -> Golden -> Bool) -> Eq Golden
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 -> String
(Int -> Golden -> ShowS)
-> (Golden -> String) -> ([Golden] -> ShowS) -> Show Golden
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Golden] -> ShowS
$cshowList :: [Golden] -> ShowS
show :: Golden -> String
$cshow :: Golden -> String
showsPrec :: Int -> Golden -> ShowS
$cshowsPrec :: Int -> Golden -> ShowS
Show)

-- | Parse command-line golden file options.
parseGolden :: String -> Parser Golden
parseGolden :: String -> Parser Golden
parseGolden String
def =
  String -> Bool -> Bool -> Golden
Golden
    (String -> Bool -> Bool -> Golden)
-> Parser String -> Parser (Bool -> Bool -> Golden)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM String -> Mod OptionFields String -> Parser String
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM String
forall s. IsString s => ReadM s
str (String -> Mod OptionFields String
forall (f :: * -> *) a. HasValue f => a -> Mod f a
Options.Applicative.value (String
"other/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
def String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".csv") Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"golden" Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'g' Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"golden file name")
    Parser (Bool -> Bool -> Golden)
-> Parser Bool -> Parser (Bool -> Golden)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"check" 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
'c' Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"check versus a golden file")
    Parser (Bool -> Golden) -> Parser Bool -> Parser Golden
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"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
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"record the result to a golden file")

-- | Report results
report :: ReportConfig -> Golden -> [Text] -> Map.Map [Text] [Double] -> IO ()
report :: ReportConfig -> Golden -> [Text] -> Map [Text] [Double] -> IO ()
report ReportConfig
cfg Golden
g [Text]
labels Map [Text] [Double]
m = do
  IO () -> IO () -> Bool -> IO ()
forall a. a -> a -> Bool -> a
bool
    ([Text] -> IO ()
reportToConsole (Format -> Header -> Map [Text] Text -> [Text]
formatIn (ReportConfig -> Format
format ReportConfig
cfg) (ReportConfig -> Header
includeHeader ReportConfig
cfg) (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')))
    (ReportConfig -> String -> Map [Text] Double -> IO ()
reportGolden ReportConfig
cfg (Golden -> String
golden Golden
g) Map [Text] Double
m')
    (Golden -> Bool
check Golden
g)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Golden -> Bool
record Golden
g)
    (String -> Map [Text] Double -> IO ()
writeResult (Golden -> String
golden Golden
g) Map [Text] Double
m')
  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 [Text]
labels) (([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

-- | Format a result given 'Format' and 'Header' preferences.
formatIn :: Format -> Header -> Map.Map [Text] Text -> [Text]
formatIn :: Format -> Header -> Map [Text] Text -> [Text]
formatIn Format
f Header
h = case Format
f of
  Format
OrgMode -> Header -> Map [Text] Text -> [Text]
formatOrg Header
h
  Format
ConsoleMode -> Header -> Map [Text] Text -> [Text]
formatConsole Header
h