{-# OPTIONS_GHC -fglasgow-exts #-} 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) import Data.Maybe (listToMaybe) import Data.Time.Clock (getCurrentTime,diffUTCTime) import Distribution.Version (showVersion) import System.FilePath ((),isRelative) import System.Directory (createDirectory, setCurrentDirectory, removeDirectoryRecursive, doesFileExist, doesDirectoryExist, getTemporaryDirectory, getCurrentDirectory ) import System.Exit(exitWith,ExitCode(ExitSuccess)) import System.IO (hPutStrLn,stderr) import System.Environment (getArgs) import System.Console.GetOpt import qualified Paths_maybench 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 exe <- asks darcsExecutable let diff = diffUTCTime stop start (avgmem, maxmem) = grabMemStats err results = [ BR "exe" exe , BR "time" (show diff) , BR "avgmem" avgmem , BR "maxmem" maxmem ] liftIO $ do putStr "bench stats " print results return out -- | given a string like -- -- <> -- -- 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 tail . 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 [String] | VersionFlag | RepoFlag String | InteractiveFlag | HelpFlag deriving (Eq) -- | comma-separated list of paths to darcs, e.g. darcs-1.0.9, darcs-2.0.0, etc darcsList :: String -> Flag darcsList = DarcsFlag . sepBy ',' options :: [OptDescr Flag] options = [Option ['h','?'] ["help"] (NoArg HelpFlag) "show this help message", Option ['v'] ["version"] (NoArg VersionFlag) "show maybench version", 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 darcsList "CMD1,CMD2,...") "set the darcs commands 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." version :: IO () version = do putStrLn $ me ++ " " ++ showVersion Paths_maybench.version exitWith ExitSuccess 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) b1 <- doesFileExist bench_dir b2 <- doesDirectoryExist bench_dir when (b1 || b2) $ 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 [] when (VersionFlag `elem` opts) $ version cwd <- getCurrentDirectory let mkAbsolute p = if isRelative p then cwd p else p -- let mUrl = listToMaybe [ f | RepoFlag f <- opts ] dCmds = replaceNil "darcs" $ map mkAbsolute $ concat [ f | DarcsFlag f <- opts ] conf dcmd = BenchConf { benchUrlRepo = undefined , benchCounts = undefined , interactive = InteractiveFlag `elem` opts , darcsExecutable = dcmd } forM_ dCmds $ \dcmd -> do case d_args of [] -> ourBench mUrl (conf dcmd) (c:das) -> runBenchM (conf dcmd) (BenchState "") $ do bench "arbitrary_command" $ run $ darcs c [] <@> Arbitrary das return () replaceNil :: a -> [a] -> [a] replaceNil a [] = [a] replaceNil _ as = as sepBy :: Char -> String -> [String] sepBy x s = case dropWhile (== x) s of "" -> [] s' -> w : sepBy x s'' where (w, s'') = break (== x) s'