darcs-benchmark 0.1.8.3 → 0.1.9

raw patch · 25 files changed

+1665/−1406 lines, 25 filesdep +SHAdep +datetimedep +strictdep ~cmdargs

Dependencies added: SHA, datetime, strict

Dependency ranges changed: cmdargs

Files

• Benchmark.hs +0/−251
• Config.hs +0/−28
• Definitions.hs +0/−308
• Dist.hs +0/−15
• Download.hs +0/−53
• Graph.hs +0/−54
• Report.hs +0/−168
• Run.hs +0/−35
• Shellish.hs +0/−166
• Standard.hs +0/−118
• TabularRST.hs +0/−70
• darcs-benchmark.cabal +6/−6
• main.hs +0/−134
• source/Benchmark.hs +369/−0
• source/Config.hs +30/−0
• source/Definitions.hs +363/−0
• source/Dist.hs +15/−0
• source/Download.hs +53/−0
• source/Graph.hs +54/−0
• source/Report.hs +221/−0
• source/Run.hs +35/−0
• source/Shellish.hs +186/−0
• source/Standard.hs +117/−0
• source/TabularRST.hs +70/−0
• source/main.hs +146/−0

@@ -1,251 +0,0 @@-module Benchmark where--import Definitions-import Shellish hiding ( run )-import Data.Char-import Data.List-import Data.List.Split ( wordsBy )-import System.Directory-import System.Environment-import System.FilePath( (</>), (<.>), splitDirectories, joinPath )-import System.IO-import System.Exit-import Text.Regex.Posix( (=~) )-import Data.Time.Clock-import Control.Monad.Error-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 qualified System.IO.UTF8 as UTF8--copyTree :: FilePath -> FilePath -> IO ()-copyTree from to =-    do subs <- (\\ [".", ".."]) `fmap` getDirectoryContents from-       createDirectory to-       forM_ subs $ \item -> do-         is_dir <- doesDirectoryExist (from </> item)-         is_file <- doesFileExist (from </> item)-         when is_dir $ copyTree (from </> item) (to </> item)-         when is_file $ copyFile (from </> item) (to </> item)--reset :: Command ()-reset = do-  resetMemoryUsed-  resetTimeUsed--exec :: Benchmark a -> FilePath -> TestRepo -> Command a-exec (Idempotent _ _ cmd) darcs_path tr = do-  cd "_playground"-  verbose "cd _playground"-  cmd (darcs darcs_path) tr-exec (Destructive _ _ cmd) darcs_path tr = do-  cd "_playground"-  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 origrepo = do-  progress "!" >> verbose "rm -rf _playground"-  rm_rf "_playground"-  liftIO $ createDirectory "_playground"-  let playrepo = "_playground" </> "repo"-  isrepo <- liftIO $ doesDirectoryExist (origrepo </> "_darcs")-  unless isrepo $ fail $ origrepo ++ ": Not a darcs repository!"-  progress "." >> verbose ("cp -a '" ++ origrepo ++ "' '" ++ playrepo ++ "'")-  liftIO $ copyTree origrepo playrepo-  progress "." >> verbose ("# sanitize " ++ playrepo)-  wd <- pwd-  liftIO $ do writeFile (defaultrepo playrepo) (wd </> origrepo)-              removeFile (sources playrepo) `catch` \_ -> return ()--prepareIfDifferent :: String -> Command ()-prepareIfDifferent origrepo = do-  let playrepo = "_playground" </> "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 progress "..." >> verbose ("# leaving " ++ playrepo ++ " alone")-     else prepare origrepo---- | Run a benchmark as many times as it takes to pass a minimum threshold---   of time or iterations (whichever comes first)---   Useful for very small benchmarks-adaptive :: Double -- ^ seconds-         -> (Int,Int) -- ^ min, max iterations-         -> Command MemTime -> Command [MemTime]-adaptive thresh (iters_min,iters_max) cmd =-   cmd >> -- just once to warm up the disk cache (eliminate a source of variance)-   go thresh iters_max []- where-  go t i acc | i <= 0 || (t <= 0 && i <= iters_enough) = return acc-  go t i acc =-   do verbose $ "# adaptive: iterations remaining: " ++ show i ++ " time remaining: " ++ show t-      mt@(MemTime _ t2) <- cmd-      go (t - t2) (i - 1) (mt : acc)-  iters_enough = iters_max - iters_min--run :: Test a -> Command (Maybe MemTimeOutput)-run test@(Test benchmark tr (TestBinary bin)) = do-  (Just `fmap` run') `catchError` \e ->-      do echo_n_err $ " error: " ++ show e-         return Nothing-  where run' = do-          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 <- adaptive 10 (3,100) . sub $ do-                     prepareIfDifferent (trPath tr)-                     liftIO (maybeVMFlush darcs_path)-                     m <- timed (exec benchmark darcs_path tr)-                     return m-          let result = mkMemTimeOutput times-              spaces = 45 - (length bin + length (description benchmark) + length (trName tr))-              tu = appropriateUnit (mtTimeMean result)-              result_str = unwords $ concatMap (\f -> f tu (Cell result)) [ formatTimeResult, formatMemoryResult, formatSampleSize ]-          liftIO $ appendResult test times-          progress $ (replicate spaces ' ') ++ result_str ++ "\n"-          verbose $ "# result: " ++ result_str-          return result--timed :: Command a -> Command MemTime-timed a = do-  resetMemoryUsed-  t1 <- liftIO $ getCurrentTime-  _ <- a-  t2 <- liftIO $ getCurrentTime-  mem <- memoryUsed-  resetMemoryUsed-  return $ MemTime (fromIntegral mem) (realToFrac $ diffUTCTime t2 t1)--darcsVersion :: String -> IO Version-darcsVersion cmd = do-       (_,outH,_,procH) <- runInteractiveCommand $ cmd ++ " --version"-       out <- strictGetContents outH-       _ <- waitForProcess procH-       return $ map read . wordsBy (== '.') . takeWhile (not . isSpace) $ out--check_darcs :: String -> IO ()-check_darcs cmd = do-       out <- darcsVersion cmd-       case out of-         2:_ -> return ()-         _ -> fail $ cmd ++ ": Not darcs 2.x binary."--verbose :: String -> Command ()-verbose m = liftIO $ do loud <- isLoud-                        when loud $ UTF8.hPutStrLn stderr m--progress :: String -> Command ()-progress m = liftIO $ do loud <- isLoud-                         unless loud $ UTF8.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--readFile' :: FilePath -> IO String-readFile' f = do s <- readFile f-                 length s `seq` return s--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-       mPlayground <- seekPlayground `fmap` getCurrentDirectory-       mEnv <- case mPlayground of-                 Nothing -> return Nothing-                 Just p  -> (Just . replace "HOME" p) `fmap` getEnvironment-       (_,outH,errH,procH) <- runInteractiveProcess cmd args Nothing mEnv-       res' <- drain outH loud-       errs' <- drain errH loud-       ex <- waitForProcess procH-       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)-    recordMemoryUsed $ mem * 1024 * 1024-    return res- where-  replace k v xs = (k,v) : filter ((/= k) . fst) xs--seekPlayground :: FilePath -> Maybe FilePath-seekPlayground dir =- if playground `elem` pieces-    then Just . joinPath . reverse . dropWhile (/= playground) . reverse $ pieces-    else Nothing- where-  pieces = splitDirectories dir-  playground = "_playground"---- ------------------------------------------------------------------------- variants--- ------------------------------------------------------------------------mkVariant :: String -> String -> Variant -> Command ()-mkVariant origrepo darcs_path v =- case vId v of-  OptimizePristineVariant -> do-    isrepo <- liftIO $ doesDirectoryExist (origrepo </> "_darcs")-    unless isrepo $ fail $ origrepo ++ ": Not a darcs repository!"-    variant_isrepo  <- liftIO $ doesDirectoryExist (variant_repo </> "_darcs")-    unless variant_isrepo $ do-      echo $ "Setting up " ++ vDescription v ++ " variant of " ++ origrepo-      verbose ("cp -a '" ++ origrepo ++ "' '" ++ variant_repo ++ "'")-      liftIO $ copyTree origrepo variant_repo-      verbose ("# sanitize " ++ variant_repo)-      liftIO $ removeFile (sources variant_repo) `catch` \_ -> return ()-      darcs darcs_path [ "optimize", "--pristine", "--repodir", variant_repo ]-      return ()-  DefaultVariant -> return ()- where-  variant_repo = variantRepoName v origrepo--variantRepoName :: Variant -> String -> String-variantRepoName (Variant { vId = DefaultVariant }) x = x-variantRepoName v x = "variant" <.> stripped x ++ "-" ++ vSuffix v- where-  stripped y | "repo."   `isPrefixOf` y = stripped (drop 5 y)-             | "-hashed" `isSuffixOf` y = take (length y -  7) y-             | otherwise = y--setupVariants :: [TestRepo] -> TestBinary -> Command ()-setupVariants repos (TestBinary bin) =-  sequence_ [ mkVariant (trPath repo) bin variant-            | repo <- repos, variant <- trVariants repo ]

@@ -1,28 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Config where--import System.Console.CmdArgs--data Config = Get { repos :: [String] }-            | Run { fast  :: Bool-                  , cold  :: Bool-                  , only  :: [String]-                  , dump  :: Bool-                  , extra :: [String] }-            | Dist { repo :: FilePath }-            | Report-              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"-              , cold = False &= text "Try to flush VM caches between iterations"-              , 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"-              }- , mode $ Dist { repo = "" &= argPos 0 & typ "DIRECTORY" }- , mode $ Report- ]

