diff --git a/TestMain.hs b/TestMain.hs index d212864..0cbfd51 100644 --- a/TestMain.hs +++ b/TestMain.hs @@ -64,19 +64,19 @@ import System.IO import Test.HUnit import qualified AnalyseAsmTest (tests) -import qualified ArrayUsageCheckTest (ioqcTests) +import qualified ArrayUsageCheckTest (vioqcTests) import qualified BackendPassesTest (qcTests) import qualified CheckTest (tests) import qualified CommonTest (tests) import qualified FlowGraphTest (qcTests) import qualified GenerateCTest (tests) import qualified OccamPassesTest (tests) -import qualified OccamTypesTest (ioTests) +import qualified OccamTypesTest (vioTests) import qualified ParseRainTest (tests) import qualified PassTest (tests) import qualified PreprocessOccamTest (tests) import qualified RainPassesTest (tests) -import qualified RainTypesTest (ioTests) +import qualified RainTypesTest (vioTests) import qualified SimplifyAbbrevsTest (tests) import qualified SimplifyTypesTest (tests) import qualified StructureOccamTest (tests) @@ -89,6 +89,7 @@ data TestOption = | OutputType Bool -- True is plain, False is erasing | ListTests | RunJust String + | Verbose deriving (Eq) type TestSet = (Test, [LabelledQuickCheckTest]) @@ -109,7 +110,7 @@ main = do (opts, nonOpts, errs) <- getArgs >>* getOpt RequireOrder options Right level -> return level Left unknown -> err $ "Unknown level: " ++ unknown - allSets <- sequence tests + allSets <- sequence $ tests opts let labelled = getLabels allSets selectedSets <- case (find (== ListTests) opts, findJust opts) of @@ -144,6 +145,7 @@ main = do (opts, nonOpts, errs) <- getArgs >>* getOpt RequireOrder options , Option [] ["plain"] (NoArg (OutputType True)) "Show the test output as plain text" , Option ['l'] ["list-tests"] (NoArg (ListTests)) "Show the top-level test names" , Option ['f'] ["filter"] (ReqArg RunJust "TESTNAME") "Run just the tests that have this in their name (use -l to list)" + , Option ['v'] ["verbose"] (NoArg Verbose) "be more verbose (use multiple times for more detail)" ] findLevel :: [TestOption] -> Either String (Maybe QuickCheckLevel) @@ -181,27 +183,29 @@ main = do (opts, nonOpts, errs) <- getArgs >>* getOpt RequireOrder options getLabel _ t@(TestLabel label _, _) = (label, t) getLabel n t = ("Unknown test: " ++ show n, t) - tests :: [IO TestSet] - tests = [ + tests :: [TestOption] -> [IO TestSet] + tests opts = [ noqc AnalyseAsmTest.tests - ,ArrayUsageCheckTest.ioqcTests + ,ArrayUsageCheckTest.vioqcTests v ,return BackendPassesTest.qcTests ,noqc CheckTest.tests ,noqc CommonTest.tests ,return FlowGraphTest.qcTests ,noqc GenerateCTest.tests ,noqc OccamPassesTest.tests - ,noqcButIO OccamTypesTest.ioTests + ,noqcButIO $ OccamTypesTest.vioTests v ,noqc ParseRainTest.tests ,noqc PassTest.tests ,noqc PreprocessOccamTest.tests ,noqc RainPassesTest.tests - ,noqcButIO RainTypesTest.ioTests + ,noqcButIO $ RainTypesTest.vioTests v ,noqc SimplifyAbbrevsTest.tests ,noqc SimplifyTypesTest.tests ,noqc StructureOccamTest.tests ,noqc UsageCheckTest.tests ] + where + v = length $ filter (== Verbose) opts noqc :: Test -> IO (Test, [LabelledQuickCheckTest]) noqc t = return (t,[]) diff --git a/checks/ArrayUsageCheck.hs b/checks/ArrayUsageCheck.hs index f142563..c978538 100644 --- a/checks/ArrayUsageCheck.hs +++ b/checks/ArrayUsageCheck.hs @@ -80,6 +80,7 @@ findRepSolutions reps bks | bk <- bks]) maxInt of Right problems -> do probs <- formatProblems [(vm, prob) | (_,vm,prob) <- problems] + debug $ "Problems in findRepSolutions:\n" ++ probs case mapMaybe solve problems of [] -> return Nothing -- No solutions, safe xs -> liftM (Just . unlines) $ mapM format xs @@ -148,7 +149,7 @@ checkArrayUsage (m,p) = mapM_ (checkIndexes m) $ Map.toList $ Right [] -> return () -- No problems to work with Right problems -> do probs <- formatProblems [(vm, prob) | (_,vm,prob) <- problems] - debug probs + debug $ "Problems in checkArrayUsage:\n" ++ probs case mapMaybe solve problems of -- No solutions; no worries! [] -> return () diff --git a/checks/ArrayUsageCheckTest.hs b/checks/ArrayUsageCheckTest.hs index 8205a3e..b9a2849 100644 --- a/checks/ArrayUsageCheckTest.hs +++ b/checks/ArrayUsageCheckTest.hs @@ -16,7 +16,7 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . -} -module ArrayUsageCheckTest (ioqcTests) where +module ArrayUsageCheckTest (vioqcTests) where import Control.Monad.Identity import Control.Monad.State @@ -1164,8 +1164,8 @@ qcOmegaPrune = [("Omega Test Pruning", scaleQC (100,1000,10000,50000) prop)] result = undefined -- TODO replace solveAndPrune: solveProblem [] inp -} -ioqcTests :: IO (Test, [LabelledQuickCheckTest]) -ioqcTests +vioqcTests :: Int -> IO (Test, [LabelledQuickCheckTest]) +vioqcTests v = seqPair (liftM (TestLabel "ArrayUsageCheckTest" . TestList) $ sequence $ map return [ @@ -1173,7 +1173,7 @@ ioqcTests ,testIndexes ,testMakeEquations ] - ++ map (automaticTest FrontendOccam) + ++ map (automaticTest FrontendOccam v) ["testcases/automatic/usage-check-1.occ.test" ,"testcases/automatic/usage-check-2.occ.test" ,"testcases/automatic/usage-check-3.occ.test" diff --git a/common/TestHarness.hs b/common/TestHarness.hs index 7844ae0..23bff1f 100644 --- a/common/TestHarness.hs +++ b/common/TestHarness.hs @@ -66,33 +66,32 @@ data AutoTest = AutoTest , bodies :: [TestBody] } -automaticTest :: CompFrontend -> FilePath -> IO Test -automaticTest fr fileName = readFile fileName >>* performTest fr fileName +automaticTest :: CompFrontend -> Int -> FilePath -> IO Test +automaticTest fr verb fileName = readFile fileName >>* performTest fr verb fileName --- Bit of a hard-hack, until usage-checking is on by default: -defaultState :: CompFrontend -> CompState -defaultState fr = emptyState {csUsageChecking = True, csFrontend = fr} +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 :: String -> IO (Maybe String) -testOccam source = do (result,_) <- runPassM (defaultState FrontendOccam) compilation - return $ case result of +testOccam :: Int -> String -> IO (Maybe 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) + >>= runPasses (getPassList $ defaultState FrontendOccam v) -testRain :: String -> IO (Maybe String) -testRain source = do (result,_) <- runPassM (defaultState FrontendRain) compilation - return $ case result of +testRain :: Int -> String -> IO (Maybe String) +testRain v source = do (result,_) <- runPassM (defaultState FrontendRain v) compilation + return $ case result of Left (_,err) -> Just err Right _ -> Nothing where compilation = parseRainProgram "" source - >>= runPasses (getPassList $ defaultState FrontendRain) + >>= runPasses (getPassList $ defaultState FrontendRain v) -- | Substitutes each substitution into the prologue substitute :: AutoTest -> Either String [(Bool, String, String)] @@ -113,8 +112,8 @@ substitute t = sequence [ do ls <- execWriterT $ subst n (prologueLines t, ss) -- | Given a file's contents, tests it -performTest :: CompFrontend -> String -> String -> Test -performTest fr fileName fileContents +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 $ @@ -126,7 +125,7 @@ performTest fr fileName fileContents performTest' :: (Bool, String, String) -> Test performTest' (expPass, testName, testText) = TestCase $ - do result <- (if fr == FrontendOccam then testOccam else testRain) testText + do result <- (if fr == FrontendOccam then testOccam else testRain) v 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") diff --git a/frontends/OccamTypesTest.hs b/frontends/OccamTypesTest.hs index deea784..6552a5c 100644 --- a/frontends/OccamTypesTest.hs +++ b/frontends/OccamTypesTest.hs @@ -19,7 +19,7 @@ with this program. If not, see . -- #ignore-exports -- | Tests for 'OccamTypes'. -module OccamTypesTest (ioTests) where +module OccamTypesTest (vioTests) where import Control.Monad.State import Data.Generics @@ -631,12 +631,12 @@ testOccamTypes = TestList --}}} -ioTests :: IO Test -ioTests = liftM (TestLabel "OccamTypesTest" . TestList) $ sequence $ +vioTests :: Int -> IO Test +vioTests v = liftM (TestLabel "OccamTypesTest" . TestList) $ sequence $ map return [ testOccamTypes ] - ++ map (automaticTest FrontendOccam) + ++ map (automaticTest FrontendOccam v) [ "testcases/automatic/direction-decorators-1.occ.test" , "testcases/automatic/direction-decorators-2.occ.test" , "testcases/automatic/direction-decorators-3.occ.test" diff --git a/frontends/RainTypesTest.hs b/frontends/RainTypesTest.hs index 3fd166b..88fc251 100644 --- a/frontends/RainTypesTest.hs +++ b/frontends/RainTypesTest.hs @@ -17,7 +17,7 @@ with this program. If not, see . -} -- | A module testing things from the RainTypes module. -module RainTypesTest (ioTests) where +module RainTypesTest (vioTests) where import Control.Monad.State import Control.Monad.Error @@ -108,10 +108,10 @@ testUnify = TestList [] {- where names = take (min (length xs) (length ys)) $ map (:[]) ['a'..] -} -ioTests :: IO Test -ioTests = liftM (TestLabel "RainTypesTest" . TestList) $ sequence +vioTests :: Int -> IO Test +vioTests v = liftM (TestLabel "RainTypesTest" . TestList) $ sequence [ return constantFoldTest ,return testUnify - ,automaticTest FrontendRain "testcases/automatic/unify-types-1.rain.test" + ,automaticTest FrontendRain v "testcases/automatic/unify-types-1.rain.test" ]