Added a helper function for timing tasks in the TestUtils module

This commit is contained in:
Neil Brown 2008-01-23 15:23:00 +00:00
parent 4c176a1a0f
commit d1fa9fd71f

View File

@ -42,6 +42,7 @@ import Control.Monad.Error
import Control.Monad.State
import Data.Generics
import qualified Data.Map as Map
import System.Time
import Test.HUnit hiding (State,Testable)
import Test.QuickCheck
@ -86,6 +87,49 @@ mkPassResult = Result (Just True) [] []
mkFailResult :: String -> Result
mkFailResult s = Result (Just False) [s] []
data TimedTaskLevel = TT_Low | TT_Medium | TT_High
-- | The numbers are mean, variance
type TimedTask = TimedTaskLevel -> IO (String, Integer, Maybe Integer)
timeTask :: String -> (Int,Int,Int) -> IO () -> TimedTask
timeTask label (low,med,high) test level
= case level of
TT_Low -> runLow low test
TT_Medium -> run med test
TT_High -> run high test
where
average :: [Integer] -> Integer
average xs = sum xs `div` (toInteger $ length xs)
-- Despite what you might expect, there is no equivalent to this function provided
-- by the standard libraries
timeDiffToMicros :: TimeDiff -> Integer
timeDiffToMicros (TimeDiff _ _ day hour min sec pico)
= toInteger (((((((day * 24) + hour) * 60) + min) * 60) + sec) * 1000000) + (pico `div` 1000000)
-- Times a task in microseconds
time :: IO () -> IO Integer
time task = do startTime <- getClockTime
task
endTime <- getClockTime
let duration = diffClockTimes endTime startTime
return $ timeDiffToMicros duration
-- Run all tests together then estimate mean and set variance to Nothing:
runLow :: Int -> IO () -> IO (String, Integer, Maybe Integer)
runLow n task = do time <- time $ replicateM_ n task
return (label, time `div` toInteger n, Nothing)
-- Run each test separately and calculate mean and variance
run :: Int -> IO () -> IO (String, Integer, Maybe Integer)
run n task = do times <- replicateM n (time task)
let mean = average times
return (label, mean, Just $ average (map (\x -> (x - mean) * (x - mean)) times))
-- | An abbreviation for using 'emptyMeta'. TODO: This should really be removed (and all uses of it replaced with 'emptyMeta') for clarity.
m :: Meta
m = emptyMeta