@@ -1,308 +0,0 @@-module Definitions where--import Control.Applicative-import Data.Array.Vector-import Data.Function-import Data.IORef-import Data.List-import Data.Maybe-import Data.Ord-import Data.Time-import Network.BSD ( HostName, getHostName )-import Statistics.Sample-import System.Directory-import System.FilePath-import System.Locale-import System.IO.Unsafe-import Text.JSON-import Text.Printf--import Shellish (Command)--type Darcs = [String] -> Command String--data Test a = Test (Benchmark a) TestRepo TestBinary deriving (Show)--data TestBinary = TestBinary String deriving (Show, Eq)--data ParamStamp = Params { pHostName :: HostName-                         , pFlush :: Maybe (FilePath -> IO ()) }-type TimeStamp = UTCTime--type Version = [Int] -- we could also use Data.Version-                     -- the difference here is just that we explicitly-                     -- do not have a notion of version tags--global :: IORef (ParamStamp, TimeStamp)-global = unsafePerformIO $ do t  <- getCurrentTime-                              hn <- getHostName-                              newIORef (Params hn Nothing, t)--maybeVMFlush :: FilePath -> IO ()-maybeVMFlush darcs = do- (p,_) <- readIORef global- case pFlush p of-  Just f  -> f darcs-  Nothing -> return ()---- ------------------------------------------------------------------------- benchmarks--- ------------------------------------------------------------------------type BenchmarkCmd a = Darcs -> TestRepo -> Command a--data BenchmarkSpeed = FastB | SlowB deriving (Eq)--data Benchmark a = Idempotent String BenchmarkSpeed (BenchmarkCmd a)-                 | Destructive String BenchmarkSpeed (BenchmarkCmd a)-                 | Description String--instance Show (Benchmark a) where-    show = description -- FIXME: is this right?--description :: Benchmark a -> String-description (Idempotent d _ _) = d-description (Destructive d _ _) = d-description (Description d) = d--speed :: Benchmark a -> BenchmarkSpeed-speed (Idempotent _ s _) = s-speed (Destructive _ s _) = s-speed (Description _) = FastB---- ------------------------------------------------------------------------- repositories--- ------------------------------------------------------------------------data TestRepo = TestRepo { trName     :: String-                         , trCoreName :: String   -- ^ (variants only) name of the orig repo-                         , trPath     :: FilePath -- ^ relative to the config file-                         , trAnnotate :: Maybe FilePath -- ^ relative to repo, eg. @Just "README"@-                         , trVariants :: [Variant]-                         }- deriving (Read, Show, Eq, Ord)--instance JSON TestRepo where-  readJSON (JSObject o) =-     TestRepo <$> jlookup "name"-              <*> jlookup "name" -- 2nd time for trCoreName-              <*> jlookup "path"-              <*> jlookupMaybe "annotate"-              <*> (map toVariant . (DefaultVariant :) <$> jlookupMaybeList "variants")-    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-     jlookupMaybeList a = case lookup a (fromJSObject o) of-                            Nothing -> return []-                            Just v  -> readJSONs v-  readJSON _ = fail "Unable to read TestRepo"-  showJSON = error "showJSON not defined for TestRepo yet"---- note that the order of the variants is reflected in the tables-data VariantName = DefaultVariant | OptimizePristineVariant- deriving (Enum, Bounded, Eq, Ord, Read, Show)--instance JSON VariantName where-  readJSON (JSString s) =-    case fromJSString s of-      "optimize-pristine" -> return OptimizePristineVariant-      x -> fail $ "Unknown variant: " ++ x-  readJSON _ = fail "Unable to VariantName"-  showJSON = error "showJSON not defined for VariantName yet"--data Variant = Variant { vId :: VariantName-                       , vShortName   :: String-                       , vDescription :: String-                       , vSuffix :: String-                       }- deriving (Eq, Ord, Show, Read)--toVariant :: VariantName -> Variant-toVariant n@DefaultVariant =-  Variant n "default"  "default (hashed)" ""-toVariant n@OptimizePristineVariant =-  Variant n "opt pris" "optimize --pristine" "op"---- | Given a name of a repo like "tabular opt pris", figure out what the---   variant was.  If there are no suffixes, like "opt pris", we assume---   it's not a variant.-nameToVariant :: String -> Variant-nameToVariant n =-  case [ v | v <- variants, vShortName v `isSuffixOf` n ] of-   []    -> toVariant DefaultVariant-   (v:_) -> v- where-  variants = sortBy (compare `on` (negate . suffixLength)) -- longest suffixes first-           $ allVariants-  suffixLength = length . vShortName--allVariants :: [Variant]-allVariants = map toVariant [minBound .. maxBound]---- | The subset of variants appropriate to the given darcs version-appropriateVariants :: Version -> [Variant] -> [Variant]-appropriateVariants v | v < [2,3,97] = filter ((/= OptimizePristineVariant) . vId)-                      | v > [2,4,96] = filter ((/= DefaultVariant) . vId)-                      | otherwise    = id---- ------------------------------------------------------------------------- long-term storage--- -------------------------------------------------------------------------- TODO: machine info? hash this?-paramStampPath :: ParamStamp -> String-paramStampPath p = intercalate "-" [ pHostName p, flushStr ]- where-  flushStr = if isJust (pFlush p) then "cold" else "warm"--timeStampPath :: TimeStamp -> String-timeStampPath t = formatTime defaultTimeLocale "%Y-%m-%dT%H%M" t -- we don't need to be super-precise here--resultsDir :: IO FilePath-resultsDir =- do home <- getHomeDirectory-    return $ home </> ".darcs-benchmark"--timingsDir :: ParamStamp -> IO FilePath-timingsDir cstmp =- do d <- resultsDir-    return $ d </> paramStampPath cstmp <.> "timings"--appendResult :: Test a -> [MemTime] -> IO ()-appendResult (Test benchmark tr (TestBinary bin)) times =- do (pstmp, tstmp) <- readIORef global-    d <- resultsDir-    createDirectoryIfMissing False d-    td <- timingsDir pstmp-    createDirectoryIfMissing False td-    appendFile (td </> timeStampPath tstmp) block- where-   block = unlines $ map (intercalate "\t" . fields) times-   fields mt = [ trName tr, bin, description benchmark ] ++ fieldMt mt-   fieldMt (MemTime m t) = [ show (fromRational m :: Float), show t ]---- ------------------------------------------------------------------------- outputs--- ------------------------------------------------------------------------precision :: Int-precision = 1--data MemTime = MemTime Rational Double deriving (Read, Show, Ord, Eq)--data MemTimeOutput = MemTimeOutput { mtTimeMean    :: Double-                                   , mtTimeDev :: Double-                                   , mtSampleSize :: Int-                                   , mtMemMean     :: Rational-                                   }- deriving (Show)--mkMemTimeOutput :: [MemTime] -> MemTimeOutput-mkMemTimeOutput xs =-  MemTimeOutput { mtTimeMean = mean time_v-                , mtTimeDev  = stdDev time_v-                , mtMemMean  = toRational (mean mem_v)-                , mtSampleSize = lengthU time_v-                }- where-  time_v = toU [ t | MemTime _ t <- xs ]-  mem_v  = toU [ fromRational m | MemTime m _ <- xs ]--data RepoTable = RepoTable { rtRepo :: String-                           , rtColumns :: [String]-                           , rtRows :: [String]-                           , rtTable :: [(TimeUnit, [Maybe MemTimeOutput])]-                           }---- Reformat (test, output) array as a square table by (core) Repository-repoTables :: [Benchmark ()] -> [(Test a, Maybe MemTimeOutput)] -> [RepoTable]-repoTables benchmarks results = [RepoTable { rtRepo = reponame (head repo)-                                           , rtColumns = columns repo-                                           , rtRows = rows-                                           , rtTable = table repo-                                           } | repo <- reposResults]- where-  reposResults = groupBy (on (==) reponame) $ sortBy repoOrder results-  reponame (Test _ tr _, _) = trCoreName tr-  repoOrder = comparing reponame-  ---  rows = map description . filter hasBenchmark $ benchmarks-  hasBenchmark b = any (\ (Test tb _ _, _) -> description tb == description b) results-  ---  columns repo = map mkColName $ columnInfos repo-  columnInfos repo = nub [ (b, trName tr) | (Test _ tr b, _) <- repo ]-  mkColName (TestBinary b, tname) =-    let v = nameToVariant tname-        prefix = case vId v of-                   DefaultVariant -> ""-                   _-> vSuffix v ++ " "-    in prefix ++ cutdown b-  cutdown d | "darcs-" `isPrefixOf` d = cutdown (drop 6 d)-            | takeExtension d == ".exe" = dropExtension d-            | otherwise = d-  ---  table repo = [(tu (tableRow row), map justMemTimeOutput $ tableRow row)-               | row <- rows]-    where-      tableRow row = [find (match row col) repo | col <- columnInfos repo]-      getTime (Just (_, Just mt)) = Just (mtTimeMean mt)-      getTime _ = Nothing-      tu row = case mapMaybe getTime row of-        [] -> Milliseconds-        xs -> appropriateUnit (minimum xs)-  match bench (binary, name) (Test bench' tr binary', _) =-      bench == description bench' && binary == binary' && trName tr == name-  justMemTimeOutput (Just (_, mt)) = mt-  justMemTimeOutput Nothing = Nothing--data TimeUnit = MinutesAndSeconds | Milliseconds--formatTimeElapsed :: TimeUnit -> Double -> String-formatTimeElapsed Milliseconds raw = formatNumber (raw * 1000) ++ "ms"-formatTimeElapsed MinutesAndSeconds raw =- case mins raw of-   Nothing -> formatNumber (secs raw) ++ "s"-   Just m  -> show m ++ "m" ++ formatNumber (secs raw) ++ "s"- where-   secs x = (fromInteger (floor x `mod` 60)) + (x - fromInteger (floor x))-   mins x | x > 60 = Just (floor x `div` 60 :: Int)-          | otherwise = Nothing--appropriateUnit :: Double -> TimeUnit-appropriateUnit s | s < 2     = Milliseconds-                  | otherwise = MinutesAndSeconds--data Cell h a = ColHeader h | Cell a | MissingCell--formatNumber :: (PrintfArg a, Fractional a) => a -> String-formatNumber = printf $ "%."++(show precision)++"f"--type Formatter = TimeUnit -> Cell String MemTimeOutput -> [String]--formatSampleSize :: Formatter-formatSampleSize _ (ColHeader h) = [ h ]-formatSampleSize _ MissingCell = [ "-" ]-formatSampleSize _ (Cell mt) = [ show (mtSampleSize mt) ++ "x" ]--formatTimeResult :: Formatter-formatTimeResult _ (ColHeader h) = [ h, "sdev" ]-formatTimeResult _ MissingCell = [ "-", "-" ]-formatTimeResult tu (Cell mt) =-  [ vouchFor $ time $ mtTimeMean mt, "(" ++ time (mtTimeDev mt) ++ ")" ]- where-   time t = formatTimeElapsed tu t-   vouchFor = case mtSampleSize mt of -- FIXME: YUCK! hard coded; cf. criterion-               sz | sz < 5    -> showChar '?'-                  | sz < 20   -> showChar '~'-                  | otherwise -> id--formatMemoryResult :: Formatter-formatMemoryResult _ (ColHeader s) = [ s ]-formatMemoryResult _ MissingCell = [ "-" ]-formatMemoryResult _ (Cell mt) =-  [ formatNumber ((realToFrac (mtMemMean mt / (1024*1024))) :: Float) ++ "M" ]

@@ -1,15 +0,0 @@-module Dist where--import qualified Codec.Archive.Tar as Tar-import Codec.Compression.GZip( compress )-import qualified Data.ByteString.Lazy as BL-import Data.List ( isPrefixOf )-import System.FilePath--createTarball :: FilePath -> IO ()-createTarball dir = do-  str <- (compress . Tar.write) `fmap` Tar.pack dir [ "." ]-  let tarball = dropPrefix "repo." (takeBaseName dir) <.> "tgz"-  BL.writeFile tarball str- where-  dropPrefix p x = if p `isPrefixOf` x then drop (length p) x else x

@@ -1,53 +0,0 @@-module Download where--import Network.Browser-import Network.URI-import Network.HTTP.Base--import qualified Codec.Archive.Tar as Tar ( read, unpack )-import System.FilePath-import System.Directory-import Codec.Compression.GZip( decompress )-import Control.Monad--baseurl :: String-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 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-      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

@@ -1,54 +0,0 @@-module Graph where--import Data.List-import Graphics.GChart--import Definitions--graphRepoMemory :: RepoTable -> [String]-graphRepoMemory repo = map graphUrl rows- where-  rows = [(title rowname, rtColumns repo, graphdata rowdata)-         | (rowname, (_, rowdata)) <- zip (rtRows repo) (rtTable repo)]-  title rowname = rowname ++ " (MiB)"-  graphdata rowdata = map selectMemory rowdata-  selectMemory (Just mt) = fromRational (mtMemMean mt) / (1024 * 1024)-  selectMemory _ = 0.0--graphRepoTime :: RepoTable -> [String]-graphRepoTime repo = map graphUrl rows- where-  rows = [(title tu rowname, rtColumns repo, graphdata tu rowdata)-         | (rowname, (tu, rowdata)) <- zip (rtRows repo) (rtTable repo)]-  title Milliseconds rowname = rowname ++ " (ms)"-  title MinutesAndSeconds rowname = rowname ++ " (s)"-  graphdata tu rowdata = map (selectTime tu) rowdata-  selectTime Milliseconds (Just mt) = mtTimeMean mt * 1000-  selectTime MinutesAndSeconds (Just mt) = mtTimeMean mt-  selectTime _ _ = 0.0  --graphUrl :: (String, [String], [Double]) -> String-graphUrl (title, labels, results) = getChartUrl $ do-  setChartSize 200 200-  setDataEncoding simple-  setChartType BarVerticalGrouped-  setBarWidthSpacing $ barwidthspacing 23 5 20-  setChartTitle title-  addAxis $ makeAxis { axisType = AxisBottom, axisLabels = Just labels }-  addAxis $ makeAxis { axisType = AxisLeft,-    axisRange = Just $ Range (0, realToFrac range) Nothing }-  setColors palette-  addChartData row- where-  range = case results of-    [] -> 1-    xs -> maximum xs-  row = [truncate (result * 61.0 / range) | result <- results] :: [Int]--- Color palette for bars, based on the Tango palette (Butter, Orange, Choc)-  -- TODO: Adjust palette size based on actual number of results?-  palette = [intercalate "|" ["fce94f"-                            , "c4a000"-                            , "fcaf3e"-                            , "ce5c00"-                            , "e9b96e"-                            , "8f5902"]]

