Added a helper function for timing tasks in the TestUtils module
This commit is contained in:
parent
4c176a1a0f
commit
d1fa9fd71f
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue
Block a user