{-# LANGUAGE ScopedTypeVariables, QuasiQuotes #-}

module QuickBench (
  defaultMain
)
where

import Control.Exception
import Control.Monad
import Data.List
import Data.List.Split (splitOn)
import Data.Maybe
import Data.Time.Clock
import Data.Time.Format
import Data.Time.LocalTime
import Safe
import System.Console.Docopt
import System.Directory
import System.Environment
import System.Exit
import System.IO
import System.Process
import Text.Show.Pretty
import Text.Printf
import Text.Tabular
import qualified Text.Tabular.AsciiArt as TA

---------------------------------------80----------------------------------------
docoptpatterns :: Docopt
docoptpatterns :: Docopt
docoptpatterns = [docopt|quickbench 1.0
Run some test commands, possibly with different executables, once or more
and show their best execution times.
Commands are specified as one or more quote-enclosed arguments,
and/or one per line in CMDSFILE; or read from a default file [./bench.sh].
With -w, commands' first words are replaced with a new executable
(or multiple comma-separated executables, showing times for all).
Note: tests executable files only, not shell builtins; options must precede args.

Usage:
  quickbench [options] [<cmd>...]

Options:
  -f, --file CMDSFILE   file containing commands, one per line (- for stdin)
  -w, --with EXE[,...]  replace first word of commands with these executables
  -n, --iterations=N    run each test this many times [default: 1]
  -N, --cycles=N        run the whole suite this many times [default: 1]
  -p, --precision=N     show times with this many decimal places [default: 2]
  -v, --verbose         show commands being run
  -V, --more-verbose    show command output
      --debug           show debug output for this program
  -h, --help            show this help
|]
-- CLI help. When changing this, remember to sync:
-- quickbench.cabal
-- README.md
-- quickbench.1.md
-- unknown option checking below
-- Just assumptions below, if changing [default] annotations.
-- Try to avoid writing the same thing different ways in all of these places.

defaultFile :: FilePath
defaultFile :: [Char]
defaultFile = [Char]
"bench.sh"

data Opts = Opts {
   Opts -> Maybe [Char]
file        :: Maybe FilePath
  ,Opts -> [[Char]]
executables :: [String]
  ,Opts -> Size
iterations  :: Int
  ,Opts -> Size
cycles      :: Int
  ,Opts -> Size
precision   :: Int
  ,Opts -> Bool
verbose     :: Bool
  ,Opts -> Bool
moreVerbose :: Bool
  ,Opts -> Bool
debug       :: Bool
  ,Opts -> Bool
help        :: Bool
  ,Opts -> [[Char]]
clicmds     :: [String]
} deriving (Size -> Opts -> ShowS
[Opts] -> ShowS
Opts -> [Char]
(Size -> Opts -> ShowS)
-> (Opts -> [Char]) -> ([Opts] -> ShowS) -> Show Opts
forall a.
(Size -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Opts] -> ShowS
$cshowList :: [Opts] -> ShowS
show :: Opts -> [Char]
$cshow :: Opts -> [Char]
showsPrec :: Size -> Opts -> ShowS
$cshowsPrec :: Size -> Opts -> ShowS
Show)

getOpts :: IO Opts
getOpts :: IO Opts
getOpts = do
  Arguments
dopts <- Docopt -> [[Char]] -> IO Arguments
parseArgsOrExit Docopt
docoptpatterns ([[Char]] -> IO Arguments) -> IO [[Char]] -> IO Arguments
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [[Char]]
getArgs
  let
    flag :: [Char] -> Bool
flag [Char]
f   = Arguments
dopts Arguments -> Option -> Bool
`isPresent` [Char] -> Option
longOption [Char]
f
    option :: [Char] -> Maybe [Char]
option [Char]
f = Arguments
dopts Arguments -> Option -> Maybe [Char]
`getArg` [Char] -> Option
longOption [Char]
f
    readint :: [Char] -> m a
readint [Char]
s =
      case [Char] -> Maybe a
forall a. Read a => [Char] -> Maybe a
readMay [Char]
s of
        Just a
a  -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
        Maybe a
Nothing -> [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m a) -> [Char] -> m a
forall a b. (a -> b) -> a -> b
$ [Char]
"could not read " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> [Char]
show [Char]
s [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" as an integer"
    ([[Char]]
lateflags,[[Char]]
args) = ([Char] -> Bool) -> [[Char]] -> ([[Char]], [[Char]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ([Char]
"-" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([[Char]] -> ([[Char]], [[Char]]))
-> [[Char]] -> ([[Char]], [[Char]])
forall a b. (a -> b) -> a -> b
$ Arguments
dopts Arguments -> Option -> [[Char]]
`getAllArgs` ([Char] -> Option
argument [Char]
"cmd")
  Size
iterations' <- [Char] -> IO Size
forall a (m :: * -> *). (Read a, MonadFail m) => [Char] -> m a
readint ([Char] -> IO Size) -> [Char] -> IO Size
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> [Char]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
option [Char]
"iterations" -- fromJust safe because of [default:] above
  Size
cycles'     <- [Char] -> IO Size
forall a (m :: * -> *). (Read a, MonadFail m) => [Char] -> m a
readint ([Char] -> IO Size) -> [Char] -> IO Size
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> [Char]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
option [Char]
"cycles"
  Size
precision'  <- [Char] -> IO Size
forall a (m :: * -> *). (Read a, MonadFail m) => [Char] -> m a
readint ([Char] -> IO Size) -> [Char] -> IO Size
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> [Char]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
option [Char]
"precision"
  let
    opts :: Opts
opts = Opts :: Maybe [Char]
-> [[Char]]
-> Size
-> Size
-> Size
-> Bool
-> Bool
-> Bool
-> Bool
-> [[Char]]
-> Opts
Opts {
       file :: Maybe [Char]
file        = [Char] -> Maybe [Char]
option [Char]
"file"
      ,executables :: [[Char]]
executables = [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([Char] -> [Char] -> [[Char]]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [Char]
",") (Maybe [Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
option [Char]
"with"
      ,iterations :: Size
iterations  = Size
iterations'
      ,cycles :: Size
cycles      = Size
cycles'
      ,precision :: Size
precision   = Size
precision'
      ,verbose :: Bool
verbose     = [Char] -> Bool
flag [Char]
"verbose"
      ,moreVerbose :: Bool
moreVerbose = [Char] -> Bool
flag [Char]
"more-verbose"
      ,debug :: Bool
debug       = [Char] -> Bool
flag [Char]
"debug"
      ,help :: Bool
help        = [Char] -> Bool
flag [Char]
"help"
      ,clicmds :: [[Char]]
clicmds     = [[Char]]
args
      }
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Opts -> Bool
debug Opts
opts Bool -> Bool -> Bool
|| [Char]
"--debug" [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
lateflags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Char] -> IO ()
err ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"docopts: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Arguments -> [Char]
forall a. Show a => a -> [Char]
ppShow Arguments
dopts [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Opts -> [Char]
forall a. Show a => a -> [Char]
ppShow Opts
opts [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Opts -> Bool
help Opts
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn (Docopt -> [Char]
usage Docopt
docoptpatterns) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess
  -- try to report some errors docopts misses
  case ([[Char]]
lateflags, [[Char]]
args) of
    -- unknown option
    -- quickbench a -fk       user error (unknown option: "fk")
    -- (f:_,[]) | not $ elem f [
    --    "file","f"
    --   ,"with","w"
    --   ,"iterations","n"
    --   ,"cycles","N"
    --   ,"precision","p"
    --   ,"verbose","v"
    --   ,"more-verbose","V"
    --   ] -> fail $ printf "unknown option: %s" (show f)
    -- option value missing
    ([Char]
f:[[Char]]
_,[]) -> [Char] -> IO ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ShowS
forall r. PrintfType r => [Char] -> r
printf [Char]
"option %s needs a value or is unknown" (ShowS
forall a. Show a => a -> [Char]
show [Char]
f)
    -- option following arguments
    ([Char]
f:[[Char]]
_,[Char]
a:[[Char]]
_) -> [Char] -> IO ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> ShowS
forall r. PrintfType r => [Char] -> r
printf [Char]
"option %s should appear before argument %s or is unknown" (ShowS
forall a. Show a => a -> [Char]
show [Char]
f) (ShowS
forall a. Show a => a -> [Char]
show [Char]
a)
    ([[Char]], [[Char]])
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Opts -> IO Opts
forall (m :: * -> *) a. Monad m => a -> m a
return Opts
opts

-- | Run the quickbench program, returning an error message if there was a problem.
defaultMain :: IO (Maybe String)
defaultMain :: IO (Maybe [Char])
defaultMain =
  (IO ()
runSuite IO () -> IO (Maybe [Char]) -> IO (Maybe [Char])
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe [Char] -> IO (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
forall a. Maybe a
Nothing)
    IO (Maybe [Char])
-> (SomeException -> IO (Maybe [Char])) -> IO (Maybe [Char])
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) -> Maybe [Char] -> IO (Maybe [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> IO (Maybe [Char]))
-> Maybe [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$
      if SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e Maybe ExitCode -> Maybe ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode -> Maybe ExitCode
forall a. a -> Maybe a
Just ExitCode
ExitSuccess
      then Maybe [Char]
forall a. Maybe a
Nothing
      else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e
  where
    runSuite :: IO ()
runSuite = do
      Opts
opts <- IO Opts
getOpts
      [[Char]]
filecmds <-
        (([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
istest ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
lines) ([Char] -> [[Char]]) -> IO [Char] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (case (Opts -> Maybe [Char]
file Opts
opts, Opts -> [[Char]]
clicmds Opts
opts) of
          (Just [Char]
"-", [[Char]]
_) -> IO [Char]
getContents
          (Just [Char]
f, [[Char]]
_)   -> [Char] -> IO [Char]
readFile [Char]
f
          (Maybe [Char]
Nothing, []) -> [Char] -> IO Bool
doesFileExist [Char]
defaultFile IO Bool -> (Bool -> IO [Char]) -> IO [Char]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            \Bool
yes -> if Bool
yes then [Char] -> IO [Char]
readFile [Char]
defaultFile else [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
""
          (Maybe [Char]
Nothing, [[Char]]
_)  -> [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [])
      let cmds :: [[Char]]
cmds = [[Char]]
filecmds [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ Opts -> [[Char]]
clicmds Opts
opts
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
cmds) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Opts -> [Char] -> IO ()
out Opts
opts [Char]
"No test commands found; provide some as arguments, with -f, or in ./bench.sh\n"
        IO ()
forall a. IO a
exitSuccess
      ZonedTime
now <- IO ZonedTime
getCurrentZonedTime
      Opts -> [Char] -> IO ()
out Opts
opts ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Size -> Size -> [Char] -> ShowS
forall r. PrintfType r => [Char] -> r
printf [Char]
"Running %d tests %d times%s at %s:\n"
        ([[Char]] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [[Char]]
cmds)
        (Opts -> Size
iterations Opts
opts)
        (case Opts -> [[Char]]
executables Opts
opts of
          [] -> [Char]
""
          [[Char]]
es -> [Char] -> Size -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
" with %d executables" ([[Char]] -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [[Char]]
es))
        (TimeLocale -> [Char] -> ZonedTime -> [Char]
forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale [Char]
"%Y-%m-%d %T %Z" ZonedTime
now)
      let
        exes :: [[Char]]
exes = case Opts -> [[Char]]
executables Opts
opts of
          [] -> [[Char]
""]
          [[Char]]
es -> [[Char]]
es
      Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
NoBuffering
      [Size] -> (Size -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Size
1..Opts -> Size
cycles Opts
opts] ((Size -> IO ()) -> IO ()) -> (Size -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Size
cyc -> do
        [[[Float]]]
results <- ([Char] -> IO [[Float]]) -> [[Char]] -> IO [[[Float]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Opts -> [[Char]] -> [Char] -> IO [[Float]]
runTestWithExes Opts
opts [[Char]]
exes) [[Char]]
cmds
        Opts -> [[Char]] -> [[Char]] -> Size -> [[[Float]]] -> IO ()
printSummary Opts
opts [[Char]]
cmds [[Char]]
exes Size
cyc [[[Float]]]
results

getCurrentZonedTime :: IO ZonedTime
getCurrentZonedTime :: IO ZonedTime
getCurrentZonedTime = do
  UTCTime
t <- IO UTCTime
getCurrentTime
  TimeZone
tz <- IO TimeZone
getCurrentTimeZone
  ZonedTime -> IO ZonedTime
forall (m :: * -> *) a. Monad m => a -> m a
return (ZonedTime -> IO ZonedTime) -> ZonedTime -> IO ZonedTime
forall a b. (a -> b) -> a -> b
$ TimeZone -> UTCTime -> ZonedTime
utcToZonedTime TimeZone
tz UTCTime
t

runTestWithExes :: Opts -> [String] -> String -> IO [[Float]]
runTestWithExes :: Opts -> [[Char]] -> [Char] -> IO [[Float]]
runTestWithExes Opts
opts [[Char]]
exes [Char]
cmd = ([Char] -> IO [Float]) -> [[Char]] -> IO [[Float]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Opts -> [Char] -> [Char] -> IO [Float]
runTestWithExe Opts
opts [Char]
cmd) [[Char]]
exes

runTestWithExe :: Opts -> String -> String -> IO [Float]
runTestWithExe :: Opts -> [Char] -> [Char] -> IO [Float]
runTestWithExe Opts
opts [Char]
cmd [Char]
exe = (Size -> IO Float) -> [Size] -> IO [Float]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Opts -> [Char] -> [Char] -> Size -> IO Float
runTestOnce Opts
opts [Char]
cmd [Char]
exe) [Size
1..Opts -> Size
iterations Opts
opts]

runTestOnce :: Opts -> String -> String -> Int -> IO Float
runTestOnce :: Opts -> [Char] -> [Char] -> Size -> IO Float
runTestOnce Opts
opts [Char]
cmd [Char]
exe Size
iteration = do
  let ([Char]
cmd',[Char]
exe',[[Char]]
args) = [Char] -> [Char] -> ([Char], [Char], [[Char]])
replaceExecutable [Char]
exe [Char]
cmd
  Opts -> [Char] -> IO ()
dbg Opts
opts ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> ShowS
forall r. PrintfType r => [Char] -> r
printf [Char]
"replaceExecutable: %s -> %s\n" (([Char], [Char]) -> [Char]
forall a. Show a => a -> [Char]
show ([Char]
cmd,[Char]
exe)) (([Char], [Char], [[Char]]) -> [Char]
forall a. Show a => a -> [Char]
show ([Char]
cmd',[Char]
exe',[[Char]]
args))
  Opts -> [Char] -> IO ()
outv Opts
opts (Size -> [Char]
forall a. Show a => a -> [Char]
show Size
iteration [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
cmd' [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n")
  Float
t <- Opts -> [Char] -> [[Char]] -> IO Float
time Opts
opts [Char]
exe' [[Char]]
args
  Opts -> [Char] -> IO ()
outv Opts
opts ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ShowS
forall r. PrintfType r => [Char] -> r
printf [Char]
"\t[%ss]\n" (Opts -> Float -> [Char]
showtime Opts
opts Float
t)
  Float -> IO Float
forall (m :: * -> *) a. Monad m => a -> m a
return Float
t

-- | Replace a command's first word with the specified executable.
-- If the executable is empty, the command remains unchanged.
-- If the command is empty, the executable becomes the command.
-- Return the new command string, executable, and arguments.
replaceExecutable :: String -> String -> (String,String,[String])
replaceExecutable :: [Char] -> [Char] -> ([Char], [Char], [[Char]])
replaceExecutable [Char]
exe [Char]
""  = ([Char]
exe, [Char]
exe, [])
replaceExecutable [Char]
""  [Char]
cmd = ([Char]
cmd, [Char]
w, [[Char]]
ws) where [Char]
w:[[Char]]
ws = [Char] -> [[Char]]
words ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ShowS
clean [Char]
cmd
replaceExecutable [Char]
exe [Char]
cmd = ([[Char]] -> [Char]
unwords ([Char]
exe[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[[Char]]
args), [Char]
exe, [[Char]]
args) where args :: [[Char]]
args = Size -> [[Char]] -> [[Char]]
forall a. Size -> [a] -> [a]
drop Size
1 ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
words ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ShowS
clean [Char]
cmd
  -- XXX might display wrong quoting here

time :: Opts -> String -> [String] -> IO Float
time :: Opts -> [Char] -> [[Char]] -> IO Float
time Opts
opts [Char]
exe [[Char]]
args = do
  UTCTime
t1 <- IO UTCTime
getCurrentTime
  (ExitCode
c, [Char]
o, [Char]
e) <- [Char] -> [[Char]] -> [Char] -> IO (ExitCode, [Char], [Char])
readProcessWithExitCode' [Char]
exe [[Char]]
args [Char]
""
  UTCTime
t2 <- IO UTCTime
getCurrentTime
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
o) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Opts -> [Char] -> IO ()
outvv Opts
opts ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ (if Opts -> Bool
verbose Opts
opts then [Char]
"\n" else [Char]
"") [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
o
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExitCode
c ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Opts -> [Char] -> IO ()
out Opts
opts ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
" (error: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
clean [Char]
e [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
") "
  Float -> IO Float
forall (m :: * -> *) a. Monad m => a -> m a
return (Float -> IO Float) -> Float -> IO Float
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (NominalDiffTime -> Float) -> NominalDiffTime -> Float
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t2 UTCTime
t1

-- ^ This variant also returns a failure when the executable is missing.
readProcessWithExitCode' :: FilePath -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode' :: [Char] -> [[Char]] -> [Char] -> IO (ExitCode, [Char], [Char])
readProcessWithExitCode' [Char]
exe [[Char]]
args [Char]
inp =
  [Char] -> [[Char]] -> [Char] -> IO (ExitCode, [Char], [Char])
readProcessWithExitCode [Char]
exe [[Char]]
args [Char]
inp
    IO (ExitCode, [Char], [Char])
-> (IOException -> IO (ExitCode, [Char], [Char]))
-> IO (ExitCode, [Char], [Char])
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) -> (ExitCode, [Char], [Char]) -> IO (ExitCode, [Char], [Char])
forall (m :: * -> *) a. Monad m => a -> m a
return (Size -> ExitCode
ExitFailure Size
1, [Char]
"", IOException -> [Char]
forall a. Show a => a -> [Char]
show IOException
e)

printSummary :: Opts -> [String] -> [String] -> Int -> [[[Float]]] -> IO ()
printSummary :: Opts -> [[Char]] -> [[Char]] -> Size -> [[[Float]]] -> IO ()
printSummary Opts
opts [[Char]]
cmds [[Char]]
exes Size
cyc [[[Float]]]
results = do
  Opts -> [Char] -> IO ()
out Opts
opts ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ShowS
forall r. PrintfType r => [Char] -> r
printf [Char]
"\nBest times%s:\n" (if Opts -> Size
cycles Opts
opts Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
1 then [Char]
" "[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++Size -> [Char]
forall a. Show a => a -> [Char]
show Size
cyc else [Char]
"")
  let t :: Table [Char] [Char] [Char]
t = Opts
-> [[Char]]
-> [[Char]]
-> [[[Float]]]
-> Table [Char] [Char] [Char]
maketable Opts
opts [[Char]]
cmds' [[Char]]
exes [[[Float]]]
results
  Opts -> [Char] -> IO ()
out Opts
opts ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS -> ShowS -> ShowS -> Table [Char] [Char] [Char] -> [Char]
forall rh ch a.
(rh -> [Char])
-> (ch -> [Char]) -> (a -> [Char]) -> Table rh ch a -> [Char]
TA.render ShowS
forall a. a -> a
id ShowS
forall a. a -> a
id ShowS
forall a. a -> a
id Table [Char] [Char] [Char]
t
  -- let outname = "benchresults"
  -- writeFile (outname <.> "txt") $ TA.render id id id t
  -- writeFile (outname <.> "html") $ renderHtml $ TH.css TH.defaultCss +++ TH.render stringToHtml stringToHtml stringToHtml t
  where
    cmds' :: [[Char]]
cmds' =
      case Opts -> [[Char]]
executables Opts
opts of
        []  -> [[Char]]
cmds
        [[Char]
e] -> [[Char]
c | ([Char]
c,[Char]
_,[[Char]]
_) <- ([Char] -> ([Char], [Char], [[Char]]))
-> [[Char]] -> [([Char], [Char], [[Char]])]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char] -> ([Char], [Char], [[Char]])
replaceExecutable [Char]
e) [[Char]]
cmds]
        [[Char]]
_   -> ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([[Char]] -> [Char]
unwords ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size -> [[Char]] -> [[Char]]
forall a. Size -> [a] -> [a]
drop Size
1 ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
words) [[Char]]
cmds

maketable :: Opts -> [String] -> [String] -> [[[Float]]] -> Table String String String
maketable :: Opts
-> [[Char]]
-> [[Char]]
-> [[[Float]]]
-> Table [Char] [Char] [Char]
maketable Opts
opts [[Char]]
rownames [[Char]]
colnames [[[Float]]]
results = Header [Char]
-> Header [Char] -> [[[Char]]] -> Table [Char] [Char] [Char]
forall rh ch a. Header rh -> Header ch -> [[a]] -> Table rh ch a
Table Header [Char]
rowhdrs Header [Char]
colhdrs [[[Char]]]
rows
 where
  rowhdrs :: Header [Char]
rowhdrs = Properties -> [Header [Char]] -> Header [Char]
forall h. Properties -> [Header h] -> Header h
Group Properties
NoLine ([Header [Char]] -> Header [Char])
-> [Header [Char]] -> Header [Char]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Header [Char]) -> [[Char]] -> [Header [Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Header [Char]
forall h. h -> Header h
Header ([[Char]] -> [Header [Char]]) -> [[Char]] -> [Header [Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
forall (t :: * -> *) a b.
(PrintfArg (t a), PrintfType b, Foldable t) =>
[t a] -> [b]
padright [[Char]]
rownames
  colhdrs :: Header [Char]
colhdrs = Properties -> [Header [Char]] -> Header [Char]
forall h. Properties -> [Header h] -> Header h
Group Properties
SingleLine ([Header [Char]] -> Header [Char])
-> [Header [Char]] -> Header [Char]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Header [Char]) -> [[Char]] -> [Header [Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Header [Char]
forall h. h -> Header h
Header [[Char]]
colnames
  rows :: [[[Char]]]
rows = ([[Float]] -> [[Char]]) -> [[[Float]]] -> [[[Char]]]
forall a b. (a -> b) -> [a] -> [b]
map (([Float] -> [Char]) -> [[Float]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Opts -> Float -> [Char]
showtime Opts
opts (Float -> [Char]) -> ([Float] -> Float) -> [Float] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum)) [[[Float]]]
results
  padright :: [t a] -> [b]
padright [t a]
ss = (t a -> b) -> [t a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> t a -> b
forall r. PrintfType r => [Char] -> r
printf ([Char] -> Size -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%%-%ds" Size
w)) [t a]
ss
      where w :: Size
w = [Size] -> Size
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Size] -> Size) -> [Size] -> Size
forall a b. (a -> b) -> a -> b
$ (t a -> Size) -> [t a] -> [Size]
forall a b. (a -> b) -> [a] -> [b]
map t a -> Size
forall (t :: * -> *) a. Foldable t => t a -> Size
length [t a]
ss

showtime :: Opts -> (Float -> String)
showtime :: Opts -> Float -> [Char]
showtime Opts
opts = [Char] -> Float -> [Char]
forall r. PrintfType r => [Char] -> r
printf ([Char] -> Float -> [Char]) -> [Char] -> Float -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"%." [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Size -> [Char]
forall a. Show a => a -> [Char]
show (Opts -> Size
precision Opts
opts) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"f"

istest :: String -> Bool
istest :: [Char] -> Bool
istest [Char]
s = Bool -> Bool
not ([Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
s' Bool -> Bool -> Bool
|| ([Char]
"#" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
s')) where s' :: [Char]
s' = ShowS
clean [Char]
s

clean :: String -> String
clean :: ShowS
clean = [[Char]] -> [Char]
unwords ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
words

out :: Opts -> String -> IO ()
out :: Opts -> [Char] -> IO ()
out Opts
_ = [Char] -> IO ()
putStr

outv :: Opts -> String -> IO ()
outv :: Opts -> [Char] -> IO ()
outv Opts
opts [Char]
s = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Opts -> Bool
verbose Opts
opts Bool -> Bool -> Bool
|| Opts -> Bool
moreVerbose Opts
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStr [Char]
s

outvv :: Opts -> String -> IO ()
outvv :: Opts -> [Char] -> IO ()
outvv Opts
opts [Char]
s = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Opts -> Bool
moreVerbose Opts
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStr [Char]
s

err :: String -> IO ()
err :: [Char] -> IO ()
err = Handle -> [Char] -> IO ()
hPutStr Handle
stderr

dbg :: Opts -> String -> IO ()
dbg :: Opts -> [Char] -> IO ()
dbg Opts
opts [Char]
s = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Opts -> Bool
debug Opts
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
err [Char]
s