@@ -1,168 +0,0 @@-module Report where--import Control.Arrow-import Control.Monad.Error-import Data.Function-import Data.List-import Data.List.Split-import Data.Maybe-import qualified Data.Map as Map-import qualified Text.Tabular          as Tab-import System.Directory-import System.FilePath-import System.IO--import Definitions-import Graph-import Shellish hiding ( run )-import Standard-import TabularRST as TR---- ------------------------------------------------------------------------- tables--- ------------------------------------------------------------------------type BenchmarkTable = Tab.Table String String String--tabulateRepo :: Formatter -> RepoTable -> Tab.Table String String String-tabulateRepo format repo = Tab.Table rowhdrs colhdrs rows- where-  rowhdrs = Tab.Group Tab.NoLine $ map Tab.Header (rtRows repo)-  colhdrs = Tab.Group Tab.SingleLine $ map Tab.Header $-              concatMap (format myundefined . ColHeader) $ rtColumns repo-  myundefined = error "Formatting is undefined for column headers"-  rows = map formatRow $ rtTable repo-  formatRow (tu, rs) = concatMap (fmt tu) rs-  fmt tu (Just mt) = format tu (Cell mt)-  fmt tu Nothing = format tu MissingCell---- ------------------------------------------------------------------------- timings files--- ------------------------------------------------------------------------readAllTimings :: IO [[(Test a, Maybe MemTimeOutput)]]-readAllTimings = do-  rdir  <- resultsDir-  tdirs <- filter isTimingFile `fmap` getDirectoryContents rdir-  let pstamps = map dropExtension tdirs-  mapM readTimingsForParams pstamps- where-  isTimingFile f = takeExtension f == ".timings"--readTimingsForParams :: String -> IO [(Test a, Maybe MemTimeOutput)]-readTimingsForParams pstamp = do-  rdir  <- resultsDir-  let pdir = rdir </> pstamp <.> "timings"-  -- let ifile = replaceExtension ".timings" ".info" pdir-  tfiles   <- filter notJunk `fmap` getDirectoryContents pdir-  entries  <- concat `fmap` mapM parseTimingsFile (map (pdir </>) tfiles)-  return . map process . Map.toList . Map.fromListWith (++) . map (second (:[])) $ entries- where-  notJunk = not . (`elem` [".",".."])--process :: ((String, String, String), [MemTime]) -> (Test a, Maybe MemTimeOutput)-process ((repo, dbin, bm), times) = (key, val)- where-   key = Test (Description bm) (mkTr repo) (TestBinary dbin)-   val = Just $ mkMemTimeOutput times-   mkTr n = TestRepo n (guessCoreName n) n Nothing []--guessCoreName :: String -> String-guessCoreName n =-  case [ n `chop` (' ':s) | s <- suffixes, s `isSuffixOf` n ] of-   []    -> n-   (h:_) -> h- where-  x `chop` s = take (length x - length s) x-  suffixes   = sortBy (compare `on` (negate . length)) -- longest suffixes first-             $ map vShortName allVariants--type TimingsFileEntry = ((String,String,String),MemTime)--parseTimingsFile :: FilePath -> IO [TimingsFileEntry]-parseTimingsFile tf = do-  ms <- (map parseLine . lines) `fmap` readFile tf-  let unknowns = length $ filter isNothing ms-  when (unknowns > 0) $-    hPutStrLn stderr $ "Warning: could not understand " ++ show unknowns ++ " lines in " ++ tf-  return (catMaybes ms)--parseLine :: String -> Maybe TimingsFileEntry-parseLine l =- case wordsBy (== '\t') l of-  [ repo, dbin, bm, mem, time ] -> Just ((repo, dbin, bm), memtime time mem)-  _ -> Nothing- where-  memtime t m = MemTime (toRational (read m :: Float)) (read t)---- ------------------------------------------------------------------------- reports--- ------------------------------------------------------------------------renderMany :: [(Test a, Maybe MemTimeOutput)] -> Command ()-renderMany results  = do-  echo . unlines $-   [ "Copy and paste below"-   , "====================================================="-   , ""-   , machine_details-   , ""-   , "How to read these tables"-   , "====================================================="-   , ""-   , def "?x" "less than  5 runs used"-   , def "~x" "less than 20 runs used"-   , def "sdev" "std deviation"-   , descriptions_of_variants-   , ""-   , "Timings"-   , "===================================================="-   , ""-   , intercalate "\n" (map showT t_tables)-   , "Memory"-   , "===================================================="-   , ""-   , intercalate "\n" (map showT m_tables)-   , "Timing Graphs"-   , "===================================================="-   , ""-   , intercalate "\n" (map showG t_graphs)-   , "Memory Graphs"-   , "===================================================="-   , ""-   , intercalate "\n" (map showG m_graphs)-   ]- where-  tables = repoTables benchmarks results-  ---  machine_details = intercalate "\n" $-    map detail [ "GHC version"-               , "Machine description", "Year", "CPU", "Memory", "Hard disk"-               , "Notes" ]-  detail k = k ++ "\n    *Replace Me*"-  ---  descriptions_of_variants = intercalate "\n" $-    map (describe . toVariant) [ OptimizePristineVariant ]-  describe v = def (vSuffix v) (vDescription v ++ " variant")-  def k v = "* " ++ k ++ " = " ++ v-  ---  repoTuple tabulate repo = (rtRepo repo, tabulate repo)-  t_tables = map (repoTuple $ tabulateRepo formatTimeResult) tables-  m_tables = map (repoTuple $ tabulateRepo formatMemoryResult) tables-  showT (r,t) = intercalate "\n" [ r-                                 , replicate (length r) '-'-                                 , ""-                                 , TR.render id id id t ]-  ---  t_graphs = map (repoTuple graphRepoTime) tables-  m_graphs = map (repoTuple graphRepoMemory) tables-  showG (r,gs) = intercalate "\n" $ [ r-                                    , replicate (length r) '-'-                                    , ""-                                    ] ++ (map imgDirective gs) ++ [""]-  imgDirective = (".. image:: " ++)--printCumulativeReport :: Command ()-printCumulativeReport = do-  ts <- liftIO readAllTimings-  mapM_ renderMany ts -- TODO: split this into sections for each param stamp

@@ -1,35 +0,0 @@-module Run where--import Control.Monad.Error--import Benchmark-import Definitions-import Report-import Shellish hiding ( run )-import Standard-import qualified TabularRST as TR--benchMany :: [TestRepo] -> [TestBinary] -> [Benchmark a] -> Command [(Test a, Maybe MemTimeOutput)]-benchMany repos bins benches = do-  binsVers <- liftIO $ forM bins $-    \bin@(TestBinary b) -> do v <- darcsVersion b-                              return (bin, v)-  fmap concat $ forM repos $ \r -> do-    res <- sequence-             [ do let test = Test bench repo bin-                  memtime <- run test-                  return (test, memtime)-               | (bin,ver) <- binsVers, repo <- repoAndVariants ver r, bench <- benches ]-    let tables = repoTables benchmarks res-    if length tables == 1 then-      echo_n $ TR.render id id id $ tabulateRepo formatTimeResult (head tables)-      else error "Not expecting more than one table for a repo and its variants"-    return res- where-  repoAndVariants v r = map (r `tweakVia`) (appropriateVariants v (trVariants r))-  tweakVia tr v =-   case vId v of-     DefaultVariant -> tr-     _ -> tr { trPath = variantRepoName v (trPath tr)-             , trName = trName tr ++ " " ++ vShortName v-             }

@@ -1,166 +0,0 @@-module Shellish( cd, pwd, run, (#), withCurrentDirectory, strictGetContents,-                 shellish, silently, verbosely, Command, sub, echo, echo_n,-                 which, canonize, resetMemoryUsed, recordMemoryUsed,-                 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-import System.IO-import System.Directory-import System.Exit-import Control.Monad.State-import Control.Monad.Error-import Data.Time.Clock( getCurrentTime, diffUTCTime, UTCTime(..) )-import Control.Exception ( bracket, evaluate )-import qualified Data.ByteString.Char8 as B-import System.Process( runInteractiveProcess, waitForProcess )-import qualified System.IO.UTF8 as UTF8----- TODO maxMem is sort of a layering violation here... but who cares.-data St = St { sCode :: Int, sStderr :: B.ByteString , sStdout :: B.ByteString,-               sVerbose :: Bool, maxMem :: Int, startTime :: UTCTime }--type Command a = StateT St IO a--cd :: String -> Command ()-cd = liftIO . setCurrentDirectory--mv :: String -> String -> Command ()-mv a b = liftIO $ renameFile a b--ls :: String -> Command [String]-ls dir = liftIO $ (\\ [".", ".."]) `fmap` getDirectoryContents dir--pwd :: Command String-pwd = liftIO $ getCurrentDirectory--echo, echo_n, echo_err, echo_n_err :: String -> Command ()-echo = liftIO . UTF8.putStrLn-echo_n = liftIO . (>> hFlush System.IO.stdout) . UTF8.putStr-echo_err = liftIO . UTF8.hPutStrLn stderr-echo_n_err = liftIO . (>> hFlush stderr) . UTF8.hPutStr stderr--which :: String -> Command (Maybe String)-which = liftIO . findExecutable--canonize :: String -> Command String-canonize = liftIO . canonicalizePath--whenM :: Monad m => m Bool -> m () -> m ()-whenM c a = do res <- c-               when res a--test_e :: String -> Command Bool-test_e f = liftIO $ do-             dir <- doesDirectoryExist f-             file <- doesFileExist f-             return $ file || dir--test_f :: String -> Command Bool-test_f = liftIO . doesFileExist--test_d :: String -> Command Bool-test_d = liftIO . doesDirectoryExist--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-    (_,outH,errH,procH) <- liftIO $ runInteractiveProcess cmd args Nothing Nothing-    st <- get-    res <- liftIO $ B.hGetContents outH-    errs <- liftIO $ B.hGetContents errH-    ex <- liftIO $ waitForProcess procH-    when (sVerbose st) $ do-                 liftIO $ B.putStr res-                 liftIO $ B.putStr errs-    case ex of-      ExitSuccess -> return ()-      ExitFailure n -> fail $ "command " ++ cmd ++ " " ++ show args-                         ++ " failed with exit code " ++ show n-    put $ st { sCode = 0, sStderr = errs, sStdout = res }-    return $ B.unpack res--(#) :: String -> [String] -> Command String-cmd # args = run cmd args--silently :: Command a -> Command a-silently a = do-  x <- get-  put $ x { sVerbose = False }-  r <- a-  put x-  return r--verbosely :: Command a -> Command a-verbosely a = do-  x <- get-  put $ x { sVerbose = True }-  r <- a-  put x-  return r--sub :: Command a -> Command a-sub a = do-  -- TODO save environment as well?-  dir <- liftIO $ getCurrentDirectory-  r <- a `catchError` (\e -> (liftIO $ setCurrentDirectory dir) >> throwError e)-  liftIO $ setCurrentDirectory dir-  return r--shellish :: MonadIO m => Command a -> m a-shellish a = do-  dir <- liftIO $ getCurrentDirectory-  time <- liftIO getCurrentTime-  r <- liftIO $ evalStateT a $ empty time-  liftIO $ setCurrentDirectory dir-  return r-      where empty t = St { sCode = 0, sStderr = B.empty,-                           sStdout = B.empty, sVerbose = True,-                           maxMem = 0, startTime = t }--strictGetContents :: Handle -> IO String-strictGetContents h =-    do res <- hGetContents h-       evaluate (length res)-       return res--withCurrentDirectory :: FilePath -> IO a -> IO a-withCurrentDirectory name m =-    bracket-        (do cwd <- getCurrentDirectory-            when (name /= "") (setCurrentDirectory name)-            return cwd)-        (\oldwd -> setCurrentDirectory oldwd `catch` (\_ -> return ()))-        (const m)--recordMemoryUsed :: Int -> Command ()-recordMemoryUsed u = do-  x <- get-  put x { maxMem = maximum [maxMem x, u] }--resetMemoryUsed :: Command ()-resetMemoryUsed = do-  x <- get-  put x { maxMem = 0 }--resetTimeUsed :: Command ()-resetTimeUsed = do-  x <- get-  t <- liftIO getCurrentTime-  put x { startTime = t }--memoryUsed :: Command Int-memoryUsed = do x <- get-                return $ maxMem x--timeUsed :: Command Float-timeUsed = do x <- get-              t <- liftIO getCurrentTime-              return $ realToFrac $ diffUTCTime t (startTime x)

@@ -1,118 +0,0 @@-module Standard( benchmarks ) where-import System.FilePath-import Shellish-import Benchmark hiding ( darcs )-import Definitions-import Control.Monad( forM_, filterM, when )-import Control.Monad.Trans( liftIO )-import qualified Control.Monad.State as MS--check :: BenchmarkCmd ()-check darcs _ = do-  cd "repo"-  darcs [ "check", "--no-test" ]-  return ()--repair :: BenchmarkCmd ()-repair darcs _ = do-  cd "repo"-  darcs [ "repair" ]-  return ()--annotate :: BenchmarkCmd ()-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 = maybe id (:) (trAnnotate tr) [ "Setup.hs", "Setup.lhs" ]--get :: [String] -> BenchmarkCmd ()-get param darcs _ = do-  darcs $ "get" : param ++ ["repo", "get"]-  return ()--pull :: Int -> BenchmarkCmd ()-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" ]-  return ()---- Oh my eyes! Oh noes! Horrible!-darcs_wh :: [String] -> BenchmarkCmd ()-darcs_wh param darcs _ = do-  state <- MS.get-  newstate <- liftIO $ catch (MS.execStateT (darcs $ "whatsnew" : param) state)-                             (\_ -> return state)-  MS.put newstate--wh :: BenchmarkCmd ()-wh darcs tr = do-  cd "repo"-  darcs_wh [] darcs tr-  return ()--wh_mod :: BenchmarkCmd ()-wh_mod 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__"-  darcs_wh [] darcs tr-  forM_ files $ \f -> mv (f <.> "__foo__") f-  return ()--wh_l :: BenchmarkCmd ()-wh_l darcs tr = do-  cd "repo"-  darcs_wh [ "--look-for-adds" ] darcs tr-  return ()---- | n patches for each file-record_mod :: BenchmarkCmd ()-record_mod darcs _ = do- cd "repo"- files <- filterM test_f =<< ls "."- forM_ files $ \f -> liftIO (appendFile f "x")- darcs [ "record", "-A", "me", "--all", "-m", "test record", "--no-test"]- darcs [ "obliterate", "--last=1", "--all" ]- return ()--revert_mod :: BenchmarkCmd ()-revert_mod darcs _ = do- cd "repo"- files <- filterM test_f =<< ls "."- forM_ files $ \f -> liftIO (appendFile f "foo")- darcs [ "revert", "--all" ]- return ()--revert_unrevert :: BenchmarkCmd ()-revert_unrevert darcs _ = do- cd "repo"- files <- filterM test_f =<< ls "."- forM_ files $ \f -> liftIO (appendFile f (show "foo"))- darcs [ "revert", "--all" ]- darcs [ "unrevert", "--all" ]- darcs [ "revert", "--all" ]- return ()--benchmarks :: [ Benchmark () ]-benchmarks =-       [ Idempotent "wh" FastB wh-       , Idempotent "wh mod" FastB wh_mod-       , Idempotent "wh -l" FastB wh_l-       , Idempotent "record mod" FastB $ record_mod-       , Idempotent "revert mod" FastB revert_mod-       , Idempotent "(un)revert mod" FastB revert_unrevert-       , Destructive "get (full)" SlowB $ get []-       , Destructive "get (lazy)" FastB $ get ["--lazy"]-       , Idempotent "pull 100"    FastB $ pull 100-       , Idempotent "pull 1000" SlowB $ pull 1000-       , Idempotent "check" SlowB check-       , Idempotent "repair" SlowB repair-       , Idempotent "annotate" SlowB annotate-       ]

@@ -1,70 +0,0 @@-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, "" ] -- note the extra blank line- 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) ' '

