mlspec-bench: 6fc6af4f0a7058ae3d84a0de14494653e60345db

     1: {-# LANGUAGE OverloadedStrings #-}
     2: 
     3: module MLSpec.Bench where
     4: 
     5: import Control.Exception
     6: import Criterion.Main
     7: import Data.Char
     8: import Data.List
     9: import Paths_mlspec_bench
    10: import System.Directory
    11: import System.Environment
    12: import System.Exit
    13: import System.IO
    14: import System.Process
    15: 
    16: -- Register benchmarks
    17: 
    18: benchMain = do cmd   <- getEnv "BENCHMARK_COMMAND"
    19:                hPutStrLn stderr ("Got command " ++ show cmd)
    20:                args  <- fmap readArgs (lookupEnv "BENCHMARK_ARGS")
    21:                hPutStrLn stderr ("Got args " ++ show args)
    22:                input <- getContents
    23:                defaultMain [
    24:                    bgroup "command" [mkBench (proc cmd args) input]
    25:                  ]
    26: 
    27: mkBench :: CreateProcess -> String -> Benchmark
    28: mkBench cmd stdin = Criterion.Main.env (inputs cmd stdin) go
    29:   where go stdio = bench ("Running " ++ renderCmd cmd)
    30:                          (nfIO (run cmd stdio))
    31: 
    32: -- Functions to benchmark
    33: 
    34: {-# ANN run ("HLint: ignore Use putStr" :: String) #-}
    35: run :: CreateProcess -> Input -> IO String
    36: run cmd (stdin, sout, serr) = do
    37:   stdout <- openFile sout AppendMode
    38:   stderr <- openFile serr AppendMode
    39:   (c, o, e) <- readCreateProcessWithExitCode cmd stdin
    40:   hPutStr stdout ("\n-----\n" ++ o)
    41:   hPutStr stderr ("\n-----\n" ++ e)
    42:   hClose stdout
    43:   hClose stderr
    44:   case c of
    45:     ExitSuccess   -> return ()
    46:     ExitFailure i -> error (renderCmd cmd ++ " exited with code " ++ show i)
    47:   return o
    48: 
    49: -- Test data
    50: 
    51: type Deferred a = () -> a
    52: type Input = (String, FilePath, FilePath)
    53: 
    54: readArgs :: Maybe String -> [String]
    55: readArgs Nothing  = []
    56: readArgs (Just x) = read x
    57: 
    58: inputs :: CreateProcess -> String -> IO Input
    59: inputs cmd stdin = do (stdout, stderr) <- outputPaths cmd
    60:                       return (stdin, stdout, stderr)
    61: 
    62: outputPaths cmd = do Just d <- lookupEnv "BENCH_DIR"
    63:                      let out = open d "stdout"
    64:                          err = open d "stderr"
    65:                      return (out, err)
    66:   where open d x = d ++ "/outputs/" ++ hash cmd ++ "." ++ x
    67: 
    68: -- Helpers
    69: 
    70: renderCmd c = case cmdspec c of
    71:   RawCommand x xs -> show x ++ show xs
    72: 
    73: hash p = case cmdspec p of
    74:            RawCommand cmd args -> map keep (concat (cmd : args))
    75:   where keep c = if isAscii c && isAlphaNum c then c else '_'
    76: 
    77: err :: (Show a) => a -> IO ()
    78: err = hPrint stderr