diff --git a/Benchmark.hs b/Benchmark.hs --- a/Benchmark.hs +++ b/Benchmark.hs @@ -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 ] diff --git a/Config.hs b/Config.hs new file mode 100644 --- /dev/null +++ b/Config.hs @@ -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" + } + ] diff --git a/Download.hs b/Download.hs --- a/Download.hs +++ b/Download.hs @@ -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 diff --git a/Shellish.hs b/Shellish.hs --- a/Shellish.hs +++ b/Shellish.hs @@ -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 diff --git a/Standard.hs b/Standard.hs --- a/Standard.hs +++ b/Standard.hs @@ -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 ] diff --git a/TabularRST.hs b/TabularRST.hs new file mode 100644 --- /dev/null +++ b/TabularRST.hs @@ -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) ' ' diff --git a/darcs-benchmark.cabal b/darcs-benchmark.cabal --- a/darcs-benchmark.cabal +++ b/darcs-benchmark.cabal @@ -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 diff --git a/main.hs b/main.hs --- a/main.hs +++ b/main.hs @@ -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] [/ [repository] [repository]]" , "" , "or alternatively, to run on all available repos:" - , "$ darcs-benchmark binary binary" + , "$ darcs-benchmark run [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