@@ -1,5 +1,5 @@ name:          darcs-benchmark-version:       0.1.8.3+version:       0.1.9 synopsis:      Comparative benchmark suite for darcs.  description: A simple tool to compare performance of different Darcs 2.x@@ -22,12 +22,11 @@ executable darcs-benchmark     if impl(ghc >= 6.8)       ghc-options: -fwarn-tabs--    ghc-options:   -Wall -threaded -fno-warn-unused-do-bind+    ghc-options:   -Wall -threaded     ghc-prof-options: -prof -auto-all -threaded -    build-depends: base < 5,-                   cmdargs >= 0.1 && < 0.2,+    build-depends: base < 5, strict,+                   cmdargs,                    process, mtl, tabular >= 0.2.2.1,                    time, old-locale,                    regex-posix, html, filepath, directory,@@ -39,9 +38,10 @@                    split == 0.1.*,                    utf8-string == 0.3.*,                    hs-gchart,-                   tar, zlib+                   tar, zlib, SHA, datetime      main-is: main.hs+    hs-source-dirs: source     other-modules: Shellish                    Benchmark                    Config

@@ -1,134 +0,0 @@-#!/usr/bin/env runhaskell-import Shellish( shellish, rm_rf )-import Control.Arrow ( first, second )-import System.Console.CmdArgs-import System.Cmd ( system )-import System.Exit-import System.Directory-import System.IO-import Control.Monad-import Control.Monad.Trans-import Benchmark-import Config (Config(Get,Run,Dist,Report))-import Definitions-import qualified Config as C-import Report-import Run-import Standard-import Dist ( createTarball )-import Download-import Data.List-import Data.Version ( showVersion )-import Paths_darcs_benchmark-import Text.JSON-import Data.IORef--help :: String-help = unlines [ "darcs-benchmark " ++ showVersion version ++ ": run standard darcs benchmarks"-               , ""-               , "Please either specify the repositories and binaries to run on like this:"-               , "$ darcs-benchmark run <binary> [binary] [/ [repository] [repository]]"-               , ""-               , "or alternatively, to run on all available repos:"-               , "$ 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:"-               , ""-               , "binary binary binary"-               , "repo repo repo"-               , ""-               , "(again, if the second line is not there, we run on all available repos)"-               , ""-               , "Thank you for benchmarking darcs!" ]--known_repos :: [String]-known_repos = [ "tabular", "tahoe-lafs", "darcs", "ghc-hashed" ]--download_repos :: [String] -> IO ()-download_repos r = forM_ (if null r then known_repos else r) download--doVMFlush :: FilePath -> IO ()-doVMFlush path = do system "sudo sh -c 'echo 3 > /proc/sys/vm/drop_caches'"-                    system $ path ++ " --version > /dev/null"-                    return ()--config :: [TestRepo] -> C.Config -> IO ([TestRepo], [TestBinary], [Benchmark ()])-config allrepos cfg = do-  case cfg of-   Get {} -> do-      download_repos (C.repos cfg)-      exitWith ExitSuccess-   Dist {} -> do-      createTarball (C.repo cfg)-      exitWith ExitSuccess-   Report {} ->  do-      shellish printCumulativeReport-      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 filter (\b -> speed b == FastB) benchmarks else benchmarks-         usetests = case C.only cfg of-                     [] -> usetests'-                     os -> filter (\b -> any (\o -> o `isInfixOf` show b) os) usetests'-     let setParams p = p { pFlush = if C.cold cfg then Just doVMFlush else Nothing }-     modifyIORef global (first setParams)-     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 n n d Nothing [toVariant DefaultVariant]- where-  n = drop (length "repo.") d--main :: IO ()-main = do-    cfg <- cmdArgs help C.defaultConfig-    allrepos <- do listing <- getDirectoryContents "."-                   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 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 darcs-benchmark get."-         putStrLn $ "(Alternatively, check that you are in the right directory.)"-         exitWith $ ExitFailure 3-    shellish $ do rm_rf "_playground"-                  -- for setting up variants, we probably want the latest/greatest-                  -- version of darcs in case the variant involves some new feature-                  case reverse binaries of-                    []    -> return ()-                    (b:_) -> setupVariants repos b-                  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

