176 lines
7.0 KiB
Haskell
176 lines
7.0 KiB
Haskell
{-
|
|
Tock: a compiler for parallel languages
|
|
Copyright (C) 2007 University of Kent
|
|
|
|
This program is free software; you can redistribute it and/or modify it
|
|
under the terms of the GNU General Public License as published by the
|
|
Free Software Foundation, either version 2 of the License, or (at your
|
|
option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License along
|
|
with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
-}
|
|
|
|
{-|
|
|
|
|
This TestHarness module contains helper functions that deal with a file of the following format.
|
|
|
|
There is an initial prologue, assumed to be source code. Any lines beginning with "%%" are deemed
|
|
to be destinations for substitution. You can label different substitutions by
|
|
following the double-percent with other characters (but not PASS or FAIL), e.g. %%2.
|
|
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,
|
|
followed by a test name. The lines that run to the start of the next test, or
|
|
to the next line beginning with a percent are the source substitution. If you have
|
|
two or more substitution destinations (e.g. %% and %%2), you substitute them with
|
|
|
|
%PASS
|
|
First substitution
|
|
%2
|
|
Second substitution
|
|
|
|
i.e. using the label after your percent.
|
|
|
|
The file is terminated by a single percent on its own line.
|
|
|
|
-}
|
|
|
|
module TestHarness (automaticTest) where
|
|
|
|
import Control.Monad.Error
|
|
import Control.Monad.Writer
|
|
import Data.List
|
|
import Data.Maybe
|
|
import System.IO
|
|
import Test.HUnit hiding (performTest)
|
|
|
|
import CompState
|
|
import Metadata
|
|
import ParseOccam
|
|
import ParseRain
|
|
import Pass
|
|
import PassList
|
|
import PreprocessOccam
|
|
import Utils
|
|
|
|
data TestLine = Line String | Sub String {- without percents -}
|
|
data TestBody = TestBody Bool String [(String {- substName -}, [String] {- content -})]
|
|
|
|
data AutoTest = AutoTest
|
|
{ prologueLines :: [TestLine]
|
|
, bodies :: [TestBody]
|
|
}
|
|
|
|
automaticTest :: CompFrontend -> Int -> FilePath -> IO Test
|
|
automaticTest fr verb fileName = readFile fileName >>* performTest fr verb fileName
|
|
|
|
defaultState :: CompFrontend -> Int -> CompState
|
|
defaultState fr v = emptyState {csVerboseLevel = v, csFrontend = fr}
|
|
|
|
-- | Tests if compiling the given source gives any errors.
|
|
-- If there are errors, they are returned. Upon success, Nothing is returned
|
|
testOccam :: Int -> String -> IO (Maybe (Maybe Meta, String))
|
|
testOccam v source = do (result,_) <- runPassM (defaultState FrontendOccam v) compilation
|
|
return $ case result of
|
|
Left err -> Just err
|
|
Right _ -> Nothing
|
|
where
|
|
compilation = preprocessOccamSource source
|
|
>>= parseOccamProgram
|
|
>>= runPasses (getPassList $ defaultState FrontendOccam v)
|
|
|
|
testRain :: Int -> String -> IO (Maybe (Maybe Meta, String))
|
|
testRain v source = do (result,_) <- runPassM (defaultState FrontendRain v) compilation
|
|
return $ case result of
|
|
Left err -> Just err
|
|
Right _ -> Nothing
|
|
where
|
|
compilation = parseRainProgram "<test>" source
|
|
>>= runPasses (getPassList $ defaultState FrontendRain v)
|
|
|
|
-- | Substitutes each substitution into the prologue
|
|
substitute :: AutoTest -> Either String [(Bool, String, String)]
|
|
substitute t = sequence [ do ls <- execWriterT $ subst n (prologueLines t, ss)
|
|
return (p, n, unlines ls)
|
|
| TestBody p n ss <- bodies t]
|
|
where
|
|
subst :: String -> ([TestLine], [(String, [String])]) -> WriterT [String] (Either String) ()
|
|
subst _ ([], []) = return ()
|
|
subst n ([], subs) = throwError $ "Left over substitutions: " ++ show subs
|
|
++ " in " ++ n
|
|
subst n (Line l : ls, subs) = tell [l] >> subst n (ls, subs)
|
|
subst n (Sub s : ls, subs)
|
|
= case lookup s subs of
|
|
Just subLines -> tell subLines >> subst n (ls, filter ((/= s) . fst) subs)
|
|
Nothing -> throwError $ "Could not find substitution \"" ++ s
|
|
++ "\" in test: " ++ n
|
|
|
|
|
|
-- | Given a file's contents, tests it
|
|
performTest :: CompFrontend -> Int -> String -> String -> Test
|
|
performTest fr v fileName fileContents
|
|
= case parseTestFile fileContents of
|
|
Left err -> TestCase $ assertFailure $ "Error processing file \"" ++ fileName ++ "\": " ++ err
|
|
Right test -> TestLabel fileName $ TestList $
|
|
either
|
|
(singleton . TestCase . assertFailure . (fileName ++))
|
|
(map performTest')
|
|
(substitute test)
|
|
where
|
|
performTest' :: (Bool, String, String) -> Test
|
|
performTest' (expPass, testName, testText)
|
|
= TestCase $
|
|
do result <- (if fr == FrontendOccam then testOccam else testRain) v testText
|
|
case result of
|
|
Just err -> if expPass then assertFailure (testName ++ " failed with error: " ++ show err) else return ()
|
|
Nothing -> if expPass then return () else assertFailure (testName ++ " expected to fail but passed")
|
|
|
|
-- | Splits a file's contents into the prologue, and subsequent testcases
|
|
parseTestFile :: String -> Either String AutoTest
|
|
parseTestFile wholeText = liftM2 AutoTest parsePrologue (splitCases testcases)
|
|
where
|
|
allLines = lines wholeText
|
|
(prologue, testcases) = span (\l -> ("%%" `isPrefixOf` l) || (not $ "%" `isPrefixOf` l)) allLines
|
|
|
|
parsePrologue :: Either String [TestLine]
|
|
parsePrologue = if nub subs == subs then return parsed else
|
|
throwError "Multiple substitutions with the same name"
|
|
where
|
|
subs = [s | Sub s <- parsed]
|
|
|
|
parsed = [ if "%%" `isPrefixOf` l
|
|
then Sub $ drop 2 l
|
|
else Line l
|
|
| l <- prologue ]
|
|
|
|
splitCases :: [String] -> Either String [TestBody]
|
|
splitCases [] = throwError "Unexpected EOF"
|
|
splitCases (headLine:otherLines)
|
|
| "%PASS" `isPrefixOf` headLine
|
|
= (TestBody True testTitle $ foldl testCaseSubs [("",[])] testCaseLines)
|
|
`joinM` (splitCases furtherLines)
|
|
| "%FAIL" `isPrefixOf` headLine
|
|
= (TestBody False testTitle $ foldl testCaseSubs [("",[])] testCaseLines)
|
|
`joinM` (splitCases furtherLines)
|
|
| "%" == headLine = return []
|
|
| otherwise = throwError $ "Unexpected format in testcase-header line: \"" ++ headLine ++ "\""
|
|
where
|
|
testTitle = drop 5 headLine
|
|
|
|
(testCaseLines, furtherLines) = span (\x -> not $ "%PASS" `isPrefixOf`
|
|
x || "%FAIL" `isPrefixOf` x || "%" == x) otherLines
|
|
|
|
testCaseSubs :: [(String, [String])] -> String -> [(String, [String])]
|
|
testCaseSubs acc ('%':id) = (id, []) : acc -- start new subst
|
|
testCaseSubs ((aName, aSubst):as) l = (aName,aSubst++[l]) : as -- join to current
|
|
|
|
|
|
joinM :: Monad m => a -> m [a] -> m [a]
|
|
joinM x mxs = mxs >>* (x :)
|