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
Generated by git2html.