-- | @futhark benchcmp@
module Futhark.CLI.Benchcmp (main) where

import Control.Exception (catch)
import Data.Bifunctor (Bifunctor (bimap, first, second))
import Data.ByteString.Lazy.Char8 qualified as LBS
import Data.Either qualified as E
import Data.List qualified as L
import Data.Map qualified as M
import Data.Text qualified as T
import Data.Vector qualified as V
import Futhark.Bench
import Futhark.Util (showText)
import Futhark.Util.Options (mainWithOptions)
import Statistics.Sample qualified as S
import System.Console.ANSI (hSupportsANSI)
import System.IO (stdout)
import Text.Printf (printf)

-- | Record that summerizes a comparison between two benchmarks.
data SpeedUp = SpeedUp
  { -- | What factor the benchmark is improved by.
    SpeedUp -> Double
speedup :: Double,
    -- | Memory usage.
    SpeedUp -> Map Text Double
memoryUsage :: M.Map T.Text Double,
    -- | If the speedup was significant.
    SpeedUp -> Bool
significant :: Bool
  }
  deriving (Int -> SpeedUp -> ShowS
[SpeedUp] -> ShowS
SpeedUp -> String
(Int -> SpeedUp -> ShowS)
-> (SpeedUp -> String) -> ([SpeedUp] -> ShowS) -> Show SpeedUp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SpeedUp -> ShowS
showsPrec :: Int -> SpeedUp -> ShowS
$cshow :: SpeedUp -> String
show :: SpeedUp -> String
$cshowList :: [SpeedUp] -> ShowS
showList :: [SpeedUp] -> ShowS
Show)

-- | Terminal colors used when printing the comparisons. Some of these are not
-- colors ways of emphasising text.
data Colors = Colors
  { -- | The header color.
    Colors -> Text
header :: T.Text,
    -- | Okay color
    Colors -> Text
okblue :: T.Text,
    -- | A second okay color
    Colors -> Text
okgreen :: T.Text,
    -- | Warning color.
    Colors -> Text
warning :: T.Text,
    -- | When something fails.
    Colors -> Text
failing :: T.Text,
    -- | Default color.
    Colors -> Text
endc :: T.Text,
    -- | Bold text.
    Colors -> Text
bold :: T.Text,
    -- | Underline text.
    Colors -> Text
underline :: T.Text
  }

-- | Colors to use for a terminal device.
ttyColors :: Colors
ttyColors :: Colors
ttyColors =
  Colors
    { header :: Text
header = Text
"\ESC[95m",
      okblue :: Text
okblue = Text
"\ESC[94m",
      okgreen :: Text
okgreen = Text
"\ESC[92m",
      warning :: Text
warning = Text
"\ESC[93m",
      failing :: Text
failing = Text
"\ESC[91m",
      endc :: Text
endc = Text
"\ESC[0m",
      bold :: Text
bold = Text
"\ESC[1m",
      underline :: Text
underline = Text
"\ESC[4m"
    }

-- | Colors to use for a non-terminal device.
nonTtyColors :: Colors
nonTtyColors :: Colors
nonTtyColors =
  Colors
    { header :: Text
header = Text
"",
      okblue :: Text
okblue = Text
"",
      okgreen :: Text
okgreen = Text
"",
      warning :: Text
warning = Text
"",
      failing :: Text
failing = Text
"",
      endc :: Text
endc = Text
"",
      bold :: Text
bold = Text
"",
      underline :: Text
underline = Text
""
    }