@@ -0,0 +1,369 @@+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}+module Benchmark where++import Prelude hiding ( readFile, catch )+import Definitions+import Shellish hiding ( run )+import Data.Typeable( Typeable )+import Data.Char+import Data.List+import Data.Maybe+import Data.DateTime( parseDateTime, startOfTime )+import Data.List.Split ( splitOn )+import System.Directory+import System.Environment+import System.FilePath( (</>), (<.>), splitDirectories, joinPath )+import System.IO hiding ( readFile )+import System.IO.Strict( readFile )+import System.Exit+import Text.Regex.Posix( (=~) )+import Data.Time.Clock+import Control.Monad.Error+import Control.Exception( Exception(..), throw, catch, SomeException )+import Control.Concurrent( forkIO )+import Control.Concurrent.Chan( newChan, writeChan, readChan, Chan )+import System.Console.CmdArgs (isLoud)+import System.Process( runInteractiveProcess, runInteractiveCommand,+                       waitForProcess )+import qualified System.IO.UTF8 as UTF8+import qualified Data.ByteString.Char8 as BS++catchany :: IO a -> (SomeException -> IO a) -> IO a+catchany = catch++copyTree :: FilePath -> FilePath -> IO ()+copyTree from to =+    do subs <- (\\ [".", ".."]) `fmap` getDirectoryContents from+       createDirectory to+       forM_ subs $ \item -> do+         is_dir <- doesDirectoryExist (from </> item)+         is_file <- doesFileExist (from </> item)+         when is_dir $ copyTree (from </> item) (to </> item)+         when is_file $ copyFile (from </> item) (to </> item)++reset :: Command ()+reset = do+  resetMemoryUsed+  resetTimeUsed++exec :: Benchmark a -> TestBinary -> TestRepo -> Command a+exec (Idempotent _ _ cmd) bin tr = do+  cd "_playground"+  verbose "cd _playground"+  cmd (vcs bin) tr+exec (Destructive _ _ cmd) bin tr = do+  cd "_playground"+  let cleanup = verbose "cd .. ; rm -rf _playground" >> cd ".." >> rm_rf "_playground"+  res <- cmd (vcs bin) tr `catch_sh` \(e :: SomeException) -> (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 origrepo = do+  progress "!" >> verbose "rm -rf _playground"+  rm_rf "_playground"+  liftIO $ createDirectory "_playground"+  let playrepo = "_playground" </> "repo"+  isrepo <- liftIO $ doesDirectoryExist (origrepo </> "_darcs")+  progress "." >> verbose ("cp -a '" ++ origrepo ++ "' '" ++ playrepo ++ "'")+  liftIO $ copyTree origrepo playrepo+  progress "." >> verbose ("# sanitize " ++ playrepo)+  wd <- pwd+  mkdir_p (playrepo </> "_darcs" </> "prefs") -- FIXME ... this is not very nice in git repos+  liftIO $ do writeFile (defaultrepo playrepo) (wd </> origrepo)+              removeFile (sources playrepo) `catchany` \_ -> return ()++prepareIfDifferent :: String -> Command ()+prepareIfDifferent origrepo = do+  let playrepo = "_playground" </> "repo"+  exist <- test_e "_playground"+  isrepo <- test_d $ playrepo </> "_darcs"+  if isrepo then do+    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 progress "..." >> verbose ("# leaving " ++ playrepo ++ " alone")+       else prepare origrepo+   else prepare origrepo++-- | Run a benchmark as many times as it takes to pass a minimum threshold+--   of time or iterations (whichever comes first)+--   Useful for very small benchmarks+adaptive :: Double -- ^ seconds+         -> (Int,Int) -- ^ min, max iterations+         -> Command MemTime -> Command [MemTime]+adaptive thresh (iters_min,iters_max) cmd =+   cmd >> -- just once to warm up the disk cache (eliminate a source of variance)+   go thresh iters_max []+ where+  go t i acc | i <= 0 || (t <= 0 && i <= iters_enough) = return acc+  go t i acc =+   do verbose $ "# adaptive: iterations remaining: " ++ show i ++ " time remaining: " ++ show t+      mt@(MemTime _ t2) <- cmd+      go (t - t2) (i - 1) (mt : acc)+  iters_enough = iters_max - iters_min++run :: Test a -> Command (Maybe MemTimeOutput)+run test@(Test benchmark tr bin) = do+  (Just `fmap` run') `catch_sh` \(e :: SomeException) ->+      do echo_err $ " error: " ++ show e+         return Nothing+  where run' = do+          progress $ cmd ++ " " ++ description benchmark ++ " [" ++ trName tr ++ "]: "+          verbose $ "\n# testing; binary = " ++ cmd ++ ", benchmark = " +++                    description benchmark ++ ", repository = " ++ trName tr+          times <- adaptive 10 (3,100) . sub $ do+                     prepareIfDifferent (trPath tr)+                     binPath bin >>= liftIO . maybeVMFlush+                     m <- timed (exec benchmark bin tr)+                     return m+          let result = mkMemTimeOutput times+              spaces = 45 - (length cmd + length (description benchmark) + length (trName tr))+              tu = appropriateUnit (mtTimeMean result)+              result_str = unwords $ concatMap (\f -> f tu (Cell result)) [ formatTimeResult, formatMemoryResult, formatSampleSize ]+          liftIO $ appendResult test times+          progress $ (replicate spaces ' ') ++ result_str ++ "\n"+          verbose $ "# result: " ++ result_str+          return result+        cmd = binCommand bin++timed :: Command a -> Command MemTime+timed a = do+  resetMemoryUsed+  t1 <- liftIO $ getCurrentTime+  _ <- a+  t2 <- liftIO $ getCurrentTime+  mem <- memoryUsed+  resetMemoryUsed+  return $ MemTime (fromIntegral mem) (realToFrac $ diffUTCTime t2 t1)++darcsMeta :: String -> [String] -> IO String+darcsMeta cmd args = do+       (_,outH,_,procH) <- runInteractiveProcess cmd args Nothing Nothing+       out <- strictGetContents outH+       _ <- waitForProcess procH+       return out++check_vcs :: String -> IO TestBinary+check_vcs cmd = do+  ver <- darcsMeta cmd ["--version"]+  case ver of+    _ | "git" `isPrefixOf` ver ->+      return TestBinary { binCommand = cmd+                        , binVCS = VCSGit+                        , binVersionString = numeric ver+                        , binDate = startOfTime+                        , binGHC = "none at all"+                        , binContext = BS.empty }+    _ | "Mercurial" `isPrefixOf` ver ->+      return TestBinary { binCommand = cmd+                        , binVCS = VCSHg+                        , binVersionString = numeric ver+                        , binDate = startOfTime+                        , binGHC = "none at all"+                        , binContext = BS.empty }+    _ -> check_darcs cmd+  where numeric str = takeWhile (`elem` "1234567890.-") $ dropWhile (`notElem` "1234567890") str+++check_darcs :: String -> IO TestBinary+check_darcs cmd = do+       version <- darcsMeta cmd ["--version"]+       [info, context] <- splitOn "Context:\n\n" `fmap` darcsMeta cmd ["--exact-version"]+       rts <- read `fmap` darcsMeta cmd ["+RTS", "--info"]+       let date' = case info of+             _ | "darcs compiled on" `isPrefixOf` info ->+               drop 18 . takeWhile (/='\n') $ info+             _ -> "<unknown date>"+           date = fromMaybe startOfTime $ parseDateTime "%b %e %Y, at %H:%M:%S" date'+           bin = TestBinary { binCommand = cmd+                            , binVCS = VCSDarcs+                            , binVersionString = takeWhile (/='\n') version+                            , binDate = date+                            , binGHC = fromMaybe "unknown" $ lookup "GHC version" rts+                            , binContext = BS.pack context }+       case binVersion bin of+         2:_ -> return bin+         _ -> fail $ cmd ++ ": Not darcs 2.x binary."++verbose :: String -> Command ()+verbose m = liftIO $ do loud <- isLoud+                        when loud $ UTF8.hPutStrLn stderr m++progress :: String -> Command ()+progress m = liftIO $ do loud <- isLoud+                         unless loud $ UTF8.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 ++ "\n")+                              `catchany` \_ -> writeChan chan acc+                  _ <- forkIO $ work ""+                  return chan++readFile' :: FilePath -> IO String+readFile' f = do s <- readFile f+                 length s `seq` return s++data RunFailed = RunFailed String Int String deriving (Typeable)++instance Show RunFailed where+  show (RunFailed cmd code errs) =+    "error running " ++ cmd ++ ": exit status " ++ show code ++ ":\n" ++ errs++instance Exception RunFailed++runInPlayground :: String -> [String] -> Command String+runInPlayground cmd args = do+    loud <- liftIO isLoud+    verbose . unwords $ cmd:args+    liftIO $ do+       mPlayground <- seekPlayground `fmap` getCurrentDirectory+       mEnv <- case mPlayground of+                 Nothing -> return Nothing+                 Just p  -> (Just . replace "HOME" p) `fmap` getEnvironment+       (_,outH,errH,procH) <- runInteractiveProcess cmd args Nothing mEnv+       res' <- drain outH loud+       errs' <- drain errH loud+       ex <- waitForProcess procH+       errs <- readChan errs'+       case ex of+         ExitSuccess -> return ()+         ExitFailure n -> throw $ RunFailed (cmd ++ " " ++ show args) n errs+       res <- readChan res'+       return res+ where+  replace k v xs = (k,v) : filter ((/= k) . fst) xs++binPath :: TestBinary -> Command String+binPath bin = do exe <- which (binCommand bin)+                 case exe of+                   Nothing -> canonize $ binCommand bin+                   Just p -> return p++vcs :: TestBinary -> [String] -> Command String+vcs bin args =+  do exe <- binPath bin+     case binVCS bin of+       VCSDarcs -> darcs exe args+       VCSGit -> git exe args+       VCSHg -> hg exe args++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"]+    res <- runInPlayground cmd args+    stats <- liftIO $ do c <- readFile' stats_f+                         removeFile stats_f `catchany` \e -> hPutStrLn stderr (show e)+                         return c+                       `catchany` \_ -> return ""+    let bytes = (stats =~ "([0-9, ]+) M[bB] total memory in use") :: String+        mem = case length bytes of+          0 -> 0+          _ -> (read (filter (`elem` "0123456789") bytes) :: Int)+    recordMemoryUsed $ mem * 1024 * 1024+    return res++git :: String -> [String] -> Command String+git cmd args = case args of+  ["obliterate", "--last", n, "--all"] -> obliterate n+  _ -> runInPlayground cmd ("--no-pager" : args')+  where args' | ("whatsnew":rem) <- args = "diff" : rem+              | ("revert":rem) <- args = "reset" : "--hard" : filter (/="-a") rem+              | ("record":rem) <- args = "commit" : filter (/= "--no-test") rem+              | ("get":rem) <- args = "clone" : rem+              | otherwise = args+        obliterate n = do+          rev <- (last . lines) `fmap` runInPlayground cmd+                             ["rev-list", "--max-count=" ++ n, "HEAD"]+          runInPlayground cmd ["reset", "--hard", rev]++hg :: String -> [String] -> Command String+hg cmd args = case args of+  ["obliterate", "--last", "1", "--all"] -> rollback+  _ ->  runInPlayground cmd args'+  where args' | ("whatsnew":rem) <- args = "diff" : rem+              | ("record":rem) <- args = "commit" : [ if opt == "--author" then "--user" else opt+                                                    | opt <- rem, opt /= "--no-test", opt /= "--all" ]+              | ("get":rem) <- args = "clone" : rem+              | otherwise = args+        rollback = do runInPlayground cmd ["rollback"]+                      runInPlayground cmd ["revert", "-a"]++seekPlayground :: FilePath -> Maybe FilePath+seekPlayground dir =+ if playground `elem` pieces+    then Just . joinPath . reverse . dropWhile (/= playground) . reverse $ pieces+    else Nothing+ where+  pieces = splitDirectories dir+  playground = "_playground"++-- ----------------------------------------------------------------------+-- variants+-- ----------------------------------------------------------------------++mkVariant :: String -> TestBinary -> Variant -> Command ()+mkVariant origrepo bin v = do+  isrepo <- liftIO $ doesDirectoryExist (origrepo </> "_darcs")+  unless isrepo $ fail $ origrepo ++ ": Not a darcs repository!"+  case vId v of+    OptimizePristineVariant -> do+      variant_isrepo  <- liftIO $ doesDirectoryExist (variant_repo </> "_darcs")+      unless variant_isrepo $ do+        echo $ "Setting up " ++ vDescription v ++ " variant of " ++ origrepo+        verbose ("cp -a '" ++ origrepo ++ "' '" ++ variant_repo ++ "'")+        liftIO $ copyTree origrepo variant_repo+        verbose ("# sanitize " ++ variant_repo)+        liftIO $ removeFile (sources variant_repo) `catchany` \_ -> return ()+        darcs (binCommand bin) [ "optimize", "--pristine", "--repodir", variant_repo ]+        return ()+    GitVariant -> do+      variant_exists <- liftIO $ doesDirectoryExist (variant_repo </> ".git")+      unless variant_exists $ do+        mkdir_p variant_repo+        sub $ do+          cd variant_repo+          system "git init"+          system ("darcs convert --export ../" ++ origrepo ++ " | git fast-import")+          system "git checkout"+        return ()+    HgVariant -> do+      variant_exists <- liftIO $ doesDirectoryExist (variant_repo </> ".hg")+      gitvariant <- case reverse variant_repo of+            'g':'h':'-':rest -> return $ reverse rest ++ "-git"+            _ -> fail "can't figure the git variant..."+      unless variant_exists $ do+        mkVariant origrepo bin (toVariant GitVariant)+        system $ "hg convert " ++ gitvariant ++ " " ++ variant_repo+        sub $ cd variant_repo >> system "hg checkout"+        return ()+    DefaultVariant -> return ()+ where+  variant_repo = variantRepoName v origrepo++variantRepoName :: Variant -> String -> String+variantRepoName (Variant { vId = DefaultVariant }) x = x+variantRepoName v x = "variant" <.> stripped x ++ "-" ++ vSuffix v+ where+  stripped y | "repo."   `isPrefixOf` y = stripped (drop 5 y)+             | "-hashed" `isSuffixOf` y = take (length y -  7) y+             | otherwise = y++setupVariants :: [TestRepo] -> TestBinary -> Command ()+setupVariants repos bin =+  sequence_ [ mkVariant (trPath repo) bin variant+            | repo <- repos, variant <- trVariants repo ]

@@ -0,0 +1,30 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Config where++import System.Console.CmdArgs++data Config = Get { repos :: [String] }+            | Run { fast  :: Bool+                  , converge :: Bool+                  , cold  :: Bool+                  , only  :: [String]+                  , dump  :: Bool+                  , extra :: [String] }+            | Dist { repo :: FilePath }+            | Report+              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"+              , converge = False &= text "Focus on benchmarks with not enough data"+              , cold = False &= text "Try to flush VM caches between iterations"+              , 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"+              }+ , mode $ Dist { repo = "" &= argPos 0 & typ "DIRECTORY" }+ , mode $ Report+ ]

