maybench-0.2: darcs-benchmark/DarcsBenchmark.hs
{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
import Prelude hiding (foldr, foldl, foldr1, foldl1)
import Control.Arrow (second)
import Control.Monad ()
import Control.Monad.Reader
import Control.Monad.State
import Control.Applicative
import Data.List (isInfixOf,find)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Time.Clock (getCurrentTime,diffUTCTime)
import System.FilePath ((</>))
import System.Directory (createDirectory, setCurrentDirectory, removeDirectoryRecursive,
getTemporaryDirectory, getCurrentDirectory )
import System.IO (hPutStrLn,stderr)
import System.Environment (getArgs)
import System.Posix (fileExist)
import System.Console.GetOpt
import Test.Maybench (run)
import Test.Maybench.Command (Command(..), CommandModifier(..), CommandModifierClass, modifyCmd, (<@>),
updateCmdInput, addArgs)
import Test.Maybench.Utils (fromList)
data Counts = Counts
{ allPatches :: Int
, manyPatches :: Int
, somePatches :: Int
}
data BenchConf = BenchConf
{ benchUrlRepo :: String
, benchCounts :: Counts
, interactive :: Bool
, darcsExecutable :: String
}
data BenchState = BenchState
{ benchDirRepo :: String
}
newtype BenchM a = BenchM { benchM :: ReaderT BenchConf (StateT BenchState IO) a }
deriving (Functor, Monad, MonadIO, MonadReader BenchConf, MonadState BenchState)
type DarcsCmd = CommandModifier BenchM
runD :: DarcsCmd -> BenchM (String, String)
runD cmd = do
dir <- gets benchDirRepo
run $ cmd <@> RepoDir dir
-- doing a lot of replaces finally slow down
data DarcsCommand = DarcsCommand { _darcsCmd :: String, _darcsSubCmds :: [String] }
instance CommandModifierClass BenchM DarcsCommand where
modifyCmd (DarcsCommand cmd subCmds) = do
exe <- asks darcsExecutable
let reset (Cmd "" [] "") = Cmd exe (cmd:subCmds) ""
reset _ = error "DarcsCommand: unexpected non empty command"
return reset
data DarcsOpts = All
| Confirmed -- ^ for that final 'are you sure' prompt
| Last Int
| RepoDir String
| IgnoreTimes
| NoTest
| Quiet
| Author String
| Message String
| RTS String
| Arbitrary [String]
instance CommandModifierClass BenchM DarcsOpts where
modifyCmd Confirmed = return $ updateCmdInput (++ "y")
modifyCmd All = do
b <- asks interactive
return $
if b then
updateCmdInput ('a':)
else
addArgs ["--all"]
modifyCmd (Last n) = do
b <- asks interactive
return $
if b then
updateCmdInput ((replicate n 'y' ++) . ('d' :))
else
addArgs ["--last", show n]
modifyCmd (RepoDir d) = return $ addArgs ["--repodir", d]
modifyCmd IgnoreTimes = return $ addArgs ["--ignore-times"]
modifyCmd NoTest = return $ addArgs ["--no-test"]
modifyCmd Quiet = return $ addArgs ["--quiet"]
modifyCmd (Author a) = return $ addArgs ["--author", a]
modifyCmd (Message m) = return $ addArgs ["-m", m]
-- not darcs flags
modifyCmd (RTS x) = return $ addArgs ["+RTS", x, "-RTS"]
modifyCmd (Arbitrary x) = return $ addArgs x
darcs :: String -> [String] -> DarcsCmd
darcs cmd subCmds = Nop <@> DarcsCommand cmd subCmds <@> Quiet <@> RTS "-tstderr"
darcs_unrecord, darcs_obliterate, darcs_record, darcs_add, darcs_get,
darcs_pull, darcs_show_repo, darcs_init :: DarcsCmd
darcs_init = darcs "init" []
darcs_unrecord = darcs "unrecord" []
darcs_obliterate = darcs "obliterate" [] <@> IgnoreTimes
darcs_record = darcs "record" [] <@> IgnoreTimes <@> NoTest
darcs_show_repo = darcs "show" ["repo"]
darcs_add = darcs "add" []
darcs_get = darcs "get" []
darcs_pull = darcs "pull" []
data BenchResult = BR String String
instance Show BenchResult where
show (BR k v) = k ++ ":" ++ v
bench :: String -> BenchM (String, String) -> BenchM String
bench title f = do
start <- liftIO $ do
putStrLn title
getCurrentTime
(out, err) <- f
stop <- liftIO getCurrentTime
let diff = diffUTCTime stop start
(avgmem, maxmem) = grabMemStats err
results = [ BR "time" (show diff)
, BR "avgmem" avgmem
, BR "maxmem" maxmem ]
liftIO $ do putStr "bench stats "
print results
return out
-- | given a string like
--
-- <<ghc: 4317044 bytes, 9 GCs, 86016/86016 avg/max bytes residency (1
-- samples), 1M in use, 0.00 INIT (0.00 elapsed), 0.02 MUT (0.09 elapsed), 0.00
-- GC (0.00 elapsed) :ghc>>
--
-- return only the memory usage, so here 86016, 86016
grabMemStats :: String -> (String, String)
grabMemStats s =
case (dropWhile (/= "GCs,") . words $ s) of
(_:x:_) -> breakOn '/' x
_ -> ("ERR","ERR")
-- | Split a string in two at and dropping @delim@
breakOn :: Char -- ^ delim
-> String -> (String, String)
breakOn c = second (drop 1) . break (== c)
-- get
-- URL
-- last tag
-- medium tag
-- partial
-- format hashed/old-f
data RepoSize = RepoSize { duration :: Int,
nfiles :: Int,
filesize :: Int }
defaultRepoSize :: RepoSize
defaultRepoSize = RepoSize { duration = 100,
nfiles = 100,
filesize = 25 }
make_repo :: RepoSize -> String -> BenchM ()
make_repo sh name =
do cwd <- liftIO $ getCurrentDirectory
liftIO $ createDirectory name
liftIO $ setCurrentDirectory name
bench "darcs init" $ run $ darcs_init
mapM_ (\n -> createFile ("file-"++show n) (filesize sh) n) [0..nfiles sh]
bench "initial record" $ run $ darcs_record <@> All <@> Author "me" <@> Message "initial record"
let modifyFiles seed = do mapM_ (\n -> modifyFile ("file-"++show n) (seed+n)) [0..nfiles sh]
run $ darcs_record <@> All <@> Author "me" <@> Message ("change "++show seed)
mapM_ modifyFiles [0..duration sh]
liftIO $ setCurrentDirectory cwd
return ()
createFile :: String -> Int -> Int -> BenchM ()
createFile f size seed = do liftIO $ writeFile f $ unlines x
bench ("add "++f) $ run $ darcs_add <@> f
return ()
where x = map toline [0 .. size]
toline n | n `mod` (seed+1) == 0 = ""
| otherwise = "line "++ show n
modifyFile :: String -> Int -> BenchM ()
modifyFile _ seed | seed `mod` 10 /= 1 = return () -- only modify one in ten files
modifyFile f seed = do x <- liftIO $ readFile f
liftIO $ (seq (length x) writeFile) f $ unlines $ modi seed $ lines x
where modi 0 (_:ls) = modi seed ls
modi 3 (l:ls) = l:('x':l): modi 2 ls
modi 7 (l:ls) = ('y':l): modi 6 ls
modi n (l:ls) = l : modi (n-1) ls
modi _ [] = []
bench_unrecord_record :: BenchM ()
bench_unrecord_record =
do bench "unrecord last 1" $ runD $ darcs_unrecord <@> Last 1 <@> All <@> Confirmed
bench "record" $ runD $ darcs_record <@> All <@> Message "test patch" <@> Author "me"
return ()
bench_obliterate_pull_last :: Int -> BenchM ()
bench_obliterate_pull_last n =
do bench ("obliterate last "++show n) $
runD $ darcs_obliterate <@> Last n <@> All <@> Confirmed
bench ("pull "++show n) $ runD $ darcs_pull <@> All
return ()
replicateBench :: (Int -> BenchM ()) -> BenchM ()
replicateBench m = do
counts <- asks benchCounts
m 1
m $ somePatches counts
m $ manyPatches counts
benchAll :: BenchM ()
benchAll = do
bench_unrecord_record
replicateBench bench_obliterate_pull_last
-- TODO
-- whatsnew
-- record
-- unrecord
-- amend-record
-- mark-conflicts
-- rollback
-- TODO: but these commands are not that problematic about performance
-- tag
-- unrevert
-- add
-- remove
-- mv
-- replace
-- setpref
runBenchM :: BenchConf -> BenchState -> BenchM a -> IO a
runBenchM conf state f = evalStateT (runReaderT (benchM f) conf) state
countPatches :: String -> BenchM Int
countPatches repo =
(read . last . words . fromList (error "bad 'darcs show repo' output") .
filter ("Num Patches:" `isInfixOf`) . lines . fst)
<$> (run $ darcs_show_repo <@> RepoDir repo)
data Flag = DarcsFlag { darcsFlag :: String }
| RepoFlag String
| InteractiveFlag | HelpFlag
deriving (Eq)
options :: [OptDescr Flag]
options =
[Option ['h','?'] ["help"] (NoArg HelpFlag) "show this help message",
Option ['i'] ["interactive"] (NoArg InteractiveFlag) "use the interactive mode of darcs",
Option ['r'] ["repo"] (ReqArg RepoFlag "URL") "run on a specific repository",
Option [] ["darcs"] (ReqArg DarcsFlag "COMMAND") "set the darcs command to use"]
usage :: [String] -> IO a
usage errs = do hPutStrLn stderr $ usageInfo header options
hPutStrLn stderr dargs
ioError $ userError $ concat errs
where header = "Usage: " ++ me ++ " [OPTION...] [cmd [darcsarg...]]"
dargs = "If you pass in a darcs command, maybench will ignore any flags and\n" ++
"just run darcs with the arguments specified.\n" ++
"If you pass in no arguments, maybench will run its own set of standard\n" ++
"darcs benchmarks."
me :: String
me = "darcs-benchmark"
ourBench :: Maybe String -> BenchConf -> IO ()
ourBench mUrl initBenchConf = do
tmp <- getTemporaryDirectory
let bench_dir = tmp </> me
let main_repo = "main"
let displayInfo url = liftIO $ do
putStrLn ("bench directory: " ++ bench_dir)
putStrLn ("origin repository: " ++ url)
putStrLn ("main repository: " ++ main_repo)
b <- fileExist bench_dir
when b $ removeDirectoryRecursive bench_dir
createDirectory bench_dir
setCurrentDirectory bench_dir
(url, count) <- runBenchM initBenchConf undefined $ do
url <- case mUrl of
Nothing -> do displayInfo "fresh"
make_repo defaultRepoSize "fresh"
return (bench_dir </> "fresh")
Just r -> do displayInfo r
return r
bench "darcs get" $ run $ darcs_get <@> url <@> main_repo
count <- countPatches main_repo
return (url, count)
let counts = Counts { allPatches = count
, manyPatches = min (count `div` 3) 500
, somePatches = min (count `div` 10) 50 }
let benchConf = initBenchConf { benchUrlRepo = url
, benchCounts = counts
}
runBenchM benchConf (BenchState main_repo) benchAll
main :: IO ()
main = do
args <- getArgs
(opts, d_args) <-
case getOpt Permute options args of
(o,n,[]) -> return (o,n)
(_,_,errs) -> usage errs
when (HelpFlag `elem` opts) $ usage []
--
let is_darcs_flag (DarcsFlag _) = True
is_darcs_flag _ = False
cwd <- getCurrentDirectory
let mkAbsolute ('.':'/':xs) = cwd ++ "/" ++ xs
mkAbsolute p = p
let initBenchConf = BenchConf { benchUrlRepo = undefined
, benchCounts = undefined
, interactive = InteractiveFlag `elem` opts
, darcsExecutable = fromMaybe "darcs" $
(mkAbsolute . darcsFlag) <$> find is_darcs_flag opts
}
mUrl = listToMaybe [ f | RepoFlag f <- opts ]
--
case d_args of
[] -> ourBench mUrl initBenchConf
(c:das) -> runBenchM initBenchConf (BenchState "") $ do
bench "arbitrary_command" $ run $ darcs c [] <@> Arbitrary das
return ()