Remove now-unused code for running timed tests.
This commit is contained in:
parent
ba10c85fc0
commit
808277ca84
|
@ -31,7 +31,7 @@ The file is terminated by a single percent on its own line.
|
||||||
|
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module TestHarness (automaticTest, automaticTimeTest) where
|
module TestHarness (automaticTest) where
|
||||||
|
|
||||||
import Control.Monad.Error
|
import Control.Monad.Error
|
||||||
import Data.List
|
import Data.List
|
||||||
|
@ -45,15 +45,11 @@ import ParseOccam
|
||||||
import Pass
|
import Pass
|
||||||
import PassList
|
import PassList
|
||||||
import PreprocessOccam
|
import PreprocessOccam
|
||||||
import TestUtils
|
|
||||||
import Utils
|
import Utils
|
||||||
|
|
||||||
automaticTest :: FilePath -> IO Test
|
automaticTest :: FilePath -> IO Test
|
||||||
automaticTest fileName = readFile fileName >>* performTest fileName
|
automaticTest fileName = readFile fileName >>* performTest fileName
|
||||||
|
|
||||||
automaticTimeTest :: (Int, Int, Int) -> FilePath -> IO [TimedTask]
|
|
||||||
automaticTimeTest scale fileName = readFile fileName >>* performTimeTest scale fileName
|
|
||||||
|
|
||||||
-- Bit of a hard-hack, until usage-checking is on by default:
|
-- Bit of a hard-hack, until usage-checking is on by default:
|
||||||
defaultState :: CompState
|
defaultState :: CompState
|
||||||
defaultState = emptyState {csUsageChecking = True}
|
defaultState = emptyState {csUsageChecking = True}
|
||||||
|
@ -89,17 +85,6 @@ performTest fileName fileContents
|
||||||
Just err -> if expPass then assertFailure (testName ++ " failed with error: " ++ err) else return ()
|
Just err -> if expPass then assertFailure (testName ++ " failed with error: " ++ err) else return ()
|
||||||
Nothing -> if expPass then return () else assertFailure (testName ++ " expected to fail but passed")
|
Nothing -> if expPass then return () else assertFailure (testName ++ " expected to fail but passed")
|
||||||
|
|
||||||
performTimeTest :: (Int, Int, Int) -> String -> String -> [TimedTask]
|
|
||||||
performTimeTest scale fileName fileContents
|
|
||||||
= case parseTestFile fileContents of
|
|
||||||
Left err -> error $ "Error processing file \"" ++ fileName ++ "\": " ++ err
|
|
||||||
Right (prologue,tests) -> mapMaybe performTimeTest' (substitute prologue tests)
|
|
||||||
|
|
||||||
where
|
|
||||||
performTimeTest' :: (Bool, Bool, String, String) -> Maybe TimedTask
|
|
||||||
performTimeTest' (_, False, _, _) = Nothing
|
|
||||||
performTimeTest' (_, True, testName, testText) = Just $ timeTask testName scale (testOccam testText >> return ())
|
|
||||||
|
|
||||||
-- | Splits a file's contents into the prologue, and subsequent testcases
|
-- | Splits a file's contents into the prologue, and subsequent testcases
|
||||||
parseTestFile :: String -> Either String (String, [(Bool, Bool, String, String)])
|
parseTestFile :: String -> Either String (String, [(Bool, Bool, String, String)])
|
||||||
parseTestFile wholeText = seqPair (return $ unlines prologue, splitCases testcases)
|
parseTestFile wholeText = seqPair (return $ unlines prologue, splitCases testcases)
|
||||||
|
|
|
@ -41,7 +41,6 @@ module TestUtils where
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import Data.Generics
|
import Data.Generics
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import System.Time
|
|
||||||
import Test.HUnit hiding (State,Testable)
|
import Test.HUnit hiding (State,Testable)
|
||||||
import Test.QuickCheck
|
import Test.QuickCheck
|
||||||
|
|
||||||
|
@ -74,47 +73,6 @@ scaleQC (low,med,high,ext) test level
|
||||||
run :: Testable a => Int -> a -> IO ()
|
run :: Testable a => Int -> a -> IO ()
|
||||||
run n = check (defaultConfig { configMaxTest = n })
|
run n = check (defaultConfig { configMaxTest = n })
|
||||||
|
|
||||||
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))
|
|
||||||
|
|
||||||
-- | Creates a 'A.Name' object with the given 'String' as 'A.nameName', and 'A.nameType' as 'A.VariableName'.
|
-- | Creates a 'A.Name' object with the given 'String' as 'A.nameName', and 'A.nameType' as 'A.VariableName'.
|
||||||
simpleName :: String -> A.Name
|
simpleName :: String -> A.Name
|
||||||
simpleName s = A.Name { A.nameName = s , A.nameMeta = emptyMeta , A.nameType = A.VariableName }
|
simpleName s = A.Name { A.nameName = s , A.nameMeta = emptyMeta , A.nameType = A.VariableName }
|
||||||
|
|
Loading…
Reference in New Issue
Block a user