Changed tocktest so you can pass it -v options for use with the automatic tests

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 :: [TestOption] -> [IO TestSet]
-    tests = [
+    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,[])

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 ()

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 <http://www.gnu.org/licenses/>.
 -}
 
-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])
+vioqcTests :: Int -> IO (Test, [LabelledQuickCheckTest])
-ioqcTests
+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"

common/TestHarness.hs

@@ -66,33 +66,32 @@ data AutoTest = AutoTest
   , bodies :: [TestBody]
   }
 
-automaticTest :: CompFrontend -> FilePath -> IO Test
+automaticTest :: CompFrontend -> Int -> FilePath -> IO Test
-automaticTest fr fileName = readFile fileName >>* performTest fr fileName
+automaticTest fr verb fileName = readFile fileName >>* performTest fr verb fileName
 
--- Bit of a hard-hack, until usage-checking is on by default:
+defaultState :: CompFrontend -> Int -> CompState
-defaultState :: CompFrontend -> CompState
+defaultState fr v = emptyState {csVerboseLevel = v, csFrontend = fr}
-defaultState fr = emptyState {csUsageChecking = True, 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 :: Int -> String -> IO (Maybe String)
-testOccam source = do (result,_) <- runPassM (defaultState FrontendOccam) compilation
+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 :: Int -> String -> IO (Maybe String)
-testRain  source = do (result,_) <- runPassM (defaultState FrontendRain) compilation
+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)
+                  >>= 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 :: CompFrontend -> Int -> String -> String -> Test
-performTest fr fileName fileContents
+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")

frontends/OccamTypesTest.hs

@@ -19,7 +19,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 -- #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
+vioTests :: Int -> IO Test
-ioTests = liftM (TestLabel "OccamTypesTest" . TestList) $ sequence $
+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"

frontends/RainTypesTest.hs

@@ -17,7 +17,7 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 -}
 
 -- | 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
+vioTests :: Int -> IO Test
-ioTests = liftM (TestLabel "RainTypesTest" . TestList) $ sequence
+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"
  ]