@@ -0,0 +1,363 @@+module Definitions where++import Prelude hiding ( readFile )+import System.IO.Strict( readFile )+import Control.Applicative+import Data.Array.Vector+import Data.Function+import Data.IORef+import Data.List+import Data.List.Split ( wordsBy, splitOn )+import Data.Maybe+import Data.DateTime( DateTime, formatDateTime )+import Data.Ord+import Data.Time+import Data.Char+import Data.Digest.Pure.SHA+import Network.BSD ( HostName, getHostName )+import Statistics.Sample+import System.Directory+import System.FilePath+import System.Locale+import System.IO.Unsafe+import Text.JSON+import Text.Printf+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as BL++import Shellish (Command)++type Darcs = [String] -> Command String++data Test a = Test (Benchmark a) TestRepo TestBinary deriving (Show)+data VCS = VCSDarcs | VCSGit | VCSHg deriving (Eq, Ord, Show, Read)++data TestBinary = TestBinary { binCommand :: String+                             , binVersionString :: String+                             , binDate :: DateTime+                             , binGHC :: String+                             , binVCS :: VCS+                             , binContext :: BS.ByteString }+                deriving (Eq, Ord, Show, Read)++binVersion :: TestBinary -> [Int]+binVersion = parsever . binVersionString+  where parsever = map read . wordsBy (== '.') . takeWhile (`elem` "0123456789.-")++binSha1 :: TestBinary -> String+binSha1 bin = showDigest (sha1 $ BL.fromChunks [BS.pack txt, binContext bin])+  where txt = show (binVersionString bin) ++ " " +++              (formatDateTime "%Y-%m-%d %H:%M:%S" $ binDate bin) ++ " "++data ParamStamp = Params { pHostName :: HostName+                         , pFlush :: Maybe (FilePath -> IO ()) }+type TimeStamp = UTCTime++type Version = [Int] -- we could also use Data.Version+                     -- the difference here is just that we explicitly+                     -- do not have a notion of version tags++global :: IORef (ParamStamp, TimeStamp)+global = unsafePerformIO $ do t  <- getCurrentTime+                              hn <- getHostName+                              newIORef (Params hn Nothing, t)++maybeVMFlush :: FilePath -> IO ()+maybeVMFlush darcs = do+ (p,_) <- readIORef global+ case pFlush p of+  Just f  -> f darcs+  Nothing -> return ()++-- ----------------------------------------------------------------------+-- benchmarks+-- ----------------------------------------------------------------------++type BenchmarkCmd a = Darcs -> TestRepo -> Command a++data BenchmarkSpeed = FastB | SlowB deriving (Eq)++data Benchmark a = Idempotent String BenchmarkSpeed (BenchmarkCmd a)+                 | Destructive String BenchmarkSpeed (BenchmarkCmd a)+                 | Description String++instance Show (Benchmark a) where+    show = description -- FIXME: is this right?++description :: Benchmark a -> String+description (Idempotent d _ _) = d+description (Destructive d _ _) = d+description (Description d) = d++speed :: Benchmark a -> BenchmarkSpeed+speed (Idempotent _ s _) = s+speed (Destructive _ s _) = s+speed (Description _) = FastB++-- ----------------------------------------------------------------------+-- repositories+-- ----------------------------------------------------------------------++data TestRepo = TestRepo { trName     :: String+                         , trCoreName :: String   -- ^ (variants only) name of the orig repo+                         , trPath     :: FilePath -- ^ relative to the config file+                         , trAnnotate :: Maybe FilePath -- ^ relative to repo, eg. @Just "README"@+                         , trVariants :: [Variant]+                         , trSkip     :: [String] -- ^ skip benchmarks w/ description matching any of these strings+                         }+ deriving (Read, Show, Eq, Ord)++instance JSON TestRepo where+  readJSON (JSObject o) =+     TestRepo <$> jlookup "name"+              <*> jlookup "name" -- 2nd time for trCoreName+              <*> jlookup "path"+              <*> jlookupMaybe "annotate"+              <*> (map toVariant . (DefaultVariant :) <$> jlookupMaybeList "variants")+              <*> jlookupMaybeList "skip"+    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+     jlookupMaybeList a = case lookup a (fromJSObject o) of+                            Nothing -> return []+                            Just v  -> readJSONs v+  readJSON _ = fail "Unable to read TestRepo"+  showJSON = error "showJSON not defined for TestRepo yet"++-- note that the order of the variants is reflected in the tables+data VariantName = DefaultVariant | OptimizePristineVariant | GitVariant | HgVariant+ deriving (Enum, Bounded, Eq, Ord, Read, Show)++instance JSON VariantName where+  readJSON (JSString s) =+    case fromJSString s of+      "optimize-pristine" -> return OptimizePristineVariant+      "git" -> return GitVariant+      "hg" -> return HgVariant+      x -> fail $ "Unknown variant: " ++ x+  readJSON _ = fail "Unable to VariantName"+  showJSON = error "showJSON not defined for VariantName yet"++data Variant = Variant { vId :: VariantName+                       , vShortName   :: String+                       , vDescription :: String+                       , vSuffix :: String+                       }+ deriving (Eq, Ord, Show, Read)++toVariant :: VariantName -> Variant+toVariant n@DefaultVariant =+  Variant n "default"  "default (hashed)" ""+toVariant n@OptimizePristineVariant =+  Variant n "opt pris" "optimize --pristine" "op"+toVariant n@GitVariant =+  Variant n "git" "git" "git"+toVariant n@HgVariant =+  Variant n "hg" "hg" "hg"++-- | Given a name of a repo like "tabular opt pris", figure out what the+--   variant was.  If there are no suffixes, like "opt pris", we assume+--   it's not a variant.+nameToVariant :: String -> Variant+nameToVariant n =+  case [ v | v <- variants, vShortName v `isSuffixOf` n ] of+   []    -> toVariant DefaultVariant+   (v:_) -> v+ where+  variants = sortBy (compare `on` (negate . suffixLength)) -- longest suffixes first+           $ allVariants+  suffixLength = length . vShortName++allVariants :: [Variant]+allVariants = map toVariant [minBound .. maxBound]++-- | The subset of variants appropriate to the given darcs version+appropriateVariants :: TestBinary -> [Variant] -> [Variant]+appropriateVariants bin = filter (appropriate . vId)+  where appropriate GitVariant+          | vcs /= VCSGit = False+        appropriate HgVariant+          | vcs /= VCSHg = False+        appropriate OptimizePristineVariant+          | vcs /= VCSDarcs || ver < [2,3,97] = False+        appropriate DefaultVariant+          | vcs /= VCSDarcs || ver > [2,4,96] = False+        appropriate _ = True+        vcs = binVCS bin+        ver = binVersion bin++-- ----------------------------------------------------------------------+-- long-term storage+-- ----------------------------------------------------------------------++-- TODO: machine info? hash this?+paramStampPath :: ParamStamp -> String+paramStampPath p = intercalate "-" [ pHostName p, flushStr ]+ where+  flushStr = if isJust (pFlush p) then "cold" else "warm"++timeStampPath :: TimeStamp -> String+timeStampPath t = formatTime defaultTimeLocale "%Y-%m-%dT%H%M" t -- we don't need to be super-precise here++resultsDir :: IO FilePath+resultsDir =+ do home <- getHomeDirectory+    return $ home </> ".darcs-benchmark"++timingsDir :: ParamStamp -> IO FilePath+timingsDir cstmp =+ do d <- resultsDir+    return $ d </> paramStampPath cstmp <.> "timings"++appendBinary :: TestBinary -> IO ()+appendBinary bin =+ do (pstmp, _) <- readIORef global+    path <- flip replaceExtension "info" `fmap` timingsDir pstmp+    current <- (read `fmap` readFile path) `catch` \_ -> return []+    let new = (sha, bin) : [ (s, x) | (s, x) <- current, s /= sha ]+    writeFile path (show new)+   where sha = binSha1 bin++appendResult :: Test a -> [MemTime] -> IO ()+appendResult (Test benchmark tr bin) times =+ do (pstmp, tstmp) <- readIORef global+    d <- resultsDir+    createDirectoryIfMissing False d+    td <- timingsDir pstmp+    createDirectoryIfMissing False td+    appendFile (td </> timeStampPath tstmp) block+ where+   block = unlines $ map (intercalate "\t" . fields) times+   fields mt = [ trName tr, binSha1 bin, description benchmark ] ++ fieldMt mt+   fieldMt (MemTime m t) = [ show (fromRational m :: Float), show t ]++-- ----------------------------------------------------------------------+-- outputs+-- ----------------------------------------------------------------------++precision :: Int+precision = 1++data MemTime = MemTime Rational Double deriving (Read, Show, Ord, Eq)++data MemTimeOutput = MemTimeOutput { mtTimeMean    :: Double+                                   , mtTimeDev :: Double+                                   , mtSampleSize :: Int+                                   , mtMemMean     :: Rational+                                   }+ deriving (Show)++mkMemTimeOutput :: [MemTime] -> MemTimeOutput+mkMemTimeOutput xs =+  MemTimeOutput { mtTimeMean = mean time_v+                , mtTimeDev  = stdDev time_v+                , mtMemMean  = toRational (mean mem_v)+                , mtSampleSize = lengthU time_v+                }+ where+  time_v = toU [ t | MemTime _ t <- xs ]+  mem_v  = toU [ fromRational m | MemTime m _ <- xs ]++data RepoTable = RepoTable { rtRepo :: String+                           , rtColumns :: [String]+                           , rtRows :: [String]+                           , rtTable :: [(TimeUnit, [Maybe MemTimeOutput])]+                           }++-- Reformat (test, output) array as a square table by (core) Repository+repoTables :: [Benchmark ()] -> [(Test a, Maybe MemTimeOutput)] -> [RepoTable]+repoTables benchmarks results = [RepoTable { rtRepo = reponame (head repo)+                                           , rtColumns = columns repo+                                           , rtRows = rows+                                           , rtTable = table repo+                                           } | repo <- reposResults]+ where+  reposResults = groupBy (on (==) reponame) $ sortBy repoOrder results+  reponame (Test _ tr _, _) = trCoreName tr+  repoOrder = comparing reponame+  --+  rows = map description . filter hasBenchmark $ benchmarks+  hasBenchmark b = any (\ (Test tb _ _, _) -> description tb == description b) results+  --+  columns repo = map mkColName $ columnInfos repo+  columnInfos repo = nub [ (b, trName tr) | (Test _ tr b, _) <- repo ]+  mkColName (b, tname) =+    let v = nameToVariant tname+        prefix = case vId v of+                   DefaultVariant -> ""+                   _-> vSuffix v ++ " "+    in prefix ++ cutdown (binCommand b)+  cutdown d | "darcs-" `isPrefixOf` d = cutdown (drop 6 d)+            | takeExtension d == ".exe" = dropExtension d+            | otherwise = d+  --+  table repo = [(tu (tableRow row), map justMemTimeOutput $ tableRow row)+               | row <- rows]+    where+      tableRow row = [find (match row col) repo | col <- columnInfos repo]+      getTime (Just (_, Just mt)) = Just (mtTimeMean mt)+      getTime _ = Nothing+      tu row = case mapMaybe getTime row of+        [] -> Milliseconds+        xs -> appropriateUnit (minimum xs)+  match bench (binary, name) (Test bench' tr binary', _) =+      bench == description bench' && binary == binary' && trName tr == name+  justMemTimeOutput (Just (_, mt)) = mt+  justMemTimeOutput Nothing = Nothing++data TimeUnit = MinutesAndSeconds | Milliseconds++formatTimeElapsed :: TimeUnit -> Double -> String+formatTimeElapsed Milliseconds raw = formatNumber (raw * 1000) ++ "ms"+formatTimeElapsed MinutesAndSeconds raw =+ case mins raw of+   Nothing -> formatNumber (secs raw) ++ "s"+   Just m  -> show m ++ "m" ++ formatNumber (secs raw) ++ "s"+ where+   secs x = (fromInteger (floor x `mod` 60)) + (x - fromInteger (floor x))+   mins x | x > 60 = Just (floor x `div` 60 :: Int)+          | otherwise = Nothing++appropriateUnit :: Double -> TimeUnit+appropriateUnit s | s < 2     = Milliseconds+                  | otherwise = MinutesAndSeconds++data Cell h a = ColHeader h | Cell a | MissingCell++formatNumber :: (PrintfArg a, Fractional a) => a -> String+formatNumber = printf $ "%."++(show precision)++"f"++type Formatter = TimeUnit -> Cell String MemTimeOutput -> [String]++formatSampleSize :: Formatter+formatSampleSize _ (ColHeader h) = [ h ]+formatSampleSize _ MissingCell = [ "-" ]+formatSampleSize _ (Cell mt) = [ show (mtSampleSize mt) ++ "x" ]++formatTimeResult :: Formatter+formatTimeResult _ (ColHeader h) = [ h, "sdev" ]+formatTimeResult _ MissingCell = [ "-", "-" ]+formatTimeResult tu (Cell mt) =+  [ vouchFor $ time $ combineMeanStddev mt, "(" ++ time (mtTimeDev mt) ++ ")" ]+ where+   time t = formatTimeElapsed tu t+   vouchFor = case mtSampleSize mt of -- FIXME: YUCK! hard coded; cf. criterion+               sz | sz < 5    -> showChar '?'+                  | sz < 20   -> showChar '~'+                  | otherwise -> id++-- | This is simply mean + stddev, but we could potentially+--   change it in the future to, for example, mean + 2 stddev+combineMeanStddev :: MemTimeOutput -> Double+combineMeanStddev mt = mtTimeMean mt + mtTimeDev mt++formatMemoryResult :: Formatter+formatMemoryResult _ (ColHeader s) = [ s ]+formatMemoryResult _ MissingCell = [ "-" ]+formatMemoryResult _ (Cell mt) =+  [ formatNumber ((realToFrac (mtMemMean mt / (1024*1024))) :: Float) ++ "M" ]

@@ -0,0 +1,15 @@+module Dist where++import qualified Codec.Archive.Tar as Tar+import Codec.Compression.GZip( compress )+import qualified Data.ByteString.Lazy as BL+import Data.List ( isPrefixOf )+import System.FilePath++createTarball :: FilePath -> IO ()+createTarball dir = do+  str <- (compress . Tar.write) `fmap` Tar.pack dir [ "." ]+  let tarball = dropPrefix "repo." (takeBaseName dir) <.> "tgz"+  BL.writeFile tarball str+ where+  dropPrefix p x = if p `isPrefixOf` x then drop (length p) x else x

@@ -0,0 +1,53 @@+module Download where++import Network.Browser+import Network.URI+import Network.HTTP.Base++import qualified Codec.Archive.Tar as Tar ( read, unpack )+import System.FilePath+import System.Directory+import Codec.Compression.GZip( decompress )+import Control.Monad++baseurl :: String+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 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+      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

@@ -0,0 +1,54 @@+module Graph where++import Data.List+import Graphics.GChart++import Definitions++graphRepoMemory :: RepoTable -> [String]+graphRepoMemory repo = map graphUrl rows+ where+  rows = [(title rowname, rtColumns repo, graphdata rowdata)+         | (rowname, (_, rowdata)) <- zip (rtRows repo) (rtTable repo)]+  title rowname = rowname ++ " (MiB)"+  graphdata rowdata = map selectMemory rowdata+  selectMemory (Just mt) = fromRational (mtMemMean mt) / (1024 * 1024)+  selectMemory _ = 0.0++graphRepoTime :: RepoTable -> [String]+graphRepoTime repo = map graphUrl rows+ where+  rows = [(title tu rowname, rtColumns repo, graphdata tu rowdata)+         | (rowname, (tu, rowdata)) <- zip (rtRows repo) (rtTable repo)]+  title Milliseconds rowname = rowname ++ " (ms)"+  title MinutesAndSeconds rowname = rowname ++ " (s)"+  graphdata tu rowdata = map (selectTime tu) rowdata+  selectTime Milliseconds (Just mt) = combineMeanStddev mt * 1000+  selectTime MinutesAndSeconds (Just mt) = combineMeanStddev mt+  selectTime _ _ = 0.0  ++graphUrl :: (String, [String], [Double]) -> String+graphUrl (title, labels, results) = getChartUrl $ do+  setChartSize 200 200+  setDataEncoding simple+  setChartType BarVerticalGrouped+  setBarWidthSpacing $ barwidthspacing 23 5 20+  setChartTitle title+  addAxis $ makeAxis { axisType = AxisBottom, axisLabels = Just labels }+  addAxis $ makeAxis { axisType = AxisLeft,+    axisRange = Just $ Range (0, realToFrac range) Nothing }+  setColors palette+  addChartData row+ where+  range = case results of+    [] -> 1+    xs -> maximum xs+  row = [truncate (result * 61.0 / range) | result <- results] :: [Int]+-- Color palette for bars, based on the Tango palette (Butter, Orange, Choc)+  -- TODO: Adjust palette size based on actual number of results?+  palette = [intercalate "|" ["fce94f"+                            , "c4a000"+                            , "fcaf3e"+                            , "ce5c00"+                            , "e9b96e"+                            , "8f5902"]]