-- | Reads a file without throwing an error.
readFileSafely :: T.Text -> IO (Either T.Text LBS.ByteString)
readFileSafely :: Text -> IO (Either Text ByteString)
readFileSafely Text
filepath =
  (ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right (ByteString -> Either Text ByteString)
-> IO ByteString -> IO (Either Text ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
LBS.readFile (Text -> String
T.unpack Text
filepath)) IO (Either Text ByteString)
-> (IOError -> IO (Either Text ByteString))
-> IO (Either Text ByteString)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` IOError -> IO (Either Text ByteString)
forall {f :: * -> *} {b}.
Applicative f =>
IOError -> f (Either Text b)
couldNotRead
  where
    couldNotRead :: IOError -> f (Either Text b)
couldNotRead IOError
e = Either Text b -> f (Either Text b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text b -> f (Either Text b))
-> Either Text b -> f (Either Text b)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text b
forall a b. a -> Either a b
Left (Text -> Either Text b) -> Text -> Either Text b
forall a b. (a -> b) -> a -> b
$ IOError -> Text
forall a. Show a => a -> Text
showText (IOError
e :: IOError)

-- | Converts DataResults to a Map with the text as a key.
toDataResultsMap :: [DataResult] -> M.Map T.Text (Either T.Text Result)
toDataResultsMap :: [DataResult] -> Map Text (Either Text Result)
toDataResultsMap = [(Text, Either Text Result)] -> Map Text (Either Text Result)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, Either Text Result)] -> Map Text (Either Text Result))
-> ([DataResult] -> [(Text, Either Text Result)])
-> [DataResult]
-> Map Text (Either Text Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DataResult -> (Text, Either Text Result))
-> [DataResult] -> [(Text, Either Text Result)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DataResult -> (Text, Either Text Result)
toTuple
  where
    toTuple :: DataResult -> (Text, Either Text Result)
toTuple (DataResult Text
dataset Either Text Result
dataResults) = (Text
dataset, Either Text Result
dataResults)

-- | Converts BenchResults to a Map with the file path as a key.
toBenchResultsMap ::
  [BenchResult] ->
  M.Map T.Text (M.Map T.Text (Either T.Text Result))
toBenchResultsMap :: [BenchResult] -> Map Text (Map Text (Either Text Result))
toBenchResultsMap = [(Text, Map Text (Either Text Result))]
-> Map Text (Map Text (Either Text Result))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, Map Text (Either Text Result))]
 -> Map Text (Map Text (Either Text Result)))
-> ([BenchResult] -> [(Text, Map Text (Either Text Result))])
-> [BenchResult]
-> Map Text (Map Text (Either Text Result))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BenchResult -> (Text, Map Text (Either Text Result)))
-> [BenchResult] -> [(Text, Map Text (Either Text Result))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BenchResult -> (Text, Map Text (Either Text Result))
toTuple
  where
    toTuple :: BenchResult -> (Text, Map Text (Either Text Result))
toTuple (BenchResult String
path [DataResult]
dataResults) =
      (String -> Text
T.pack String
path, [DataResult] -> Map Text (Either Text Result)
toDataResultsMap [DataResult]
dataResults)

-- | Given a file path to a json file which has the form of a futhark benchmark
-- result, it will try to parse the file to a Map of Maps. The key
-- in the outer most dictionary is a file path the inner key is the dataset.
decodeFileBenchResultsMap ::
  T.Text ->
  IO (Either T.Text (M.Map T.Text (M.Map T.Text (Either T.Text Result))))
decodeFileBenchResultsMap :: Text -> IO (Either Text (Map Text (Map Text (Either Text Result))))
decodeFileBenchResultsMap Text
path = do
  Either Text ByteString
file <- Text -> IO (Either Text ByteString)
readFileSafely Text
path
  Either Text (Map Text (Map Text (Either Text Result)))
-> IO (Either Text (Map Text (Map Text (Either Text Result))))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text (Map Text (Map Text (Either Text Result)))
 -> IO (Either Text (Map Text (Map Text (Either Text Result)))))
-> Either Text (Map Text (Map Text (Either Text Result)))
-> IO (Either Text (Map Text (Map Text (Either Text Result))))
forall a b. (a -> b) -> a -> b
$ [BenchResult] -> Map Text (Map Text (Either Text Result))
toBenchResultsMap ([BenchResult] -> Map Text (Map Text (Either Text Result)))
-> Either Text [BenchResult]
-> Either Text (Map Text (Map Text (Either Text Result)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Either Text ByteString
file Either Text ByteString
-> (ByteString -> Either Text [BenchResult])
-> Either Text [BenchResult]
forall a b. Either Text a -> (a -> Either Text b) -> Either Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((String -> Text)
-> Either String [BenchResult] -> Either Text [BenchResult]
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
T.pack (Either String [BenchResult] -> Either Text [BenchResult])
-> (ByteString -> Either String [BenchResult])
-> ByteString
-> Either Text [BenchResult]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String [BenchResult]
decodeBenchResults))

-- | Will return a text with an error saying there is a missing program in a
-- given result.
formatMissingProg :: T.Text -> T.Text -> T.Text -> T.Text
formatMissingProg :: Text -> Text -> Text -> Text
formatMissingProg = ((String -> Text
T.pack .) .) ((Text -> Text -> String) -> Text -> Text -> Text)
-> (Text -> Text -> Text -> String) -> Text -> Text -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> Text -> Text -> String
forall r. PrintfType r => String -> r
printf String
"In %s but not %s: program %s"

-- | Will return a text with an error saying there is a missing dataset in a
-- given result.
formatMissingData :: T.Text -> T.Text -> T.Text -> T.Text -> T.Text
formatMissingData :: Text -> Text -> Text -> Text -> Text
formatMissingData =
  (((String -> Text
T.pack .) .) .) ((Text -> Text -> Text -> String) -> Text -> Text -> Text -> Text)
-> (Text -> Text -> Text -> Text -> String)
-> Text
-> Text
-> Text
-> Text
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> Text -> Text -> Text -> String
forall r. PrintfType r => String -> r
printf String
"In %s but not %s: program %s dataset %s"

-- | Will return texts that say there are a missing program.
formatManyMissingProg :: T.Text -> T.Text -> [T.Text] -> [T.Text]
formatManyMissingProg :: Text -> Text -> [Text] -> [Text]
formatManyMissingProg Text
a_path Text
b_path =
  (Text -> Text -> Text -> Text)
-> [Text] -> [Text] -> [Text] -> [Text]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Text -> Text -> Text -> Text
formatMissingProg [Text]
a_paths [Text]
b_paths
  where
    a_paths :: [Text]
a_paths = Text -> [Text]
forall a. a -> [a]
repeat Text
a_path
    b_paths :: [Text]
b_paths = Text -> [Text]
forall a. a -> [a]
repeat Text
b_path

-- | Will return texts that say there are missing datasets for a program.
formatManyMissingData :: T.Text -> T.Text -> T.Text -> [T.Text] -> [T.Text]
formatManyMissingData :: Text -> Text -> Text -> [Text] -> [Text]
formatManyMissingData Text
prog Text
a_path Text
b_path =
  (Text -> Text -> Text -> Text -> Text)
-> [Text] -> [Text] -> [Text] -> [Text] -> [Text]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
L.zipWith4 Text -> Text -> Text -> Text -> Text
formatMissingData [Text]
a_paths [Text]
b_paths [Text]
progs
  where
    a_paths :: [Text]
a_paths = Text -> [Text]
forall a. a -> [a]
repeat Text
a_path
    b_paths :: [Text]
b_paths = Text -> [Text]
forall a. a -> [a]
repeat Text
b_path
    progs :: [Text]
progs = Text -> [Text]
forall a. a -> [a]
repeat Text
prog

-- | Finds the keys two Maps does not have in common and returns a appropiate
-- error based on the functioned passed.
missingResults ::
  (T.Text -> T.Text -> [T.Text] -> [T.Text]) ->
  T.Text ->
  T.Text ->
  M.Map T.Text a ->
  M.Map T.Text b ->
  [T.Text]
missingResults :: forall a b.
(Text -> Text -> [Text] -> [Text])
-> Text -> Text -> Map Text a -> Map Text b -> [Text]
missingResults Text -> Text -> [Text] -> [Text]
toMissingMap Text
a_path Text
b_path Map Text a
a_results Map Text b
b_results = [Text]
missing
  where
    a_keys :: [Text]
a_keys = Map Text a -> [Text]
forall k a. Map k a -> [k]
M.keys Map Text a
a_results
    b_keys :: [Text]
b_keys = Map Text b -> [Text]
forall k a. Map k a -> [k]
M.keys Map Text b
b_results
    a_missing :: [Text]
a_missing = Text -> Text -> [Text] -> [Text]
toMissingMap Text
a_path Text
b_path ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text]
a_keys [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
b_keys
    b_missing :: [Text]
b_missing = Text -> Text -> [Text] -> [Text]
toMissingMap Text
b_path Text
a_path ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text]
b_keys [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [Text]
a_keys
    missing :: [Text]
missing = [Text]
a_missing [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
`L.union` [Text]
b_missing

-- | Compares the memory usage of two results.
computeMemoryUsage ::
  M.Map T.Text Int ->
  M.Map T.Text Int ->
  M.Map T.Text Double
computeMemoryUsage :: Map Text Int -> Map Text Int -> Map Text Double
computeMemoryUsage Map Text Int
a Map Text Int
b = (Int -> Int -> Double)
-> Map Text Int -> Map Text Int -> Map Text Double
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith Int -> Int -> Double
forall {a} {a} {a}.
(Fractional a, Integral a, Integral a) =>
a -> a -> a
divide Map Text Int
b (Map Text Int -> Map Text Double)
-> Map Text Int -> Map Text Double
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> Map Text Int -> Map Text Int
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) Map Text Int
a
  where
    divide :: a -> a -> a
divide a
x a
y = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x a -> a -> a
forall a. Fractional a => a -> a -> a
/ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
y

-- | Compares two results and thereby computes the Speed Up records.
compareResult :: Result -> Result -> SpeedUp
compareResult :: Result -> Result -> SpeedUp
compareResult Result
a Result
b =
  SpeedUp
    { speedup :: Double
speedup = Double
speedup',
      significant :: Bool
significant = Bool
significant',
      memoryUsage :: Map Text Double
memoryUsage = Map Text Double
memory_usage
    }
  where
    runResultToDouble :: RunResult -> Double
    runResultToDouble :: RunResult -> Double
runResultToDouble = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> (RunResult -> Int) -> RunResult -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunResult -> Int
runMicroseconds
    toVector :: Result -> Vector Double
toVector = [Double] -> Vector Double
forall a. [a] -> Vector a
V.fromList ([Double] -> Vector Double)
-> (Result -> [Double]) -> Result -> Vector Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RunResult -> Double
runResultToDouble <$>) ([RunResult] -> [Double])
-> (Result -> [RunResult]) -> Result -> [Double]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> [RunResult]
runResults
    a_memory_usage :: Map Text Int
a_memory_usage = Result -> Map Text Int
memoryMap Result
a
    b_memory_usage :: Map Text Int
b_memory_usage = Result -> Map Text Int
memoryMap Result
b
    a_run_results :: Vector Double
a_run_results = Result -> Vector Double
toVector Result
a
    b_run_results :: Vector Double
b_run_results = Result -> Vector Double
toVector Result
b
    a_std :: Double
a_std = Vector Double -> Double
forall (v :: * -> *). Vector v Double => v Double -> Double
S.stdDev Vector Double
a_run_results
    b_std :: Double
b_std = Vector Double -> Double
forall (v :: * -> *). Vector v Double => v Double -> Double
S.stdDev Vector Double
b_run_results
    a_mean :: Double
a_mean = Vector Double -> Double
forall (v :: * -> *). Vector v Double => v Double -> Double
S.mean Vector Double
a_run_results
    b_mean :: Double
b_mean = Vector Double -> Double
forall (v :: * -> *). Vector v Double => v Double -> Double
S.mean Vector Double
b_run_results
    diff :: Double
diff = Double -> Double
forall a. Num a => a -> a
abs (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
a_mean Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
b_mean
    speedup' :: Double
speedup' = Double
a_mean Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
b_mean
    significant' :: Bool
significant' = Double
diff Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
a_std Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
b_std Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
    memory_usage :: Map Text Double
memory_usage = Map Text Int -> Map Text Int -> Map Text Double
computeMemoryUsage Map Text Int
a_memory_usage Map Text Int
b_memory_usage

-- | Given two Maps containing datasets as keys and results as values, compare
-- the results and return the errors in a tuple.
compareDataResults ::
  T.Text ->
  T.Text ->
  T.Text ->
  M.Map T.Text (Either T.Text Result) ->
  M.Map T.Text (Either T.Text Result) ->
  (M.Map T.Text SpeedUp, ([T.Text], [T.Text]))
compareDataResults :: Text
-> Text
-> Text
-> Map Text (Either Text Result)
-> Map Text (Either Text Result)
-> (Map Text SpeedUp, ([Text], [Text]))
compareDataResults Text
prog Text
a_path Text
b_path Map Text (Either Text Result)
a_data Map Text (Either Text Result)
b_data = (Map Text SpeedUp, ([Text], [Text]))
result
  where
    formatMissing :: Text -> Text -> [Text] -> [Text]
formatMissing = Text -> Text -> Text -> [Text] -> [Text]
formatManyMissingData Text
prog
    partition :: Map k (Either a a) -> ([a], [(k, a)])
partition = [Either a (k, a)] -> ([a], [(k, a)])
forall a b. [Either a b] -> ([a], [b])
E.partitionEithers ([Either a (k, a)] -> ([a], [(k, a)]))
-> (Map k (Either a a) -> [Either a (k, a)])
-> Map k (Either a a)
-> ([a], [(k, a)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, Either a a) -> Either a (k, a))
-> [(k, Either a a)] -> [Either a (k, a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (k, Either a a) -> Either a (k, a)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => (k, m a) -> m (k, a)
sequence ([(k, Either a a)] -> [Either a (k, a)])
-> (Map k (Either a a) -> [(k, Either a a)])
-> Map k (Either a a)
-> [Either a (k, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k (Either a a) -> [(k, Either a a)]
forall k a. Map k a -> [(k, a)]
M.toList
    ([Text]
a_errors, Map Text Result
a_data') = ([(Text, Result)] -> Map Text Result)
-> ([Text], [(Text, Result)]) -> ([Text], Map Text Result)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [(Text, Result)] -> Map Text Result
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (([Text], [(Text, Result)]) -> ([Text], Map Text Result))
-> ([Text], [(Text, Result)]) -> ([Text], Map Text Result)
forall a b. (a -> b) -> a -> b
$ Map Text (Either Text Result) -> ([Text], [(Text, Result)])
forall {k} {a} {a}. Map k (Either a a) -> ([a], [(k, a)])
partition Map Text (Either Text Result)
a_data
    ([Text]
b_errors, Map Text Result
b_data') = ([(Text, Result)] -> Map Text Result)
-> ([Text], [(Text, Result)]) -> ([Text], Map Text Result)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [(Text, Result)] -> Map Text Result
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (([Text], [(Text, Result)]) -> ([Text], Map Text Result))
-> ([Text], [(Text, Result)]) -> ([Text], Map Text Result)
forall a b. (a -> b) -> a -> b
$ Map Text (Either Text Result) -> ([Text], [(Text, Result)])
forall {k} {a} {a}. Map k (Either a a) -> ([a], [(k, a)])
partition Map Text (Either Text Result)
b_data
    missing :: [Text]
missing = (Text -> Text -> [Text] -> [Text])
-> Text -> Text -> Map Text Result -> Map Text Result -> [Text]
forall a b.
(Text -> Text -> [Text] -> [Text])
-> Text -> Text -> Map Text a -> Map Text b -> [Text]
missingResults Text -> Text -> [Text] -> [Text]
formatMissing Text
a_path Text
b_path Map Text Result
a_data' Map Text Result
b_data'
    exists :: Map Text SpeedUp
exists = (Result -> Result -> SpeedUp)
-> Map Text Result -> Map Text Result -> Map Text SpeedUp
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith Result -> Result -> SpeedUp
compareResult Map Text Result
a_data' Map Text Result
b_data'
    errors :: [Text]
errors = [Text]
a_errors [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
b_errors
    result :: (Map Text SpeedUp, ([Text], [Text]))
result = (Map Text SpeedUp
exists, ([Text]
errors, [Text]
missing))

-- | Given two Maps containing program file paths as keys and values as datasets
-- with results. Compare the results for each dataset in each program and
-- return the errors in a tuple.
compareBenchResults ::
  T.Text ->
  T.Text ->
  M.Map T.Text (M.Map T.Text (Either T.Text Result)) ->
  M.Map T.Text (M.Map T.Text (Either T.Text Result)) ->
  (M.Map T.Text (M.Map T.Text SpeedUp), ([T.Text], [T.Text]))
compareBenchResults :: Text
-> Text
-> Map Text (Map Text (Either Text Result))
-> Map Text (Map Text (Either Text Result))
-> (Map Text (Map Text SpeedUp), ([Text], [Text]))
compareBenchResults Text
a_path Text
b_path Map Text (Map Text (Either Text Result))
a_bench Map Text (Map Text (Either Text Result))
b_bench = (Map Text (Map Text SpeedUp)
exists, ([Text], [Text])
errors_missing)
  where
    missing :: [Text]
missing = (Text -> Text -> [Text] -> [Text])
-> Text
-> Text
-> Map Text (Map Text (Either Text Result))
-> Map Text (Map Text (Either Text Result))
-> [Text]
forall a b.
(Text -> Text -> [Text] -> [Text])
-> Text -> Text -> Map Text a -> Map Text b -> [Text]
missingResults Text -> Text -> [Text] -> [Text]
formatManyMissingProg Text
a_path Text
b_path Map Text (Map Text (Either Text Result))
a_bench Map Text (Map Text (Either Text Result))
b_bench
    result :: Map Text (Map Text SpeedUp, ([Text], [Text]))
result = (Text
 -> Map Text (Either Text Result)
 -> Map Text (Either Text Result)
 -> (Map Text SpeedUp, ([Text], [Text])))
-> Map Text (Map Text (Either Text Result))
-> Map Text (Map Text (Either Text Result))
-> Map Text (Map Text SpeedUp, ([Text], [Text]))
forall k a b c.
Ord k =>
(k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWithKey Text
-> Map Text (Either Text Result)
-> Map Text (Either Text Result)
-> (Map Text SpeedUp, ([Text], [Text]))
auxiliary Map Text (Map Text (Either Text Result))
a_bench Map Text (Map Text (Either Text Result))
b_bench
    auxiliary :: Text
-> Map Text (Either Text Result)
-> Map Text (Either Text Result)
-> (Map Text SpeedUp, ([Text], [Text]))
auxiliary Text
prog = Text
-> Text
-> Text
-> Map Text (Either Text Result)
-> Map Text (Either Text Result)
-> (Map Text SpeedUp, ([Text], [Text]))
compareDataResults Text
prog Text
a_path Text
b_path
    exists :: Map Text (Map Text SpeedUp)
exists = (Map Text SpeedUp -> Bool)
-> Map Text (Map Text SpeedUp) -> Map Text (Map Text SpeedUp)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not (Bool -> Bool)
-> (Map Text SpeedUp -> Bool) -> Map Text SpeedUp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text SpeedUp -> Bool
forall a. Map Text a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Map Text (Map Text SpeedUp) -> Map Text (Map Text SpeedUp))
-> Map Text (Map Text SpeedUp) -> Map Text (Map Text SpeedUp)
forall a b. (a -> b) -> a -> b
$ (Map Text SpeedUp, ([Text], [Text])) -> Map Text SpeedUp
forall a b. (a, b) -> a
fst ((Map Text SpeedUp, ([Text], [Text])) -> Map Text SpeedUp)
-> Map Text (Map Text SpeedUp, ([Text], [Text]))
-> Map Text (Map Text SpeedUp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (Map Text SpeedUp, ([Text], [Text]))
result
    errors_missing' :: ([Text], [Text])
errors_missing' = ([[Text]] -> [Text])
-> ([[Text]] -> [Text]) -> ([[Text]], [[Text]]) -> ([Text], [Text])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([[Text]], [[Text]]) -> ([Text], [Text]))
-> (Map Text ([Text], [Text]) -> ([[Text]], [[Text]]))
-> Map Text ([Text], [Text])
-> ([Text], [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Text], [Text])] -> ([[Text]], [[Text]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Text], [Text])] -> ([[Text]], [[Text]]))
-> (Map Text ([Text], [Text]) -> [([Text], [Text])])
-> Map Text ([Text], [Text])
-> ([[Text]], [[Text]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text ([Text], [Text]) -> [([Text], [Text])]
forall k a. Map k a -> [a]
M.elems (Map Text ([Text], [Text]) -> ([Text], [Text]))
-> Map Text ([Text], [Text]) -> ([Text], [Text])
forall a b. (a -> b) -> a -> b
$ (Map Text SpeedUp, ([Text], [Text])) -> ([Text], [Text])
forall a b. (a, b) -> b
snd ((Map Text SpeedUp, ([Text], [Text])) -> ([Text], [Text]))
-> Map Text (Map Text SpeedUp, ([Text], [Text]))
-> Map Text ([Text], [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text (Map Text SpeedUp, ([Text], [Text]))
result
    errors_missing :: ([Text], [Text])
errors_missing = ([Text] -> [Text]) -> ([Text], [Text]) -> ([Text], [Text])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([Text]
missing ++) ([Text], [Text])
errors_missing'

-- | Formats memory usage such that it is human readable. If the memory usage
-- is not significant an empty text is returned.
memoryFormatter :: Colors -> T.Text -> Double -> T.Text
memoryFormatter :: Colors -> Text -> Double -> Text
memoryFormatter Colors
colors Text
key Double
value
  | Double
value Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.99 = Text -> Text
forall {t}. PrintfArg t => t -> Text
memoryFormat (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Colors -> Text
okgreen Colors
colors
  | Double
value Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1.01 = Text -> Text
forall {t}. PrintfArg t => t -> Text
memoryFormat (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Colors -> Text
failing Colors
colors
  | Bool
otherwise = Text
""
  where
    memoryFormat :: t -> Text
memoryFormat t
c = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> t -> Double -> Text -> Text -> String
forall r. PrintfType r => String -> r
printf String
"%s%4.2fx@%s%s" t
c Double
value Text
key Text
endc'
    endc' :: Text
endc' = Colors -> Text
endc Colors
colors

-- | Given a SpeedUp record the memory usage will be formatted to a colored
-- human readable text.
toMemoryText :: Colors -> SpeedUp -> T.Text
toMemoryText :: Colors -> SpeedUp -> Text
toMemoryText Colors
colors SpeedUp
data_result
  | Text -> Bool
T.null Text
memory_text = Text
""
  | Bool
otherwise = Text
" (mem: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
memory_text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
  where
    memory_text :: Text
memory_text = (Text -> Double -> Text -> Text) -> Text -> Map Text Double -> Text
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey Text -> Double -> Text -> Text
formatFolder Text
"" Map Text Double
memory
    memory :: Map Text Double
memory = SpeedUp -> Map Text Double
memoryUsage SpeedUp
data_result
    formatFolder :: Text -> Double -> Text -> Text
formatFolder Text
key Double
value Text
lst = Text
lst Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Colors -> Text -> Double -> Text
memoryFormatter Colors
colors Text
key Double
value

-- | Given a text shorten it to a given length and add a suffix as the last
-- word.
shorten :: Int -> T.Text -> T.Text -> T.Text
shorten :: Int -> Text -> Text -> Text
shorten Int
c Text
end Text
string
  | Text -> Int
T.length Text
string Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
c = ([Text] -> Text
T.unwords ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. HasCallStack => [a] -> [a]
init ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
shortened) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end
  | Bool
otherwise = Text
string
  where
    end_len :: Int
end_len = Text -> Int
T.length Text
end
    (Text
shortened, Text
_) = Int -> Text -> (Text, Text)
T.splitAt (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
end_len) Text
string

-- | Given a text add padding to the right of the text in form of spaces.
rightPadding :: Int -> T.Text -> T.Text
rightPadding :: Int -> Text -> Text
rightPadding Int
c = String -> Text
T.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
s
  where
    s :: String
s = String
"%-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
c String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"s"

-- | Given a SpeedUp record print the SpeedUp in a human readable manner.
printSpeedUp :: Colors -> T.Text -> SpeedUp -> IO ()
printSpeedUp :: Colors -> Text -> SpeedUp -> IO ()
printSpeedUp Colors
colors Text
dataset SpeedUp
data_result = do
  let color :: Text
color
        | SpeedUp -> Bool
significant SpeedUp
data_result Bool -> Bool -> Bool
&& SpeedUp -> Double
speedup SpeedUp
data_result Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
1.01 = Colors -> Text
okgreen Colors
colors
        | SpeedUp -> Bool
significant SpeedUp
data_result Bool -> Bool -> Bool
&& SpeedUp -> Double
speedup SpeedUp
data_result Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0.99 = Colors -> Text
failing Colors
colors
        | Bool
otherwise = Text
""
  let short_dataset :: Text
short_dataset = Int -> Text -> Text
rightPadding Int
64 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":") (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text -> Text
shorten Int
63 Text
"[...]" Text
dataset
  let memoryText :: Text
memoryText = Colors -> SpeedUp -> Text
toMemoryText Colors
colors SpeedUp
data_result
  let speedup' :: Double
speedup' = SpeedUp -> Double
speedup SpeedUp
data_result
  let endc' :: Text
endc' = Colors -> Text
endc Colors
colors
  let format :: String
format = String
"  %s%s%10.2fx%s%s"
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> Text -> Double -> Text -> Text -> String
forall r. PrintfType r => String -> r
printf String
format Text
short_dataset Text
color Double
speedup' Text
endc' Text
memoryText

-- | Given a Map of SpeedUp records where the key is the program, print the
-- SpeedUp in a human readable manner.
printProgSpeedUps :: Colors -> T.Text -> M.Map T.Text SpeedUp -> IO ()
printProgSpeedUps :: Colors -> Text -> Map Text SpeedUp -> IO ()
printProgSpeedUps Colors
colors Text
prog Map Text SpeedUp
bench_result = do
  String -> IO ()
putStrLn String
""
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> Text -> Text -> Text -> String
forall r. PrintfType r => String -> r
printf String
"%s%s%s%s" (Colors -> Text
header Colors
colors) (Colors -> Text
bold Colors
colors) Text
prog (Colors -> Text
endc Colors
colors)
  ((Text, SpeedUp) -> IO ()) -> [(Text, SpeedUp)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Text -> SpeedUp -> IO ()) -> (Text, SpeedUp) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Colors -> Text -> SpeedUp -> IO ()
printSpeedUp Colors
colors)) ([(Text, SpeedUp)] -> IO ()) -> [(Text, SpeedUp)] -> IO ()
forall a b. (a -> b) -> a -> b
$ Map Text SpeedUp -> [(Text, SpeedUp)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text SpeedUp
bench_result

-- | Given a Map of programs with dataset speedups and relevant errors, print
-- the errors and print the speedups in a human readable manner.
printComparisons ::
  Colors ->
  M.Map T.Text (M.Map T.Text SpeedUp) ->
  ([T.Text], [T.Text]) ->
  IO ()
printComparisons :: Colors -> Map Text (Map Text SpeedUp) -> ([Text], [Text]) -> IO ()
printComparisons Colors
colors Map Text (Map Text SpeedUp)
speedups ([Text]
errors, [Text]
missing) = do
  (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ()) -> (Text -> String) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) ([Text] -> IO ()) -> [Text] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. Ord a => [a] -> [a]
L.sort [Text]
missing
  (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ()) -> (Text -> String) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) ([Text] -> IO ()) -> [Text] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. Ord a => [a] -> [a]
L.sort [Text]
errors
  ((Text, Map Text SpeedUp) -> IO ())
-> [(Text, Map Text SpeedUp)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Text -> Map Text SpeedUp -> IO ())
-> (Text, Map Text SpeedUp) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Colors -> Text -> Map Text SpeedUp -> IO ()
printProgSpeedUps Colors
colors)) ([(Text, Map Text SpeedUp)] -> IO ())
-> [(Text, Map Text SpeedUp)] -> IO ()
forall a b. (a -> b) -> a -> b
$ Map Text (Map Text SpeedUp) -> [(Text, Map Text SpeedUp)]
forall k a. Map k a -> [(k, a)]
M.toList Map Text (Map Text SpeedUp)
speedups

-- | Run @futhark benchcmp@
main :: String -> [String] -> IO ()
main :: String -> [String] -> IO ()
main = ()
-> [FunOptDescr ()]
-> String
-> ([String] -> () -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> String
-> ([String] -> cfg -> Maybe (IO ()))
-> String
-> [String]
-> IO ()
mainWithOptions () [] String
"<file> <file>" [String] -> () -> Maybe (IO ())
f
  where
    f :: [String] -> () -> Maybe (IO ())
f [String
a_path', String
b_path'] () = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ do
      let a_path :: Text
a_path = String -> Text
T.pack String
a_path'
      let b_path :: Text
b_path = String -> Text
T.pack String
b_path'
      Either Text (Map Text (Map Text (Either Text Result)))
a_either <- Text -> IO (Either Text (Map Text (Map Text (Either Text Result))))
decodeFileBenchResultsMap Text
a_path
      Either Text (Map Text (Map Text (Either Text Result)))
b_either <- Text -> IO (Either Text (Map Text (Map Text (Either Text Result))))
decodeFileBenchResultsMap Text
b_path

      Bool
isTty <- Handle -> IO Bool
hSupportsANSI Handle
stdout

      let colors :: Colors
colors =
            if Bool
isTty
              then Colors
ttyColors
              else Colors
nonTtyColors

      let comparePrint :: Map Text (Map Text (Either Text Result))
-> Map Text (Map Text (Either Text Result)) -> IO ()
comparePrint =
            ((Map Text (Map Text SpeedUp) -> ([Text], [Text]) -> IO ())
-> (Map Text (Map Text SpeedUp), ([Text], [Text])) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Colors -> Map Text (Map Text SpeedUp) -> ([Text], [Text]) -> IO ()
printComparisons Colors
colors) .)
              ((Map Text (Map Text (Either Text Result))
  -> (Map Text (Map Text SpeedUp), ([Text], [Text])))
 -> Map Text (Map Text (Either Text Result)) -> IO ())
-> (Map Text (Map Text (Either Text Result))
    -> Map Text (Map Text (Either Text Result))
    -> (Map Text (Map Text SpeedUp), ([Text], [Text])))
-> Map Text (Map Text (Either Text Result))
-> Map Text (Map Text (Either Text Result))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> Text
-> Map Text (Map Text (Either Text Result))
-> Map Text (Map Text (Either Text Result))
-> (Map Text (Map Text SpeedUp), ([Text], [Text]))
compareBenchResults Text
a_path Text
b_path

      case (Either Text (Map Text (Map Text (Either Text Result)))
a_either, Either Text (Map Text (Map Text (Either Text Result)))
b_either) of
        (Left Text
a, Left Text
b) -> String -> IO ()
putStrLn (String -> IO ()) -> (Text -> String) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b)
        (Left Text
a, Either Text (Map Text (Map Text (Either Text Result)))
_) -> String -> IO ()
putStrLn (String -> IO ()) -> (Text -> String) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
a
        (Either Text (Map Text (Map Text (Either Text Result)))
_, Left Text
b) -> String -> IO ()
putStrLn (String -> IO ()) -> (Text -> String) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
b
        (Right Map Text (Map Text (Either Text Result))
a, Right Map Text (Map Text (Either Text Result))
b) -> Map Text (Map Text (Either Text Result))
-> Map Text (Map Text (Either Text Result)) -> IO ()
comparePrint Map Text (Map Text (Either Text Result))
a Map Text (Map Text (Either Text Result))
b
    f [String]
_ ()
_ = Maybe (IO ())
forall a. Maybe a
Nothing