maybench-0.2.3: Test/Maybench.hs

module Test.Maybench where

import System.Time
import System.Cmd (system) -- ideally this should use System.Process in the future, but for the sake of a first version this will do.
import Data.Maybe (isJust, fromJust)
import Control.Monad (when)
import Control.Monad.State (MonadIO, liftIO)
import System.IO (putStr,hPutStr,hClose,hGetContents)
import System.Process (waitForProcess, runInteractiveProcess)

import Test.Maybench.Command (CommandModifier, Command(Cmd), modifyCmd)
import Test.BenchPress ( benchmark, mean )

data Benchmark = Benchmark {benchIters :: Int, benchTimes :: [TimeDiff]}

run :: MonadIO m => CommandModifier m -> m (String, String)
run cmd = modifyCmd cmd >>= (\m -> runC $ m (Cmd "" [] ""))

runC :: MonadIO m => Command -> m (String, String)
runC (Cmd exe args input) = liftIO $ do
  putStr "Running... "
  let cmd_str = unwords $ map showSh (exe:args)
  putStrLn cmd_str
  (output, err) <- runProcessWithInput exe args input
  return (output, err)
  where showSh x | ' ' `elem` x = show x
                 | otherwise = x

runProcessWithInput :: FilePath -> [String] -> String -> IO (String, String)
runProcessWithInput cmd args input = do
    (pin, pout, perr, ph) <- runInteractiveProcess cmd args Nothing Nothing
    hPutStr pin input
    hClose pin
    output <- hGetContents pout
    when (output==output) $ return ()
    err <- hGetContents perr
    when (err==err) $ return ()
    hClose pout
    hClose perr
    waitForProcess ph -- should check exit code here...
    return (output, err)

averageTime :: String -> String -> String -> Int -> IO Double
averageTime cmd setup cleanup n = do
  stats <- benchmark n (system setup)
                       (const $ system cleanup)
                       (const $ system cmd)
  return $ mean $ snd stats


showTimeDiff :: (String, TimeDiff) -> String
showTimeDiff (cmd,td) = case filter isJust [helper tdYear "years",
                                            helper tdMonth "months",
                                            helper tdDay "days",
                                            helper tdHour "hours",
                                            helper tdMin "minutes",
                                            helper tdSec "seconds"]
                        of [] -> (show cmd) ++ " took less than a second."
                           xs -> (((show cmd) ++ " took ") ++) . intercalate ", " . map fromJust $ xs
    where helper accessor string = if accessor td > 0
                                   then (Just (show (accessor td) ++ " " ++ string))
                                   else Nothing
          intercalate _ [] = []
          intercalate x (y:ys) = y++x++intercalate x ys

printTimeDiff :: (String, TimeDiff) -> IO ()
printTimeDiff = putStrLn . showTimeDiff

minute, hour, day, month, year :: Int
minute = 60
hour = minute * 60
day = hour * 24
month = day * 30
year = day * 365

timeDiffToSeconds :: TimeDiff -> Int
timeDiffToSeconds td = tdSec td + (tdMin td) * minute + (tdHour td) * hour + (tdDay td) * day + (tdMonth td) * month + (tdYear td) * year

secondsToTimeDiff :: Int -> TimeDiff
secondsToTimeDiff sec = normalizeTimeDiff $ TimeDiff 0 0 0 0 0 sec 0

compareTimes :: Fractional a => (String, a) -> (String, a) -> Maybe String
compareTimes (cmd1,t1) (cmd2,t2) =
  Just $ show cmd2 ++ " took " ++ show (t1 `percentage` t2)
         ++ "% of the time "   ++ show cmd1 ++ " took."
    where percentage x y = (100 * x / y)