@@ -0,0 +1,221 @@+module Report where++import Control.Arrow+import Control.Monad.Error+import Data.Function+import Data.List+import Data.List.Split+import Data.Maybe+import Data.DateTime( formatDateTime, startOfTime )+import qualified Data.Map as Map+import qualified Text.Tabular          as Tab+import System.Directory+import System.FilePath+import System.IO++import Definitions+import Graph+import Shellish hiding ( run )+import Standard+import TabularRST as TR+import qualified Data.ByteString.Char8 as BS++-- ----------------------------------------------------------------------+-- tables+-- ----------------------------------------------------------------------++type BenchmarkTable = Tab.Table String String String++tabulateRepo :: Formatter -> RepoTable -> Tab.Table String String String+tabulateRepo format repo = Tab.Table rowhdrs colhdrs rows+ where+  rowhdrs = Tab.Group Tab.NoLine $ map Tab.Header (rtRows repo)+  colhdrs = Tab.Group Tab.SingleLine $ map Tab.Header $+              concatMap (format myundefined . ColHeader) $ rtColumns repo+  myundefined = error "Formatting is undefined for column headers"+  rows = map formatRow $ rtTable repo+  formatRow (tu, rs) = concatMap (fmt tu) rs+  fmt tu (Just mt) = format tu (Cell mt)+  fmt tu Nothing = format tu MissingCell++-- ----------------------------------------------------------------------+-- timings files+-- ----------------------------------------------------------------------++readAllTimings :: IO [[(Test a, Maybe MemTimeOutput)]]+readAllTimings = do+  rdir  <- resultsDir+  tdirs <- filter isTimingFile `fmap` getDirectoryContents rdir+  let pstamps = map dropExtension tdirs+  mapM readTimingsForParams pstamps+ where+  isTimingFile f = takeExtension f == ".timings"++unknownBinary x =+  TestBinary { binCommand = x, binVersionString = "unknown"+             , binDate = startOfTime, binGHC = "unknown", binVCS = VCSDarcs+             , binContext = BS.empty }++-- | Map an sha1 of darcs binary into the original binary description.+readInfos :: String -> (String -> TestBinary)+readInfos bits = \x -> case lookup x table of+  Nothing -> unknownBinary x+  Just b -> b+  where table' = sortBy order (case reads bits of+                                  [] -> []+                                  ((x,_):_) -> x)+        ids = [ id | (id:_:_) <- group . sort $ map (binCommand . snd) table' ]+        fixid n id ((sha, bin):rem)+          | binCommand bin == id = (sha, bin { binCommand = id ++ " " ++ show n }) :+                                       fixid (n + 1) id rem+          | otherwise = (sha, bin) : fixid n id rem+        fixid _ _ [] = []+        table = (foldl (.) id (map (fixid 0) ids)) table'+        order (_, x) (_, y) = case compare (binVersion x) (binVersion y) of+          EQ -> compare (binDate x) (binDate y)+          ord -> ord++readTimingsForParams :: String -> IO [(Test a, Maybe MemTimeOutput)]+readTimingsForParams pstamp = do+  rdir  <- resultsDir+  let pdir = rdir </> pstamp <.> "timings"+      ifile = rdir </> pstamp <.> "info"+  infos <- (readInfos `fmap` readFile ifile) `catch` \_ -> do+    hPutStrLn stderr $ "WARNING: Could read " ++ ifile+    return unknownBinary+  tfiles   <- filter notJunk `fmap` getDirectoryContents pdir+  entries  <- concat `fmap` mapM parseTimingsFile (map (pdir </>) tfiles)+  return . map (process infos) . Map.toList . Map.fromListWith (++) . map (second (:[])) $ entries+ where+  notJunk = not . (`elem` [".",".."])++process :: (String -> TestBinary)+           -> ((String, String, String), [MemTime]) -> (Test a, Maybe MemTimeOutput)+process infos ((repo, binhash, bm), times) = (key, val)+ where+   key = Test (Description bm) (mkTr repo) (infos binhash)+   val = Just $ mkMemTimeOutput times+   mkTr n = TestRepo n (guessCoreName n) n Nothing [] []++guessCoreName :: String -> String+guessCoreName n =+  case [ n `chop` (' ':s) | s <- suffixes, s `isSuffixOf` n ] of+   []    -> n+   (h:_) -> h+ where+  x `chop` s = take (length x - length s) x+  suffixes   = sortBy (compare `on` (negate . length)) -- longest suffixes first+             $ map vShortName allVariants++type TimingsFileEntry = ((String,String,String),MemTime)++parseTimingsFile :: FilePath -> IO [TimingsFileEntry]+parseTimingsFile tf = do+  ms <- (map parseLine . lines) `fmap` readFile tf+  let unknowns = length $ filter isNothing ms+  when (unknowns > 0) $+    hPutStrLn stderr $ "Warning: could not understand " ++ show unknowns ++ " lines in " ++ tf+  return (catMaybes ms)++parseLine :: String -> Maybe TimingsFileEntry+parseLine l =+ case wordsBy (== '\t') l of+  [ repo, dbin, bm, mem, time ] -> Just ((repo, dbin, bm), memtime time mem)+  _ -> Nothing+ where+  memtime t m = MemTime (toRational (read m :: Float)) (read t)++-- ----------------------------------------------------------------------+-- reports+-- ----------------------------------------------------------------------++renderMany :: [(Test a, Maybe MemTimeOutput)] -> Command ()+renderMany results = do+  echo . unlines $+   [ "Benchmark Results"+   , "====================================================="+   , ""+   , machine_details+   , ""+   , "How to read these tables"+   , "====================================================="+   , ""+   , "NB: times are reported as mean + 1 std deviation"+   , ""+   , def "?x" "less than  5 runs used"+   , def "~x" "less than 20 runs used"+   , def "sdev" "std deviation"+   , descriptions_of_variants+   , ""+   , binary_details+   , ""+   , "Timing Graphs"+   , "===================================================="+   , ""+   , intercalate "\n" (map showG t_graphs)+   , "Timings"+   , "===================================================="+   , ""+   , intercalate "\n" (map showT t_tables)+   , "Memory Graphs"+   , "===================================================="+   , ""+   , intercalate "\n" (map showG m_graphs)+   , "Memory"+   , "===================================================="+   , ""+   , intercalate "\n" (map showT m_tables)+   ]+ where+  tables = repoTables benchmarks results+  --+  machine_details = intercalate "\n" $+    map detail [ "Machine description", "Year", "CPU", "Memory", "Hard disk", "Notes" ]+  detail k = k ++ "\n    *Replace Me*"+  --+  descriptions_of_variants = intercalate "\n" $+    map (describe . toVariant) [ OptimizePristineVariant ]+  describe v = def (vSuffix v) (vDescription v ++ " variant")+  def k v = "* " ++ k ++ " = " ++ v+  --+  repoTuple tabulate repo = (rtRepo repo, tabulate repo)+  t_tables = map (repoTuple $ tabulateRepo formatTimeResult) tables+  m_tables = map (repoTuple $ tabulateRepo formatMemoryResult) tables+  showT (r,t) = intercalate "\n" [ r+                                 , replicate (length r) '-'+                                 , ""+                                 , TR.render id id id t ]+  --+  t_graphs = map (repoTuple graphRepoTime) tables+  m_graphs = map (repoTuple graphRepoMemory) tables+  showG (r,gs) = intercalate "\n" $ [ r+                                    , replicate (length r) '-'+                                    , ""+                                    ] ++ (map imgDirective gs) ++ [""]+  imgDirective = (".. image:: " ++)+  binaries = map head . group . sort $ [ bin | (Test _ _ bin, _) <- results ]+  --+  binary_details = unlines $ map describe_bin binaries+  describe_bin bin = padl 12 (binCommand bin ++ ": ") +++                     binVersionString bin ++ ",\n" ++ (replicate 12 ' ') +++                     (formatDateTime "%Y-%m-%d %H:%M:%S" $ binDate bin) +++                     ", GHC " ++ binGHC bin+  padr n x = x ++ pad n x+  padl n x = pad n x ++ x+  pad n x = take (n - length x) (repeat ' ')++printCumulativeReport :: Command ()+printCumulativeReport = do+  ts <- liftIO readAllTimings+  mapM_ renderMany ts -- TODO: split this into sections for each param stamp++-- | For each repository, the benchmarks that we have enough data for+sufficientData :: [(Test a, Maybe MemTimeOutput)] -> [ (String, [String]) ]+sufficientData results =+  map (rtRepo &&& missingPoints) tables+ where+  tables = repoTables benchmarks results+  missingPoints t = [ d | (d,mts) <- zip (rtRows t) (rtTable t), all enough (snd mts) ]+  --+  enough (Just mt) | mtSampleSize mt >= 20 = True -- TODO: avoid duplication with formatTimeResult+  enough _ = False

@@ -0,0 +1,35 @@+module Run where++import Control.Monad.Error++import Benchmark+import Definitions+import Report+import Shellish hiding ( run )+import Standard+import qualified TabularRST as TR++benchMany :: [(TestRepo, [Benchmark a])] -> [TestBinary] -> Command [(Test a, Maybe MemTimeOutput)]+benchMany reposbenches bins = do+  fmap concat $ forM reposbenches $ \(r,benches) -> do+    res <- sequence+             [ do let test = Test bench repo bin+                  memtime <- run test+                  return (test, memtime)+               | bin <- bins+               , repo <- repoAndVariants bin r+               , bench <- filter (noSkip r) benches ]+    case repoTables benchmarks res of+     []  -> echo $ "No benchmarks to run for " ++ trCoreName r+     [t] -> echo_n $ TR.render id id id $ tabulateRepo formatTimeResult t+     _   -> error "Not expecting more than one table for a repo and its variants"+    return res+ where+  noSkip r b = not (description b `elem` trSkip r)+  repoAndVariants bin r = map (r `tweakVia`) (appropriateVariants bin (trVariants r))+  tweakVia tr v =+   case vId v of+     DefaultVariant -> tr+     _ -> tr { trPath = variantRepoName v (trPath tr)+             , trName = trName tr ++ " " ++ vShortName v+             }

