maybench (empty) → 0.1
raw patch · 8 files changed
+666/−0 lines, 8 filesdep +basedep +directorydep +filepathsetup-changed
Dependencies added: base, directory, filepath, mtl, old-time, process, time, unix
Files
- LICENSE +27/−0
- Setup.lhs +4/−0
- Test/Maybench.hs +111/−0
- Test/Maybench/Command.hs +55/−0
- Test/Maybench/Utils.hs +30/−0
- darcs-benchmark/DarcsBenchmark.hs +334/−0
- maybench.cabal +57/−0
- wrapper/Maybench.hs +48/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2008, Maybench developers++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.+ * Neither the name of the Maybench developers nor the names of its+ contributors may be used to endorse or promote products derived from this+ software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ Test/Maybench.hs view
@@ -0,0 +1,111 @@+module Test.Maybench where++import System.Time+import System.Cmd (system) -- ideally this should use System.Process in the future, but for the sake of a first version this will do.+import Data.Maybe (maybe, isJust, fromJust)+import Control.Monad (when,replicateM)+import Control.Monad.State (MonadIO, liftIO)+import System.Directory (findExecutable)+import System.IO (putStr,hPutStr,hClose,hGetContents)+import System.Process (waitForProcess, runInteractiveProcess)++import Test.Maybench.Command (CommandModifier, Command(Cmd), modifyCmd)++data Benchmark = Benchmark {benchIters :: Int, benchTimes :: [TimeDiff]}++run :: MonadIO m => CommandModifier m -> m (String, String)+run cmd = modifyCmd cmd >>= (\m -> runC $ m (Cmd "" [] ""))++runC :: MonadIO m => Command -> m (String, String)+runC (Cmd exe' args input) = liftIO $ do+ exe <- findExecutable exe' >>= maybe (fail $ "cannot find " ++ exe') return+ putStr "Running... "+ let cmd_str = unwords $ map showSh (exe:args)+ putStrLn cmd_str+ (output, err) <- runProcessWithInput exe args input+ return (output, err)+ where showSh x | ' ' `elem` x = show x+ | otherwise = x++runProcessWithInput :: FilePath -> [String] -> String -> IO (String, String)+runProcessWithInput cmd args input = do+ (pin, pout, perr, ph) <- runInteractiveProcess cmd args Nothing Nothing+ hPutStr pin input+ hClose pin+ output <- hGetContents pout+ when (output==output) $ return ()+ err <- hGetContents perr+ when (err==err) $ return ()+ hClose pout+ hClose perr+ waitForProcess ph -- should check exit code here...+ return (output, err)++bench :: Maybe (IO a) -- ^ setup+ -> IO b -- ^ action+ -> Maybe (IO c) -- ^ cleanup+ -> Int -- ^ iterations+ -> IO Benchmark+bench setup action cleanup reps = do times <- replicateM reps core+ return $ Benchmark reps times+ where core = do maybe (return ()) (>> return ()) setup+ start <- getClockTime+ action+ end <- getClockTime+ maybe (return ()) (>> return ()) cleanup+ return $ end `diffClockTimes` start++benchSimple :: IO a -> Int -> IO Benchmark+benchSimple f = bench Nothing f Nothing++timeProgram :: String -> String -> String -> IO (String, TimeDiff)+timeProgram cmd setup cleanup = do time <- bench (Just $ system setup) (system cmd) (Just $ system cleanup) 1+ return $ (cmd,averageTimeDiffs $ benchTimes time)++averageTimeDiffs :: [TimeDiff] -> TimeDiff+averageTimeDiffs = secondsToTimeDiff . mean . map timeDiffToSeconds+ where mean xs = sum xs `div` length xs++averageTime :: String -> String -> String -> Int -> IO (String, TimeDiff)+averageTime cmd setup cleanup n = do times <- replicateM n (timeProgram cmd setup cleanup)+ return (cmd,averageTimeDiffs (map snd times))++showTimeDiff :: (String, TimeDiff) -> String+showTimeDiff (cmd,td) = case filter isJust [helper tdYear "years",+ helper tdMonth "months",+ helper tdDay "days",+ helper tdHour "hours",+ helper tdMin "minutes",+ helper tdSec "seconds"]+ of [] -> (show cmd) ++ " took less than a second."+ xs -> (((show cmd) ++ " took ") ++) . intercalate ", " . map fromJust $ xs+ where helper accessor string = if accessor td > 0+ then (Just (show (accessor td) ++ " " ++ string))+ else Nothing+ intercalate _ [] = []+ intercalate x (y:ys) = y++x++intercalate x ys++printTimeDiff :: (String, TimeDiff) -> IO ()+printTimeDiff = putStrLn . showTimeDiff++minute, hour, day, month, year :: Int+minute = 60+hour = minute * 60+day = hour * 24+month = day * 30+year = day * 365++timeDiffToSeconds :: TimeDiff -> Int+timeDiffToSeconds td = tdSec td + (tdMin td) * minute + (tdHour td) * hour + (tdDay td) * day + (tdMonth td) * month + (tdYear td) * year++secondsToTimeDiff :: Int -> TimeDiff+secondsToTimeDiff sec = normalizeTimeDiff $ TimeDiff 0 0 0 0 0 sec 0++compareTimes :: (String, TimeDiff) -> (String, TimeDiff) -> Maybe String+compareTimes (cmd1,td1) (cmd2,td2) = case (td1,td2) of+ (TimeDiff 0 0 0 0 0 0 _,+ TimeDiff 0 0 0 0 0 0 _) -> Nothing+ _ -> Just $ show cmd2 ++ " took " +++ (show ((fromIntegral $ timeDiffToSeconds td2) `percentage` (fromIntegral $ timeDiffToSeconds td1) :: Double))+ ++ "% of the time " ++ show cmd1 ++ " took."+ where percentage x y = (fromIntegral $ (truncate $ (x / y * 10000 :: Double) :: Int)) / 100
+ Test/Maybench/Command.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE GADTs, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-}+module Test.Maybench.Command where++import Test.Maybench.Utils ((|>))++infixl 5 <@>++data Command = Cmd { cmdName :: String, cmdArgs :: [String], cmdInput :: String }++updateCmdName :: (String -> String) -> (Command -> Command)+updateCmdName f c = c { cmdName = f $ cmdName c }++updateCmdInput :: (String -> String) -> (Command -> Command)+updateCmdInput f c = c { cmdInput = f $ cmdInput c }++updateCmdArgs :: ([String] -> [String]) -> (Command -> Command)+updateCmdArgs f c = c { cmdArgs = f $ cmdArgs c }++addArg :: String -> (Command -> Command)+addArg arg = updateCmdArgs (|> arg)++addArgs :: [String] -> (Command -> Command)+addArgs arg = updateCmdArgs (++ arg)++class Monad m => CommandModifierClass m mod where+ modifyCmd :: mod -> m (Command -> Command)++data CommandModifier m where+ Nop :: CommandModifier m+ CmdMod :: (Monad m, CommandModifierClass m mod) => CommandModifier m -> mod -> CommandModifier m++(<@>) :: (Monad m, CommandModifierClass m mod) => CommandModifier m -> mod -> CommandModifier m+(<@>) = CmdMod++instance Monad m => CommandModifierClass m (CommandModifier m) where+ modifyCmd Nop = return id+ modifyCmd (CmdMod f g) = do+ f' <- modifyCmd f+ g' <- modifyCmd g+ return (g' . f')++{-+instance CommandModifierClass mod => CommandModifierClass [mod] where+ modifyCmd [] = id+ modifyCmd (mod:mods) = modifyCmd mod . modifyCmd mods+-}++instance Monad m => CommandModifierClass m String where+ modifyCmd = return . addArg++instance Monad m => CommandModifierClass m [String] where+ modifyCmd = return . addArgs++instance Monad m => CommandModifierClass m Command where+ modifyCmd = return . const
+ Test/Maybench/Utils.hs view
@@ -0,0 +1,30 @@+module Test.Maybench.Utils where++import Data.Monoid (Monoid,mappend)++infixr 5 <|+infixl 5 |>++class ConsLeft f where+ (<|) :: a -> f a -> f a++class ConsRight f where+ (|>) :: f a -> a -> f a++instance ConsLeft [] where+ (<|) = (:)++instance ConsRight [] where+ xs |> x = xs ++ [x]++infix 5 <++>+(<++>) :: Monoid a => a -> a -> a+(<++>) = mappend++list :: b -> (a -> [a] -> b) -> [a] -> b+list nil _ [] = nil+list _ cons (x:xs) = cons x xs++fromList :: a -> [a] -> a+fromList _ [x] = x+fromList def _ = def
+ darcs-benchmark/DarcsBenchmark.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+import Prelude hiding (foldr, foldl, foldr1, foldl1)+import Control.Arrow (second)+import Control.Monad ()+import Control.Monad.Reader+import Control.Monad.State+import Control.Applicative+import Data.List (isInfixOf,find)+import Data.Maybe (fromMaybe, listToMaybe)+import Data.Time.Clock (getCurrentTime,diffUTCTime)+import System.FilePath ((</>))+import System.Directory (createDirectory, setCurrentDirectory, removeDirectoryRecursive,+ getTemporaryDirectory, getCurrentDirectory )+import System.IO (hPutStrLn,stderr)+import System.Environment (getArgs)+import System.Posix (fileExist)+import System.Console.GetOpt++import Test.Maybench (run)+import Test.Maybench.Command (Command(..), CommandModifier(..), CommandModifierClass, modifyCmd, (<@>),+ updateCmdInput, addArgs)+import Test.Maybench.Utils (fromList)++data Counts = Counts+ { allPatches :: Int+ , manyPatches :: Int+ , somePatches :: Int+ }++data BenchConf = BenchConf+ { benchUrlRepo :: String+ , benchCounts :: Counts+ , interactive :: Bool+ , darcsExecutable :: String+ }++data BenchState = BenchState+ { benchDirRepo :: String+ }++newtype BenchM a = BenchM { benchM :: ReaderT BenchConf (StateT BenchState IO) a }+ deriving (Functor, Monad, MonadIO, MonadReader BenchConf, MonadState BenchState)++type DarcsCmd = CommandModifier BenchM++runD :: DarcsCmd -> BenchM (String, String)+runD cmd = do+ dir <- gets benchDirRepo+ run $ cmd <@> RepoDir dir++-- doing a lot of replaces finally slow down++data DarcsCommand = DarcsCommand { _darcsCmd :: String, _darcsSubCmds :: [String] }++instance CommandModifierClass BenchM DarcsCommand where+ modifyCmd (DarcsCommand cmd subCmds) = do+ exe <- asks darcsExecutable+ let reset (Cmd "" [] "") = Cmd exe (cmd:subCmds) ""+ reset _ = error "DarcsCommand: unexpected non empty command"+ return reset++data DarcsOpts = All+ | Confirmed -- ^ for that final 'are you sure' prompt+ | Last Int+ | RepoDir String+ | IgnoreTimes+ | NoTest+ | Quiet+ | Author String+ | Message String+ | RTS String+ | Arbitrary [String]++instance CommandModifierClass BenchM DarcsOpts where+ modifyCmd Confirmed = return $ updateCmdInput (++ "y")++ modifyCmd All = do+ b <- asks interactive+ return $+ if b then+ updateCmdInput ('a':)+ else+ addArgs ["--all"]++ modifyCmd (Last n) = do+ b <- asks interactive+ return $+ if b then+ updateCmdInput ((replicate n 'y' ++) . ('d' :))+ else+ addArgs ["--last", show n]++ modifyCmd (RepoDir d) = return $ addArgs ["--repodir", d]+ modifyCmd IgnoreTimes = return $ addArgs ["--ignore-times"]+ modifyCmd NoTest = return $ addArgs ["--no-test"]+ modifyCmd Quiet = return $ addArgs ["--quiet"]+ modifyCmd (Author a) = return $ addArgs ["--author", a]+ modifyCmd (Message m) = return $ addArgs ["-m", m]+ -- not darcs flags+ modifyCmd (RTS x) = return $ addArgs ["+RTS", x, "-RTS"]+ modifyCmd (Arbitrary x) = return $ addArgs x++darcs :: String -> [String] -> DarcsCmd+darcs cmd subCmds = Nop <@> DarcsCommand cmd subCmds <@> Quiet <@> RTS "-tstderr"++darcs_unrecord, darcs_obliterate, darcs_record, darcs_add, darcs_get,+ darcs_pull, darcs_show_repo, darcs_init :: DarcsCmd++darcs_init = darcs "init" []+darcs_unrecord = darcs "unrecord" []+darcs_obliterate = darcs "obliterate" [] <@> IgnoreTimes+darcs_record = darcs "record" [] <@> IgnoreTimes <@> NoTest+darcs_show_repo = darcs "show" ["repo"]+darcs_add = darcs "add" []+darcs_get = darcs "get" []+darcs_pull = darcs "pull" []++data BenchResult = BR String String++instance Show BenchResult where+ show (BR k v) = k ++ ":" ++ v++bench :: String -> BenchM (String, String) -> BenchM String+bench title f = do+ start <- liftIO $ do+ putStrLn title+ getCurrentTime+ (out, err) <- f+ stop <- liftIO getCurrentTime+ let diff = diffUTCTime stop start+ (avgmem, maxmem) = grabMemStats err+ results = [ BR "time" (show diff)+ , BR "avgmem" avgmem+ , BR "maxmem" maxmem ]+ liftIO $ do putStr "bench stats "+ print results+ return out++-- | given a string like+--+-- <<ghc: 4317044 bytes, 9 GCs, 86016/86016 avg/max bytes residency (1+-- samples), 1M in use, 0.00 INIT (0.00 elapsed), 0.02 MUT (0.09 elapsed), 0.00+-- GC (0.00 elapsed) :ghc>>+--+-- return only the memory usage, so here 86016, 86016+grabMemStats :: String -> (String, String)+grabMemStats s =+ case (dropWhile (/= "GCs,") . words $ s) of+ (_:x:_) -> breakOn '/' x+ _ -> ("ERR","ERR")++-- | Split a string in two at and dropping @delim@+breakOn :: Char -- ^ delim+ -> String -> (String, String)+breakOn c = second (drop 1) . break (== c)++-- get+-- URL+-- last tag+-- medium tag+-- partial+-- format hashed/old-f++data RepoSize = RepoSize { duration :: Int,+ nfiles :: Int,+ filesize :: Int }++defaultRepoSize :: RepoSize+defaultRepoSize = RepoSize { duration = 100,+ nfiles = 100,+ filesize = 25 }++make_repo :: RepoSize -> String -> BenchM ()+make_repo sh name =+ do cwd <- liftIO $ getCurrentDirectory+ liftIO $ createDirectory name+ liftIO $ setCurrentDirectory name+ bench "darcs init" $ run $ darcs_init+ mapM_ (\n -> createFile ("file-"++show n) (filesize sh) n) [0..nfiles sh]+ bench "initial record" $ run $ darcs_record <@> All <@> Author "me" <@> Message "initial record"+ let modifyFiles seed = do mapM_ (\n -> modifyFile ("file-"++show n) (seed+n)) [0..nfiles sh]+ run $ darcs_record <@> All <@> Author "me" <@> Message ("change "++show seed)+ mapM_ modifyFiles [0..duration sh]+ liftIO $ setCurrentDirectory cwd+ return ()++createFile :: String -> Int -> Int -> BenchM ()+createFile f size seed = do liftIO $ writeFile f $ unlines x+ bench ("add "++f) $ run $ darcs_add <@> f+ return ()+ where x = map toline [0 .. size]+ toline n | n `mod` (seed+1) == 0 = ""+ | otherwise = "line "++ show n++modifyFile :: String -> Int -> BenchM ()+modifyFile _ seed | seed `mod` 10 /= 1 = return () -- only modify one in ten files+modifyFile f seed = do x <- liftIO $ readFile f+ liftIO $ (seq (length x) writeFile) f $ unlines $ modi seed $ lines x+ where modi 0 (_:ls) = modi seed ls+ modi 3 (l:ls) = l:('x':l): modi 2 ls+ modi 7 (l:ls) = ('y':l): modi 6 ls+ modi n (l:ls) = l : modi (n-1) ls+ modi _ [] = []++bench_unrecord_record :: BenchM ()+bench_unrecord_record =+ do bench "unrecord last 1" $ runD $ darcs_unrecord <@> Last 1 <@> All <@> Confirmed+ bench "record" $ runD $ darcs_record <@> All <@> Message "test patch" <@> Author "me"+ return ()++bench_obliterate_pull_last :: Int -> BenchM ()+bench_obliterate_pull_last n =+ do bench ("obliterate last "++show n) $+ runD $ darcs_obliterate <@> Last n <@> All <@> Confirmed+ bench ("pull "++show n) $ runD $ darcs_pull <@> All+ return ()++replicateBench :: (Int -> BenchM ()) -> BenchM ()+replicateBench m = do+ counts <- asks benchCounts+ m 1+ m $ somePatches counts+ m $ manyPatches counts++benchAll :: BenchM ()+benchAll = do+ bench_unrecord_record+ replicateBench bench_obliterate_pull_last++-- TODO+-- whatsnew+-- record+-- unrecord+-- amend-record+-- mark-conflicts+-- rollback++-- TODO: but these commands are not that problematic about performance+-- tag+-- unrevert+-- add+-- remove+-- mv+-- replace+-- setpref++runBenchM :: BenchConf -> BenchState -> BenchM a -> IO a+runBenchM conf state f = evalStateT (runReaderT (benchM f) conf) state++countPatches :: String -> BenchM Int+countPatches repo =+ (read . last . words . fromList (error "bad 'darcs show repo' output") .+ filter ("Num Patches:" `isInfixOf`) . lines . fst)+ <$> (run $ darcs_show_repo <@> RepoDir repo)++data Flag = DarcsFlag { darcsFlag :: String }+ | RepoFlag String+ | InteractiveFlag | HelpFlag+ deriving (Eq)++options :: [OptDescr Flag]+options =+ [Option ['h','?'] ["help"] (NoArg HelpFlag) "show this help message",+ Option ['i'] ["interactive"] (NoArg InteractiveFlag) "use the interactive mode of darcs",+ Option ['r'] ["repo"] (ReqArg RepoFlag "URL") "run on a specific repository",+ Option [] ["darcs"] (ReqArg DarcsFlag "COMMAND") "set the darcs command to use"]++usage :: [String] -> IO a+usage errs = do hPutStrLn stderr $ usageInfo header options+ hPutStrLn stderr dargs+ ioError $ userError $ concat errs+ where header = "Usage: " ++ me ++ " [OPTION...] [cmd [darcsarg...]]"+ dargs = "If you pass in a darcs command, maybench will ignore any flags and\n" +++ "just run darcs with the arguments specified.\n" +++ "If you pass in no arguments, maybench will run its own set of standard\n" +++ "darcs benchmarks."++me :: String+me = "darcs-benchmark"++ourBench :: Maybe String -> BenchConf -> IO ()+ourBench mUrl initBenchConf = do+ tmp <- getTemporaryDirectory+ let bench_dir = tmp </> me+ let main_repo = "main"+ let displayInfo url = liftIO $ do+ putStrLn ("bench directory: " ++ bench_dir)+ putStrLn ("origin repository: " ++ url)+ putStrLn ("main repository: " ++ main_repo)+ b <- fileExist bench_dir+ when b $ removeDirectoryRecursive bench_dir+ createDirectory bench_dir+ setCurrentDirectory bench_dir+ (url, count) <- runBenchM initBenchConf undefined $ do+ url <- case mUrl of+ Nothing -> do displayInfo "fresh"+ make_repo defaultRepoSize "fresh"+ return (bench_dir </> "fresh")+ Just r -> do displayInfo r+ return r+ bench "darcs get" $ run $ darcs_get <@> url <@> main_repo+ count <- countPatches main_repo+ return (url, count)+ let counts = Counts { allPatches = count+ , manyPatches = min (count `div` 3) 500+ , somePatches = min (count `div` 10) 50 }+ let benchConf = initBenchConf { benchUrlRepo = url+ , benchCounts = counts+ }+ runBenchM benchConf (BenchState main_repo) benchAll++main :: IO ()+main = do+ args <- getArgs+ (opts, d_args) <-+ case getOpt Permute options args of+ (o,n,[]) -> return (o,n)+ (_,_,errs) -> usage errs+ when (HelpFlag `elem` opts) $ usage []+ --+ let is_darcs_flag (DarcsFlag _) = True+ is_darcs_flag _ = False+ let initBenchConf = BenchConf { benchUrlRepo = undefined+ , benchCounts = undefined+ , interactive = InteractiveFlag `elem` opts+ , darcsExecutable = fromMaybe "darcs" $ darcsFlag <$> find is_darcs_flag opts+ }+ mUrl = listToMaybe [ f | RepoFlag f <- opts ]+ --+ case d_args of+ [] -> ourBench mUrl initBenchConf+ (c:das) -> runBenchM initBenchConf (BenchState "") $ do+ bench "arbitrary_command" $ run $ darcs c [] <@> Arbitrary das+ return ()
+ maybench.cabal view
@@ -0,0 +1,57 @@+Name: maybench+Version: 0.1+License: BSD3+License-file: LICENSE+Author: Maybench developers+Maintainer: <maybench-devel@googlegroups.com>++Category: Development+Synopsis: Automated benchmarking tool+Description: Maybench is a tool for comparing the performance+ between two versions of the same program, on a+ series of benchmarks that you design.+ .+ Maybench aims to be easy to use, almost as easy+ as running "time your-program arg1..arg2". Ideally,+ it should be a simple matter for outsiders to write+ timing tests for your programming project and contribute+ them as part of your performance testing suite.+ .+ The Darcs repository is available at <http://code.haskell.org/maybench>.+Homepage: http://code.google.com/p/maybench/++Build-Type: Simple+Cabal-Version: >= 1.2+Tested-With: GHC==6.8.2++Flag splitBase+ Description: Choose the new smaller, split-up base package.+Library+ if flag(splitBase)+ build-depends: base >= 3, process, old-time+ else+ build-depends: base < 3, time, mtl+ Exposed-Modules: Test.Maybench+ Test.Maybench.Command+ Test.Maybench.Utils+ ghc-options: -Wall++Executable maybench+ Hs-Source-Dirs: ., wrapper+ if flag(splitBase)+ build-depends: base >= 3,+ process+ else+ build-depends: base < 3, time, mtl+ Main-Is: Maybench.hs+ ghc-options: -Wall++Executable darcs-benchmark+ Hs-Source-Dirs: ., darcs-benchmark+ if flag(splitBase)+ build-depends: base >= 3,+ process, unix, directory, time, mtl, filepath+ else+ build-depends: base < 3, unix, time, mtl+ Main-Is: DarcsBenchmark.hs+ ghc-options: -Wall
+ wrapper/Maybench.hs view
@@ -0,0 +1,48 @@+import Control.Monad (when)+import System.Cmd -- ideally this should use System.Process in the future, but for the sake of a first version this will do.+import System.Exit+import System.Console.GetOpt+import System.Environment+import Data.Maybe (maybe, isJust, fromMaybe)++import Test.Maybench++optList :: [OptDescr (String, String)]+optList = [Option [] ["setup"] (ReqArg (\x -> ("setup",x)) "CMD") "Command to be run prior to benchmarking to prepare the environment.",+ Option [] ["setup1"] (ReqArg (\x -> ("setup1",x)) "CMD") "Command to be run prior to first benchmark to prepare the environment.",+ Option [] ["setup2"] (ReqArg (\x -> ("setup2",x)) "CMD") "Command to be run prior to second benchmark to prepare the environment.",+ Option [] ["cleanup"] (ReqArg (\x -> ("cleanup",x)) "CMD") "Command to be run post benchmarking to cleanup the environment.",+ Option [] ["cleanup1"] (ReqArg (\x -> ("cleanup1",x)) "CMD") "Command to be run post first benchmark to cleanup the environment.",+ Option [] ["cleanup2"] (ReqArg (\x -> ("cleanup2",x)) "CMD") "Command to be run post second benchmark to cleanup the environment.",+ Option ['n'] ["repetitions"] (ReqArg (\x -> ("repetitions",x)) "NUMBER") "Number of trials to run and average.",+ Option ['h'] ["help"] (NoArg ("help","help")) "Display usage information."]++optsDef :: [String] -> ([([Char], String)], [String], [String])+optsDef = getOpt Permute optList++help :: IO ()+help = do p <- getProgName+ putStrLn $ usageInfo (p ++ " cmd1 cmd2") optList+ exitWith ExitSuccess+ return ()++main :: IO ()+main = do args <- getArgs+ let opts = optsDef args+ lookupOpt opt = lookup opt . fst3 $ opts+ setup i = fromMaybe "true" (lookupOpt ("setup" ++ show i))+ cleanup i = fromMaybe "true" (lookupOpt ("cleanup" ++ show i))+ test n c = case lookupOpt "repetitions" of+ Nothing -> timeProgram c (setup n) (cleanup n)+ Just r -> averageTime c (setup n) (cleanup n) (read r)+ case opts of+ (_,[cmd1,cmd2],_) -> do+ when (isJust $ lookupOpt "help") help -- this exits+ system $ setup ""+ time1 <- test (1::Int) cmd1+ time2 <- test (2::Int) cmd2+ system $ cleanup ""+ maybe (return ()) putStrLn (compareTimes time1 time2)+ _ -> help+ where+ fst3 (x,_,_) = x