darcs-benchmark 0.1.3 → 0.1.5.1
raw patch · 8 files changed
+372/−120 lines, 8 filesdep +cmdargsdep +jsondep ~tabularnew-uploader
Dependencies added: cmdargs, json
Dependency ranges changed: tabular
Files
- Benchmark.hs +115/−47
- Config.hs +22/−0
- Download.hs +30/−11
- Shellish.hs +8/−5
- Standard.hs +52/−16
- TabularRST.hs +70/−0
- darcs-benchmark.cabal +10/−5
- main.hs +65/−36
Benchmark.hs view
@@ -1,14 +1,15 @@ module Benchmark where import Shellish hiding ( run )+import Control.Applicative import Data.Char import Data.List import Data.Maybe import System.Directory-import System.FilePath( (</>), (<.>) )+import System.FilePath( (</>) ) import System.IO import qualified Text.Tabular as Tab-import qualified Text.Tabular.AsciiArt as TA+import TabularRST as TR import System.Exit import Text.Printf import Text.Regex.Posix( (=~) )@@ -16,8 +17,12 @@ import Control.Monad.Error import Control.Monad.State( liftIO ) import Control.Exception( throw )+import Control.Concurrent( forkIO )+import Control.Concurrent.Chan( newChan, writeChan, readChan, Chan )+import System.Console.CmdArgs (isLoud) import System.Process( runInteractiveProcess, runInteractiveCommand, waitForProcess )+import Text.JSON precision, iterations :: Int precision = 1@@ -25,18 +30,47 @@ combine :: Ord a => [a] -> a combine = minimum -data MemTime = MemTime Rational Float type Darcs = [String] -> Command String+type BenchmarkCmd a = Darcs -> TestRepo -> Command a -newtype TestRepo = TestRepo String deriving Eq-data TestBinary = TestBinary String+data MemTime = MemTime Rational Float deriving (Read, Show, Ord, Eq)+data TestRepo = TestRepo { trName :: String+ , trPath :: FilePath -- ^ relative to the config file+ , trAnnotate :: Maybe FilePath -- ^ relative to repo, eg. @Just "README"@+ }+ deriving (Read, Show, Eq, Ord) -type BenchmarkCmd a = Darcs -> Command a+instance JSON TestRepo where+ readJSON (JSObject o) =+ TestRepo <$> jlookup "name" <*> jlookup "path"+ <*> jlookupMaybe "annotate"+ where+ jlookup a = case lookup a (fromJSObject o) of+ Nothing -> fail "Unable to read TestRepo"+ Just v -> readJSON v+ jlookupMaybe a = case lookup a (fromJSObject o) of+ Nothing -> return Nothing+ Just JSNull -> return Nothing+ Just v -> Just <$> readJSON v+ readJSON _ = fail "Unable to read TestRepo"+ showJSON = error "showJSON not defined for TestRepo yet"++data TestBinary = TestBinary String deriving (Show, Read)+ data Benchmark a = Idempotent String (BenchmarkCmd a) | Destructive String (BenchmarkCmd a)+ | Description String -data Test a = Test (Benchmark a) TestRepo TestBinary+instance Show (Benchmark a) where+ show (Idempotent s _) = s+ show (Destructive s _) = s+ show (Description s) = s +instance Read (Benchmark a) where+ readsPrec _ str = [(Description str, "")]++data Test a = Test (Benchmark a) TestRepo TestBinary deriving (Read, Show)+ copyTree :: FilePath -> FilePath -> IO () copyTree from to = do subs <- (\\ [".", ".."]) `fmap` getDirectoryContents from@@ -47,78 +81,84 @@ when is_dir $ copyTree (from </> item) (to </> item) when is_file $ copyFile (from </> item) (to </> item) +description :: Benchmark a -> String+description (Idempotent d _) = d+description (Destructive d _) = d+description (Description d) = d+ reset :: Command () reset = do resetMemoryUsed resetTimeUsed -description :: Benchmark a -> String-description (Idempotent d _) = d-description (Destructive d _) = d--exec :: Benchmark a -> FilePath -> Command a-exec (Idempotent _ cmd) darcs_path = do+exec :: Benchmark a -> FilePath -> TestRepo -> Command a+exec (Idempotent _ cmd) darcs_path tr = do cd "_playground"- cmd (darcs darcs_path)-exec (Destructive _ cmd) darcs_path = do+ verbose "cd _playground"+ cmd (darcs darcs_path) tr+exec (Destructive _ cmd) darcs_path tr = do cd "_playground"- let cleanup = cd ".." >> rm_rf "_playground"- res <- cmd (darcs darcs_path) `catchError` \e -> (cleanup >> throw e)+ let cleanup = verbose "cd .. ; rm -rf _playground" >> cd ".." >> rm_rf "_playground"+ res <- cmd (darcs darcs_path) tr `catchError` \e -> (cleanup >> throw e) cleanup return res+exec (Description _) _ _ = fail "Cannot run description-only benchmark." defaultrepo, sources :: FilePath -> FilePath defaultrepo path = path </> "_darcs" </> "prefs" </> "defaultrepo" sources path = path </> "_darcs" </> "prefs" </> "sources" prepare :: String -> Command ()-prepare repo = do- echo_n "!"+prepare origrepo = do+ progress "!" >> verbose "rm -rf _playground" rm_rf "_playground"- echo_n "." liftIO $ createDirectory "_playground" let playrepo = "_playground" </> "repo"- origrepo = "repo" <.> repo isrepo <- liftIO $ doesDirectoryExist (origrepo </> "_darcs") unless isrepo $ fail $ origrepo ++ ": Not a darcs repository!"+ progress "." >> verbose ("cp -a '" ++ origrepo ++ "' '" ++ playrepo ++ "'") liftIO $ copyTree origrepo playrepo- echo_n "."+ progress "." >> verbose ("# sanitize " ++ playrepo) wd <- pwd liftIO $ do writeFile (defaultrepo playrepo) (wd </> origrepo) removeFile (sources playrepo) `catch` \_ -> return () prepareIfDifferent :: String -> Command ()-prepareIfDifferent repo = do+prepareIfDifferent origrepo = do let playrepo = "_playground" </> "repo"- origrepo = "repo" <.> repo exist <- test_e "_playground" current' <- if exist then liftIO $ readFile (defaultrepo playrepo) else return "" let current = reverse (dropWhile (=='\n') $ reverse current') wd <- pwd- if (exist && current == wd </> origrepo) then echo_n "..."- else prepare repo+ if (exist && current == wd </> origrepo)+ then progress "..." >> verbose ("# leaving " ++ playrepo ++ " alone")+ else prepare origrepo run :: Test a -> Command (Maybe MemTime)-run (Test benchmark (TestRepo testrepo) (TestBinary bin)) = do+run (Test benchmark tr (TestBinary bin)) = do (Just `fmap` run') `catchError` \e ->- do echo $ " error: " ++ show e+ do echo_n_err $ " error: " ++ show e return Nothing where run' = do- echo_n $ bin ++ " " ++ description benchmark ++ " [" ++ testrepo ++ "]: "+ progress $ bin ++ " " ++ description benchmark ++ " [" ++ trName tr ++ "]: "+ verbose $ "\n# testing; binary = " ++ bin ++ ", benchmark = " +++ description benchmark ++ ", repository = " ++ trName tr exe <- which $ bin darcs_path <- case exe of Nothing -> canonize bin Just p -> return p times <- sequence [- do echo_n $ show i- sub $ do prepareIfDifferent testrepo- timed (exec benchmark darcs_path)+ do progress (show i) >> verbose ("# try " ++ show i)+ sub $ do prepareIfDifferent (trPath tr)+ timed (exec benchmark darcs_path tr) | i <- [1 .. iterations] ] let time = combine [ t | MemTime _ t <- times ] mem = combine [ m | MemTime m _ <- times ]- spaces = 45 - (length bin + length (description benchmark) + length testrepo)+ spaces = 45 - (length bin + length (description benchmark) + length (trName tr)) result = MemTime mem time- echo $ (replicate spaces ' ') ++ (concat $ intersperse ", " $ formatResult result)+ result_str = (concat $ intersperse ", " $ formatResult result)+ progress $ (replicate spaces ' ') ++ result_str ++ "\n"+ verbose $ "# result: " ++ result_str return result formatNumber :: (PrintfArg a, Fractional a) => a -> String@@ -126,28 +166,26 @@ formatResult :: MemTime -> [String] formatResult (MemTime mem time) =- [ formatNumber time ++ "s"- , formatNumber ((realToFrac (mem / (1024*1024))) :: Float) ++ "M" ]+ [ formatNumber time ++ "s, " ++ formatNumber ((realToFrac (mem / (1024*1024))) :: Float) ++ "M" ] tabulateRepo :: String -> [(Test a, Maybe MemTime)] -> Tab.Table String String String tabulateRepo repo results = Tab.Table rowhdrs colhdrs rows where rowhdrs = Tab.Group Tab.NoLine $ map Tab.Header rownames- colhdrs = Tab.Group Tab.SingleLine $ map colgrp colnames- colgrp x = Tab.Group Tab.NoLine [Tab.Header x, Tab.Header ""]+ colhdrs = Tab.Group Tab.SingleLine $ map Tab.Header colnames colnames = nub [ label | (Test _ _ (TestBinary label), _) <- interesting ] rownames = nub [ description bench | (Test bench _ _, _) <- interesting ]- interesting = [ test | test@(Test _ (TestRepo r) _, _) <- results, r == repo ]+ interesting = [ test | test@(Test _ r _, _) <- results, trName r == repo ] rows = [ concat [ fmt $ find (match row column) interesting | column <- colnames ] | row <- rownames ] match bench binary (Test bench' _ (TestBinary binary'), _) = bench == description bench' && binary == binary' fmt (Just (_, Just x)) = formatResult x- fmt _ = [ "-", "-" ]+ fmt _ = [ "-, -" ] tabulate :: [(Test a, Maybe MemTime)] -> [(String, Tab.Table String String String)] tabulate results = zip repos $ map (flip tabulateRepo results) repos- where repos = nub [ repo | (Test _ (TestRepo repo) _, _) <- results ]+ where repos = nub [ trName r | (Test _ r _, _) <- results ] timed :: Command a -> Command MemTime timed a = do@@ -168,19 +206,48 @@ '2':'.':_ -> return () _ -> fail $ cmd ++ ": Not darcs 2.x binary." +verbose :: String -> Command ()+verbose m = liftIO $ do loud <- isLoud+ when loud $ hPutStrLn stderr m++progress :: String -> Command ()+progress m = liftIO $ do loud <- isLoud+ unless loud $ hPutStr stderr m++drain :: Handle -> Bool -> IO (Chan String)+drain h verb = do chan <- newChan+ let work acc = do line <- hGetLine h+ when verb $ putStrLn ("## " ++ line)+ work (acc ++ line)+ `catch` \_ -> writeChan chan acc+ forkIO $ work ""+ return chan+ darcs :: String -> [String] -> Command String darcs cmd args' = do+ stats_f <- liftIO $+ do tmpdir <- getTemporaryDirectory+ (f, h) <- openTempFile tmpdir "darcs-stats-XXXX"+ hClose h+ return f+ let args = args' ++ ["+RTS", "-s" ++ stats_f, "-RTS"]+ loud <- liftIO isLoud+ verbose . unwords $ cmd:args (res, _, stats) <- liftIO $ do- let args = args' ++ ["+RTS", "-sdarcs-stats", "-RTS"] (_,outH,errH,procH) <- runInteractiveProcess cmd args Nothing Nothing- res <- strictGetContents outH- errs <- strictGetContents errH+ res' <- drain outH loud+ errs' <- drain errH loud ex <- waitForProcess procH- stats <- readFile "darcs-stats" `catch` \_ -> return ""+ stats <- do c <- readFile stats_f+ removeFile stats_f `catch` \e -> hPutStrLn stderr (show e)+ return c+ `catch` \_ -> return ""+ errs <- readChan errs' case ex of ExitSuccess -> return () ExitFailure n -> fail $ "darcs failed with error code " ++ show n ++ "\nsaying: " ++ errs+ res <- readChan res' return (res, errs, stats) let bytes = (stats =~ "([0-9, ]+) M[bB] total memory in use") :: String mem = (read (filter (`elem` "0123456789") bytes) :: Int)@@ -195,6 +262,7 @@ | repo <- repos, bin <- bins, bench <- benches ] renderMany :: [(Test a, Maybe MemTime)] -> Command ()-renderMany t = sequence_ [ do echo $ "\n=== " ++ r ++ " ===\n"- echo_n $ TA.render id id id tab+renderMany t = sequence_ [ do echo r+ echo $ replicate (length r) '-' ++ "\n"+ echo_n $ TR.render id id id tab | (r, tab) <- tabulate t ]
+ Config.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Config where++import System.Console.CmdArgs++data Config = Get { repos :: [String] }+ | Run { fast :: Bool+ , only :: [String]+ , dump :: Bool+ , extra :: [String] }+ deriving (Show, Data, Typeable)++defaultConfig :: [Mode Config]+defaultConfig =+ [ mode $ Get { repos = [] &= args & typ "REPONAME" }+ , mode $ Run { fast = False &= text "Exclude the most time-consuming benchmarks"+ , dump = False &= text "Produce machine-readable output on stdout"+ , only = [] &= text "Only run benchmarks with one of these substrings in their names" & typ "BENCHMARK"+ , extra = [] &= args & typ "BINARY"+ }+ ]
Download.hs view
@@ -11,24 +11,43 @@ import Control.Monad baseurl :: String-baseurl = "http://repos.mornfall.net/darcs/benchmark-repos/"+baseurl = "http://code.haskell.org/darcs/benchmark-repos/" +exists :: FilePath -> IO Bool+exists f =+ do exists_file <- doesFileExist f+ exists_dir <- doesDirectoryExist f+ return (exists_file || exists_dir)+ download :: String -> IO () download repo = do- let Just url = parseURI $ baseurl ++ repo ++ ".tgz"- putStrLn $ "downloading and extracting: " ++ show url- exist_dir <- doesDirectoryExist $ "repo" <.> repo- exist_file <- doesFileExist $ "repo" <.> repo- let go = do (_, rsp) <- browse $ do setCheckForProxy True- setOutHandler (const $ return ())- request (mkRequest GET url)+ let Just repo_url = parseURI $ baseurl ++ repo ++ ".tgz"+ Just config_url = parseURI $ baseurl ++ "config" <.> repo+ config_file = "config" <.> repo+ putStrLn $ "downloading and extracting: " ++ show repo_url+ repo_exists <- exists ("repo" <.> repo)+ config_exists <- exists ("config" <.> repo)+ let go = do rsp <- fetch repo_url when (rspCode rsp /= (2, 0, 0)) $ fail ("download failed: " ++ rspReason rsp) createDirectory $ "repo" <.> repo let bits = rspBody rsp entries = Tar.read $ decompress bits Tar.unpack ("repo" <.> repo) entries-- if (exist_dir || exist_file)- then putStrLn $ "repo" <.> repo ++ " already exists, skipping!"+ go_cfg = do rsp <- fetch config_url+ case rspCode rsp of+ (4, 0, 4) -> putStrLn $ "No config file detected for " ++ repo ++ " and that's fine!"+ (2, 0, 0) -> writeFile ("config" <.> repo) (rspBody rsp)+ _ -> fail ("download failed: " ++ rspReason rsp)+ if repo_exists+ then putStrLn $ "repo" <.> repo ++ " already exists, fetching config file only." else go+ if config_exists+ then putStrLn $ config_file ++ " already exists, skipping!"+ else go_cfg+ where+ fetch url =+ do (_, rsp) <- browse $ do setCheckForProxy True+ setOutHandler (const $ return ())+ request (mkRequest GET url)+ return rsp
Shellish.hs view
@@ -1,8 +1,8 @@ module Shellish( cd, pwd, run, (#), withCurrentDirectory, strictGetContents, shellish, silently, verbosely, Command, sub, echo, echo_n, which, canonize, resetMemoryUsed, recordMemoryUsed,- memoryUsed, rm_rf, whenM, test_e, test_f, test_d,- resetTimeUsed, timeUsed, mv, ls )+ memoryUsed, rm_rf, rm_f, whenM, test_e, test_f, test_d,+ resetTimeUsed, timeUsed, mv, ls, echo_err, echo_n_err ) where import Data.List@@ -35,11 +35,11 @@ pwd :: Command String pwd = liftIO $ getCurrentDirectory -echo :: String -> Command ()+echo, echo_n, echo_err, echo_n_err :: String -> Command () echo = liftIO . putStrLn--echo_n :: String -> Command () echo_n = liftIO . (>> hFlush System.IO.stdout) . putStr+echo_err = liftIO . hPutStrLn stderr+echo_n_err = liftIO . (>> hFlush stderr) . hPutStr stderr which :: String -> Command (Maybe String) which = liftIO . findExecutable@@ -65,6 +65,9 @@ rm_rf :: String -> Command () rm_rf f = whenM (test_e f) $ liftIO $ removeDirectoryRecursive f++rm_f :: String -> Command ()+rm_f f = whenM (test_e f) $ liftIO $ removeFile f run :: String -> [String] -> Command String run cmd args = do
Standard.hs view
@@ -2,39 +2,40 @@ import System.FilePath import Shellish import Benchmark hiding ( darcs )-import Control.Monad( forM, filterM, when )+import Control.Monad( forM_, mapM_, forM, filterM, when ) import Control.Monad.Trans( liftIO ) import qualified Control.Monad.State as MS check :: BenchmarkCmd ()-check darcs = do+check darcs _ = do cd "repo" darcs [ "check", "--no-test" ] return () repair :: BenchmarkCmd ()-repair darcs = do+repair darcs _ = do cd "repo" darcs [ "repair" ] return () annotate :: BenchmarkCmd ()-annotate darcs = do+annotate darcs tr = do cd "repo" whenM ((not . or) `fmap` mapM test_e files) $ fail "no files to annotate" sequence [ whenM (test_e f) $ (darcs [ "annotate", f ] >> return ()) | f <- files ] return ()- where files = [ "Setup.hs", "Setup.lhs" ]+ where files = maybe id (:) (trAnnotate tr) [ "Setup.hs", "Setup.lhs" ] get :: Int -> [String] -> BenchmarkCmd ()-get n param darcs = do+get n param darcs _ = do forM [1..n] $ \x -> darcs $ "get" : param ++ ["repo", "get" ++ show x] return () pull :: Int -> BenchmarkCmd ()-pull n darcs = do+pull n darcs _ = do cd "repo"+ rm_f "_darcs/patches/unrevert" darcs [ "unpull", "--last", show n, "--all" ] reset -- the benchmark starts here darcs [ "pull", "--all" ]@@ -42,46 +43,81 @@ -- Oh my eyes! Oh noes! Horrible! darcs_wh :: [String] -> BenchmarkCmd ()-darcs_wh param darcs = do+darcs_wh param darcs _ = do state <- MS.get newstate <- liftIO $ catch (MS.execStateT (darcs $ "whatsnew" : param) state) (\_ -> return state) MS.put newstate wh :: Int -> BenchmarkCmd ()-wh n darcs = do+wh n darcs tr = do cd "repo"- forM [1..n] $ \_ -> darcs_wh [] darcs+ forM [1..n] $ \_ -> darcs_wh [] darcs tr return () wh_mod :: Int -> BenchmarkCmd ()-wh_mod n darcs = do+wh_mod n darcs tr = do cd "repo" files <- filterM test_f =<< ls "." when (null files) $ fail "no files to modify in repo root!" forM files $ \f -> mv f $ f <.> "__foo__"- forM [1..n] $ \_ -> darcs_wh [] darcs+ forM [1..n] $ \_ -> darcs_wh [] darcs tr forM files $ \f -> mv (f <.> "__foo__") f return () wh_l :: Int -> BenchmarkCmd ()-wh_l n darcs = do+wh_l n darcs tr = do cd "repo"- forM [1..n] $ \_ -> darcs_wh [ "--look-for-adds" ] darcs+ forM [1..n] $ \_ -> darcs_wh [ "--look-for-adds" ] darcs tr return () +-- | n patches for each file+record_mod :: Int -> BenchmarkCmd ()+record_mod n darcs _ = do+ cd "repo"+ files <- filterM test_f =<< ls "."+ forM_ [1..n] $ \x -> do+ forM_ files $ \f -> liftIO (appendFile f (show n))+ darcs [ "record", "--all", "-m", show x, "--no-test"]+ darcs [ "obliterate", "--last=" ++ show n, "--all" ]+ return ()++revert_mod :: Int -> BenchmarkCmd ()+revert_mod n darcs _ = do+ cd "repo"+ files <- filterM test_f =<< ls "."+ forM_ [1..n] $ \x -> do+ forM_ files $ \f -> liftIO (appendFile f (show n))+ darcs [ "revert", "--all" ]+ return ()++revert_unrevert :: Int -> BenchmarkCmd ()+revert_unrevert n darcs _ = do+ cd "repo"+ files <- filterM test_f =<< ls "."+ forM_ [1..n] $ \x -> do+ forM_ files $ \f -> liftIO (appendFile f (show n))+ darcs [ "revert", "--all" ]+ darcs [ "unrevert", "--all" ]+ darcs [ "revert", "--all" ]+ return ()+ fast :: [ Benchmark () ] fast = [ Destructive "get (full)" $ get 1 [] , Destructive "get (lazy, x10)" $ get 10 ["--lazy"] , Idempotent "pull 100" $ pull 100- , Idempotent "annotate" annotate , Idempotent "wh x50" $ wh 50 , Idempotent "wh mod x50" $ wh_mod 50- , Idempotent "wh -l x20" $ wh_l 20 ]+ , Idempotent "wh -l x20" $ wh_l 20+ , Idempotent "record mod x10" $ record_mod 10+ , Idempotent "revert mod x50" $ revert_mod 50+ , Idempotent "(un)revert mod x10" $ revert_unrevert 10+ ] standard :: [ Benchmark () ] standard = fast ++ [ Idempotent "check" check , Idempotent "repair" repair+ , Idempotent "annotate" annotate , Idempotent "pull 1000" $ pull 1000 ]
+ TabularRST.hs view
@@ -0,0 +1,70 @@+module TabularRST where++import Data.List (intersperse, transpose)+import Text.Tabular++-- RST renderer for tabular+-- (being incubated; when this matures, it should become part of tabular)++-- | for simplicity, we assume that each cell is rendered+-- on a single line+render :: (rh -> String)+ -> (ch -> String)+ -> (a -> String)+ -> Table rh ch a+ -> String+render fr fc f (Table rh ch cells) =+ unlines $ [ bar DoubleLine+ , renderColumns sizes ch2+ , bar DoubleLine+ ] +++ (renderRs $ fmap renderR $ zipHeader [] cells $ fmap fr rh) +++ [ bar DoubleLine ] -- +--------------------------------------++ where+ bar = concat . renderTHLine sizes ch2+ renderTHLine _ _ NoLine = []+ renderTHLine w h SingleLine = [renderHLine' w '-' h]+ renderTHLine w h DoubleLine = [renderHLine' w '=' h]+ -- ch2 and cell2 include the row and column labels+ ch2 = Group DoubleLine [Header "", fmap fc ch]+ cells2 = headerContents ch2+ : zipWith (\h cs -> h : map f cs) rhStrings cells+ --+ renderR (cs,h) = renderColumns sizes $ Group DoubleLine+ [ Header h+ , fmap fst $ zipHeader "" (map f cs) ch]+ rhStrings = map fr $ headerContents rh+ -- maximum width for each column+ sizes = map (maximum . map length) . transpose $ cells2+ renderRs (Header s) = [s]+ renderRs (Group p hs) = concat . intersperse sep . map renderRs $ hs+ where sep = renderHLine sizes ch2 p++-- | We stop rendering on the shortest list!+renderColumns :: [Int] -- ^ max width for each column+ -> Header String+ -> String+renderColumns is h = coreLine+ where+ coreLine = concatMap helper $ flattenHeader $ zipHeader 0 is h+ helper = either hsep (uncurry padLeft)+ hsep :: Properties -> String+ hsep _ = " "++renderHLine :: [Int] -- ^ width specifications+ -> Header String+ -> Properties+ -> [String]+renderHLine _ _ _ = []++renderHLine' :: [Int] -> Char -> Header String -> String+renderHLine' is sep h = coreLine+ where+ coreLine = concatMap helper $ flattenHeader $ zipHeader 0 is h+ helper = either vsep dashes+ dashes (i,_) = replicate i sep+ vsep _ = " "++padLeft :: Int -> String -> String+padLeft l s = padding ++ s+ where padding = replicate (l - length s) ' '
darcs-benchmark.cabal view
@@ -1,5 +1,5 @@ name: darcs-benchmark-version: 0.1.3+version: 0.1.5.1 synopsis: Comparative benchmark suite for darcs. description: A simple tool to compare performance of different Darcs 2.x@@ -22,11 +22,14 @@ executable darcs-benchmark if impl(ghc >= 6.8) ghc-options: -fwarn-tabs- ghc-options: -Wall- ghc-prof-options: -prof -auto-all+ ghc-options: -Wall -threaded+ ghc-prof-options: -prof -auto-all -threaded - build-depends: base < 5, process, mtl, tabular >= 0.2, time,+ build-depends: base < 5,+ cmdargs >= 0.1 && < 0.2,+ process, mtl, tabular >= 0.2.2.1, time, regex-posix, html, filepath, directory,+ json == 0.4.*, containers, bytestring, network, HTTP >= 4000.0.8 && < 4000.1, tar, zlib@@ -34,9 +37,11 @@ main-is: main.hs other-modules: Shellish Benchmark+ Config Standard Download+ TabularRST source-repository head type: darcs- location: http://repos.mornfall.net/darcs/benchmark+ location: http://code.haskell.org/darcs/darcs-benchmark
main.hs view
@@ -1,22 +1,30 @@ #!/usr/bin/env runhaskell import Shellish( shellish, rm_rf )+import Control.Arrow ( second )+import System.Console.CmdArgs import System.Exit-import System.Environment import System.Directory+import System.IO import Control.Monad+import Control.Monad.Trans import Benchmark+import Config (Config(Get,Run))+import qualified Config as C import Standard import Download import Data.List+import Data.Version ( showVersion )+import Paths_darcs_benchmark+import Text.JSON help :: String-help = unlines [ "darcs-benchmark: run standard darcs benchmarks"+help = unlines [ "darcs-benchmark " ++ showVersion version ++ ": run standard darcs benchmarks" , "" , "Please either specify the repositories and binaries to run on like this:"- , "$ darcs-benchmark binary binary -- repository repository"+ , "$ darcs-benchmark run <binary> [binary] [/ [repository] [repository]]" , "" , "or alternatively, to run on all available repos:"- , "$ darcs-benchmark binary binary"+ , "$ darcs-benchmark run <binary> [binary]" , "" , "You can also create a file called 'config' in the working directory." , "Put two lines in it, one with list of binaries, one with list of repos:"@@ -26,54 +34,75 @@ , "" , "(again, if the second line is not there, we run on all available repos)" , ""- , "NOTE: To obtain test repositories, you can use 'darcs-benchmark --get',"- , "optionally supplying the names of the test repos you are interested in."- , "" , "Thank you for benchmarking darcs!" ] known_repos :: [String] known_repos = [ "ghc-hashed", "darcs" ] -nonopt :: [String] -> [String]-nonopt args = [ r | r <- args, not $ "--" `isPrefixOf` r ]- download_repos :: [String] -> IO ()-download_repos r = do forM_ (if null r then known_repos else r) $ download- exitWith ExitSuccess+download_repos r = forM_ (if null r then known_repos else r) download -config :: [TestRepo] -> [String] -> IO ([TestRepo], [TestBinary], [Benchmark ()])-config allrepos args = do- when ("--get" `elem` args) $ do download_repos (nonopt args)- haveConf <- doesFileExist "config"- when (not haveConf && null args) $ do- putStrLn help- exitWith $ ExitFailure 1- conf <- if haveConf then lines `fmap` readFile "config"- else return []- let confrepos = if length conf > 1 then (words $ conf !! 1) else []- confbins = if length conf > 0 then words $ conf !! 0 else []- bins = nonopt $ takeWhile (/= "--") args- repos = nonopt $ dropWhile (/= "--") args- userepos = map TestRepo $ if null repos then confrepos else repos- usebins = map TestBinary $ if null bins then confbins else bins- usetests = if "--fast" `elem` args then fast else standard- return (if null userepos then allrepos else userepos, usebins, usetests)+config :: [TestRepo] -> C.Config -> IO ([TestRepo], [TestBinary], [Benchmark ()])+config allrepos cfg = do+ case cfg of+ Get {} -> do+ download_repos (C.repos cfg)+ exitWith ExitSuccess+ Run {} -> do+ haveConf <- doesFileExist "config"+ conf <- if haveConf then lines `fmap` readFile "config"+ else return []+ let confrepos = if length conf > 1 then (words $ conf !! 1) else []+ confbins = if length conf > 0 then words $ conf !! 0 else []+ (bins,repos) = second (drop 1) $ break (== "/") (C.extra cfg)+ userepos = if null repos then confrepos else repos+ usebins = map TestBinary $ if null bins then confbins else bins+ usetests' = if C.fast cfg then fast else standard+ usetests = case C.only cfg of+ [] -> usetests'+ os -> filter (\b -> any (\o -> o `isInfixOf` show b) os) usetests'+ when (null usebins) $ do+ hPutStrLn stderr "Please specify at least one darcs binary to benchmark"+ exitWith (ExitFailure 1)+ return ( if null userepos then allrepos+ else filter (\r -> any (matchRepo r) userepos) allrepos+ , usebins+ , usetests+ )+ where+ dropPrefix p x = if p `isPrefixOf` x then drop (length p) x else x+ matchRepo tr x = trName tr == x || dropPrefix "repo." (trPath tr) == x +testRepoFromDir :: String -> TestRepo+testRepoFromDir d = TestRepo (drop (length "repo.") d) d Nothing+ main :: IO () main = do+ cfg <- cmdArgs help C.defaultConfig allrepos <- do listing <- getDirectoryContents "."- return $ [ TestRepo $ drop 5 repo- | repo <- listing, repo `notElem` [".", ".."]- , "repo." `isPrefixOf` repo ]- (repos, binaries, tests) <- config allrepos =<< getArgs+ configs <- mapM readC $ filter ("config." `isPrefixOf`) listing+ let other = [ testRepoFromDir d | d <- listing+ , "repo." `isPrefixOf` d+ , d `notElem` map trPath configs ]+ return (configs ++ other)+ (repos, binaries, tests) <- config allrepos cfg unless (null $ repos \\ allrepos) $ do- let name r = intercalate ", " $ map (\(TestRepo x) -> x) r+ let name r = intercalate ", " $ map trName r putStrLn $ "Missing repositories: " ++ name (repos \\ allrepos) exitWith $ ExitFailure 2 forM binaries $ \(TestBinary bin) -> check_darcs bin when (null repos) $ do- putStrLn $ "Oops, no repositories! Consider doing a --get."+ putStrLn $ "Oops, no repositories! Consider doing a darcs-benchmark get." putStrLn $ "(Alternatively, check that you are in the right directory.)" exitWith $ ExitFailure 3 shellish $ do rm_rf "_playground"- benchMany repos binaries tests >>= renderMany+ res <- benchMany repos binaries tests+ if C.dump cfg+ then liftIO $ print res+ else renderMany res+ where+ readC f =+ do mj <- (resultToEither . decode) `fmap` readFile f+ case mj of+ Left e -> fail $ "Could not read " ++ f ++ ": " ++ show e+ Right j -> return $ j