@@ -0,0 +1,186 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Shellish( cd, pwd, run, (#), withCurrentDirectory, strictGetContents,+                 shellish, silently, verbosely, Command, sub, echo, echo_n,+                 which, canonize, resetMemoryUsed, recordMemoryUsed,+                 memoryUsed, rm_rf, rm_f, whenM, test_e, test_f, test_d,+                 resetTimeUsed, timeUsed, mv, ls, echo_err, echo_n_err,+                 mkdir_p, catch_sh, system )+    where++import Prelude hiding ( catch )+import Data.List+import System.IO+import System.Directory+import System.Exit+import Control.Exception+import Control.Monad.State+import Control.Monad.Error+import Data.Time.Clock( getCurrentTime, diffUTCTime, UTCTime(..) )+import Control.Exception ( bracket, evaluate )+import qualified Data.ByteString.Char8 as B+import System.Process( runInteractiveProcess, waitForProcess )+import qualified System.IO.UTF8 as UTF8+import qualified System.Cmd as Cmd+++-- TODO maxMem is sort of a layering violation here... but who cares.+data St = St { sCode :: Int, sStderr :: B.ByteString , sStdout :: B.ByteString,+               sVerbose :: Bool, maxMem :: Int, startTime :: UTCTime }++type Command a = StateT St IO a++-- Oh my eyes! Oh noes! Horrible!+catch_sh :: (Exception e) => Command a -> (e -> Command a) -> Command a+catch_sh action handler = do+  state <- get+  (val, newstate) <- liftIO $ catch (runStateT action state)+                                    (\e -> do runStateT (handler e) state)+  put newstate+  return val++cd :: String -> Command ()+cd = liftIO . setCurrentDirectory++mv :: String -> String -> Command ()+mv a b = liftIO $ renameFile a b++ls :: String -> Command [String]+ls dir = liftIO $ (\\ [".", ".."]) `fmap` getDirectoryContents dir++pwd :: Command String+pwd = liftIO $ getCurrentDirectory++echo, echo_n, echo_err, echo_n_err :: String -> Command ()+echo = liftIO . UTF8.putStrLn+echo_n = liftIO . (>> hFlush System.IO.stdout) . UTF8.putStr+echo_err = liftIO . UTF8.hPutStrLn stderr+echo_n_err = liftIO . (>> hFlush stderr) . UTF8.hPutStr stderr++mkdir_p :: String -> Command ()+mkdir_p = liftIO . createDirectoryIfMissing True++which :: String -> Command (Maybe String)+which = liftIO . findExecutable++canonize :: String -> Command String+canonize = liftIO . canonicalizePath++whenM :: Monad m => m Bool -> m () -> m ()+whenM c a = do res <- c+               when res a++test_e :: String -> Command Bool+test_e f = liftIO $ do+             dir <- doesDirectoryExist f+             file <- doesFileExist f+             return $ file || dir++test_f :: String -> Command Bool+test_f = liftIO . doesFileExist++test_d :: String -> Command Bool+test_d = liftIO . doesDirectoryExist++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++system :: String -> Command ExitCode+system = liftIO . Cmd.system++run :: String -> [String] -> Command String+run cmd args = do+    (_,outH,errH,procH) <- liftIO $ runInteractiveProcess cmd args Nothing Nothing+    st <- get+    res <- liftIO $ B.hGetContents outH+    errs <- liftIO $ B.hGetContents errH+    ex <- liftIO $ waitForProcess procH+    when (sVerbose st) $ do+                 liftIO $ B.putStr res+                 liftIO $ B.putStr errs+    case ex of+      ExitSuccess -> return ()+      ExitFailure n -> fail $ "command " ++ cmd ++ " " ++ show args+                         ++ " failed with exit code " ++ show n+    put $ st { sCode = 0, sStderr = errs, sStdout = res }+    return $ B.unpack res++(#) :: String -> [String] -> Command String+cmd # args = run cmd args++silently :: Command a -> Command a+silently a = do+  x <- get+  put $ x { sVerbose = False }+  r <- a+  put x+  return r++verbosely :: Command a -> Command a+verbosely a = do+  x <- get+  put $ x { sVerbose = True }+  r <- a+  put x+  return r++sub :: Command a -> Command a+sub a = do+  -- TODO save environment as well?+  dir <- liftIO $ getCurrentDirectory+  r <- a `catch_sh` (\(e :: SomeException) -> (liftIO $ setCurrentDirectory dir) >> throw e)+  liftIO $ setCurrentDirectory dir+  return r++shellish :: MonadIO m => Command a -> m a+shellish a = do+  dir <- liftIO $ getCurrentDirectory+  time <- liftIO getCurrentTime+  r <- liftIO $ evalStateT a $ empty time+  liftIO $ setCurrentDirectory dir+  return r+      where empty t = St { sCode = 0, sStderr = B.empty,+                           sStdout = B.empty, sVerbose = True,+                           maxMem = 0, startTime = t }++strictGetContents :: Handle -> IO String+strictGetContents h =+    do res <- hGetContents h+       evaluate (length res)+       return res++withCurrentDirectory :: FilePath -> IO a -> IO a+withCurrentDirectory name m =+    bracket+        (do cwd <- getCurrentDirectory+            when (name /= "") (setCurrentDirectory name)+            return cwd)+        (\oldwd -> setCurrentDirectory oldwd `catch` (\(_ :: SomeException) -> return ()))+        (const m)++recordMemoryUsed :: Int -> Command ()+recordMemoryUsed u = do+  x <- get+  put x { maxMem = maximum [maxMem x, u] }++resetMemoryUsed :: Command ()+resetMemoryUsed = do+  x <- get+  put x { maxMem = 0 }++resetTimeUsed :: Command ()+resetTimeUsed = do+  x <- get+  t <- liftIO getCurrentTime+  put x { startTime = t }++memoryUsed :: Command Int+memoryUsed = do x <- get+                return $ maxMem x++timeUsed :: Command Float+timeUsed = do x <- get+              t <- liftIO getCurrentTime+              return $ realToFrac $ diffUTCTime t (startTime x)

@@ -0,0 +1,117 @@+module Standard( benchmarks ) where+import Prelude hiding ( catch )+import Control.Exception+import System.FilePath+import Shellish+import Benchmark hiding ( darcs )+import Definitions+import Control.Monad( forM_, filterM, when )+import Control.Monad.Trans( liftIO )+import qualified Control.Monad.State as MS++check :: BenchmarkCmd ()+check darcs _ = do+  cd "repo"+  darcs [ "check", "--no-test" ]+  return ()++repair :: BenchmarkCmd ()+repair darcs _ = do+  cd "repo"+  darcs [ "repair" ]+  return ()++annotate :: BenchmarkCmd ()+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 = maybe id (:) (trAnnotate tr) [ "Setup.hs", "Setup.lhs" ]++get :: [String] -> BenchmarkCmd ()+get param darcs _ = do+  darcs $ "get" : param ++ ["repo", "get"]+  return ()++pull :: Int -> BenchmarkCmd ()+pull n darcs _ = do+  cd "repo"+  rm_f "_darcs/patches/unrevert"+  darcs [ "obliterate", "--last", show n, "--all" ]+  reset -- the benchmark starts here+  darcs [ "pull", "--all" ]+  return ()++darcs_wh :: [String] -> BenchmarkCmd ()+darcs_wh param darcs _ = (darcs ("whatsnew" : param) >> return ()) `catch_sh` handle+  where handle (RunFailed _ 1 _) = return ()+        handle e = throw e++wh :: BenchmarkCmd ()+wh darcs tr = do+  cd "repo"+  darcs_wh [] darcs tr+  return ()++wh_mod :: BenchmarkCmd ()+wh_mod 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__"+  darcs_wh [] darcs tr+  forM_ files $ \f -> mv (f <.> "__foo__") f+  return ()++wh_l :: BenchmarkCmd ()+wh_l darcs tr = do+  cd "repo"+  darcs_wh [ "--look-for-adds" ] darcs tr+  return ()++-- | n patches for each file+record :: BenchmarkCmd ()+record darcs _ = do+ cd "repo"+ files <- filterM test_f =<< ls "."+ forM_ files $ \f -> liftIO (appendFile f "x")+ darcs [ "record", "--author", "bench <bench@example.com>", "--all", "-m", "test record", "--no-test"]+ darcs [ "obliterate", "--last", "1", "--all" ]+ return ()++revert :: BenchmarkCmd ()+revert darcs _ = do+ cd "repo"+ files <- filterM test_f =<< ls "."+ forM_ files $ \f -> liftIO (appendFile f "foo")+ darcs [ "revert", "--all" ]+ return ()++revert_unrevert :: BenchmarkCmd ()+revert_unrevert darcs _ = do+ cd "repo"+ files <- filterM test_f =<< ls "."+ forM_ files $ \f -> liftIO (appendFile f (show "foo"))+ darcs [ "revert", "--all" ]+ darcs [ "unrevert", "--all" ]+ darcs [ "revert", "--all" ]+ return ()++benchmarks :: [ Benchmark () ]+benchmarks =+       [ Idempotent "wh" FastB wh+       , Idempotent "wh mod" FastB wh_mod+       , Idempotent "wh -l" FastB wh_l+       , Idempotent "record" FastB $ record+       , Idempotent "revert" FastB revert+       , Idempotent "(un)revert" FastB revert_unrevert+       , Destructive "get (full)" SlowB $ get []+       , Destructive "get (lazy)" FastB $ get ["--lazy"]+       , Idempotent "pull 100"    FastB $ pull 100+       , Idempotent "pull 1000" SlowB $ pull 1000+       , Idempotent "check" SlowB check+       , Idempotent "repair" SlowB repair+       , Idempotent "annotate" SlowB annotate+       ]

@@ -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, "" ] -- note the extra blank line+ 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) ' '

@@ -0,0 +1,146 @@+#!/usr/bin/env runhaskell+import Shellish( shellish, rm_rf )+import Control.Arrow ( first, second )+import System.Console.CmdArgs+import System.Cmd ( system )+import System.Exit+import System.Directory+import System.IO+import Control.Monad+import Control.Monad.Trans+import Benchmark+import Config (Config(Get,Run,Dist,Report))+import Definitions+import qualified Config as C+import Report+import Run+import Standard+import Dist ( createTarball )+import Download+import Data.List+import Data.Version ( showVersion )+import Paths_darcs_benchmark+import Text.JSON+import Data.IORef++help :: String+help = unlines [ "darcs-benchmark " ++ showVersion version ++ ": run standard darcs benchmarks"+               , ""+               , "Please either specify the repositories and binaries to run on like this:"+               , "$ darcs-benchmark run <binary> [binary] [/ [repository] [repository]]"+               , ""+               , "or alternatively, to run on all available repos:"+               , "$ 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:"+               , ""+               , "binary binary binary"+               , "repo repo repo"+               , ""+               , "(again, if the second line is not there, we run on all available repos)"+               , ""+               , "Thank you for benchmarking darcs!" ]++known_repos :: [String]+known_repos = [ "tabular", "tahoe-lafs", "darcs", "ghc-hashed" ]++download_repos :: [String] -> IO ()+download_repos r = forM_ (if null r then known_repos else r) download++doVMFlush :: FilePath -> IO ()+doVMFlush path = do system "sudo sh -c 'echo 3 > /proc/sys/vm/drop_caches'"+                    system $ path ++ " --version > /dev/null"+                    return ()++config :: [TestRepo] -> C.Config -> IO ([(TestRepo,[Benchmark ()])], [String])+config allrepos cfg = do+  case cfg of+   Get {} -> do+      download_repos (C.repos cfg)+      exitWith ExitSuccess+   Dist {} -> do+      createTarball (C.repo cfg)+      exitWith ExitSuccess+   Report {} ->  do+      shellish printCumulativeReport+      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 = if null bins then confbins else bins+         usetests' = if C.fast cfg then filter (\b -> speed b == FastB) benchmarks else benchmarks+         usetests = case C.only cfg of+                     [] -> usetests'+                     os -> filter (\b -> any (\o -> o `isInfixOf` show b) os) usetests'+     let setParams p = p { pFlush = if C.cold cfg then Just doVMFlush else Nothing }+     modifyIORef global (first setParams)+     filterTests <- if C.converge cfg+                       then do pstampPath <- (paramStampPath . fst) `fmap` readIORef global+                               ts <- readTimingsForParams pstampPath+                               return $ \r bs -> case lookup (trCoreName r) (sufficientData ts) of+                                                   Nothing -> bs+                                                   Just xs -> filter (\b -> not (description b `elem` xs)) bs+                       else return (const id)+     when (null usebins) $ do+       hPutStrLn stderr "Please specify at least one darcs binary to benchmark"+       exitWith (ExitFailure 1)+     let finalrepos = if null userepos then allrepos+                         else filter (\r -> any (matchRepo r) userepos) allrepos+         finalbins  = usebins+     return ( map (\r -> (r, filterTests r usetests)) finalrepos+            , finalbins+            )+ 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 n n d Nothing [toVariant DefaultVariant] []+ where+  n = drop (length "repo.") d++main :: IO ()+main = do+    cfg <- cmdArgs help C.defaultConfig+    allrepos <- do listing <- getDirectoryContents "."+                   configs <- mapM readC $+                                  filter ((/='~') . last) $+                                  filter ("config." `isPrefixOf`) listing+                   let other = [ testRepoFromDir d | d <- listing+                                                   , "repo." `isPrefixOf` d+                                                   , d `notElem` map trPath configs ]+                   return (configs ++ other)+    (reposNtests, binaries') <- config allrepos cfg+    let repos = map fst reposNtests+    unless (null $ repos \\ allrepos) $ do+         let name r = intercalate ", " $ map trName r+         putStrLn $ "Missing repositories: " ++ name (repos \\ allrepos)+         exitWith $ ExitFailure 2+    binaries <- forM binaries' check_vcs+    mapM_ appendBinary binaries+    when (null repos) $ do+         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"+                  -- for setting up variants, we probably want the latest/greatest+                  -- version of darcs in case the variant involves some new feature+                  case reverse binaries of+                    []    -> return ()+                    (b:_) -> setupVariants repos b+                  res <- benchMany reposNtests binaries+                  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