diff --git a/common/TestHarness.hs b/common/TestHarness.hs index 4a659cc..6684215 100644 --- a/common/TestHarness.hs +++ b/common/TestHarness.hs @@ -24,17 +24,19 @@ There is an initial prologue, assumed to be source code. Any lines beginning wi to be destinations for substitution. The prologue is terminated by the first test. Each test has a starting line that begins with a single % followed by either PASS or FAIL, +optionally followed by an * (indicating this test is a good benchmark for timing) followed by a test name. The lines that run to the start of the next test are the source substitution. The file is terminated by a single percent on its own line. -} -module TestHarness (automaticTest) where +module TestHarness (automaticTest, automaticTimeTest) where import Control.Monad.Error import Control.Monad.State import Data.List +import Data.Maybe import System.IO import Test.HUnit hiding (performTest) import Text.Regex @@ -44,11 +46,15 @@ import ParseOccam import Pass import PassList import PreprocessOccam +import TestUtils import Utils automaticTest :: FilePath -> IO Test 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: defaultState :: CompState defaultState = emptyState {csUsageChecking = True} @@ -62,6 +68,12 @@ testOccam source = do result <- evalStateT (runErrorT compilation) defaultState Right _ -> Nothing where compilation = preprocessOccamSource source >>= parseOccamProgram >>= runPasses (getPassList defaultState) + +-- | Substitutes each substitution into the prologue +substitute :: String -> [(Bool, Bool, String, String)] -> [(Bool, Bool, String, String)] +substitute prologue = map (\(a,b,c,subst) -> (a,b,c,subRegex (mkRegex "%%") prologue subst)) + + -- | Given a file's contents, tests it performTest :: String -> String -> Test performTest fileName fileContents @@ -70,33 +82,42 @@ performTest fileName fileContents Right (prologue,tests) -> TestLabel fileName $ TestList $ map performTest' (substitute prologue tests) where - -- Substitutes each substitution into the prologue - substitute :: String -> [(Bool, String, String)] -> [(Bool, String, String)] - substitute prologue = map (\(a,b,subst) -> (a,b,subRegex (mkRegex "%%") prologue subst)) - - performTest' :: (Bool, String, String) -> Test - performTest' (expPass, testName, testText) + performTest' :: (Bool, Bool, String, String) -> Test + performTest' (expPass, _, testName, testText) = TestCase $ do result <- testOccam testText case result of 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") +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 -parseTestFile :: String -> Either String (String, [(Bool, String, String)]) +parseTestFile :: String -> Either String (String, [(Bool, Bool, String, String)]) parseTestFile wholeText = seqPair (return $ unlines prologue, splitCases testcases) where allLines = lines wholeText (prologue, testcases) = span (\l -> ("%%" `isPrefixOf` l) || (not $ "%" `isPrefixOf` l)) allLines - splitCases :: [String] -> Either String [(Bool, String, String)] + splitCases :: [String] -> Either String [(Bool, Bool, String, String)] splitCases [] = throwError "Unexpected EOF" splitCases (headLine:otherLines) - | "%PASS" `isPrefixOf` headLine = joinM (True, drop 5 headLine , unlines testCaseLines) (splitCases furtherLines) - | "%FAIL" `isPrefixOf` headLine = joinM (False, drop 5 headLine , unlines testCaseLines) (splitCases furtherLines) + | "%PASS" `isPrefixOf` headLine = joinM (True, hasStar, testTitle, unlines testCaseLines) (splitCases furtherLines) + | "%FAIL" `isPrefixOf` headLine = joinM (False, hasStar, testTitle, unlines testCaseLines) (splitCases furtherLines) | "%" == headLine = return [] | otherwise = throwError $ "Unexpected format in testcase-header line: \"" ++ headLine ++ "\"" where + (hasStar, testTitle) = if headLine !! 5 == '*' then (True, drop 6 headLine) else (False, drop 5 headLine) + (testCaseLines, furtherLines) = span (not . isPrefixOf "%") otherLines joinM :: Monad m => a -> m [a] -> m [a]