Added a new test framework, based on simple monads, to allow easy unification of HUnit and QuickCheck tests with the minimum of work

Makefile.am

@@ -147,6 +147,7 @@ tocktest_SOURCES += checks/ArrayUsageCheckTest.hs
 tocktest_SOURCES += checks/RainUsageCheckTest.hs
 tocktest_SOURCES += common/CommonTest.hs
 tocktest_SOURCES += common/FlowGraphTest.hs
+tocktest_SOURCES += common/TestFramework.hs
 tocktest_SOURCES += common/TestHarness.hs
 tocktest_SOURCES += common/TestUtils.hs
 tocktest_SOURCES += frontends/ParseRainTest.hs

checks/ArrayUsageCheckTest.hs

@@ -34,6 +34,7 @@ import ArrayUsageCheck
 import qualified AST as A
 import Metadata
 import Omega
+import TestFramework
 import TestHarness
 import TestUtils hiding (m)
 import UsageCheckUtils hiding (Var)
@@ -608,15 +609,16 @@ generateMapping :: VarMap -> VarMap -> Maybe [(CoeffIndex,CoeffIndex)]
 generateMapping m0 m1 = if Map.keys m0 /= Map.keys m1 then Nothing else Just (Map.elems $ zipMap mergeMaybe m0 m1)
 
 -- | Given a forward mapping list, translates equations across
-translateEquations :: [(CoeffIndex,CoeffIndex)] -> (EqualityProblem, InequalityProblem) -> IO (Maybe (EqualityProblem, InequalityProblem))
+translateEquations :: forall m r. TestMonad m r =>
+  [(CoeffIndex,CoeffIndex)] -> (EqualityProblem, InequalityProblem) -> m (Maybe (EqualityProblem, InequalityProblem))
 translateEquations mp (eq,ineq)
-  = do assertEqual "translateEquations mapping not one-to-one" (sort $ map fst mp) (sort $ map snd mp)
+  = do testEqual "translateEquations mapping not one-to-one" (sort $ map fst mp) (sort $ map snd mp)
-       assertCompareCustom "translateEquations input not square" (>=) 1 $ length $ nub $ map (snd . bounds) $ eq ++ ineq
+       testCompareCustom "translateEquations input not square" (>=) 1 $ length $ nub $ map (snd . bounds) $ eq ++ ineq
        eq' <- mapM swapColumns eq >>* sequence -- mapM is in the IO monad, sequence is in the Maybe monad
        ineq' <- mapM swapColumns ineq >>* sequence
        return $ mergeMaybe eq' ineq'
   where
-    swapColumns :: Array CoeffIndex Integer -> IO (Maybe (Array CoeffIndex Integer))
+    swapColumns :: Array CoeffIndex Integer -> m (Maybe (Array CoeffIndex Integer))
     swapColumns arr
       = case mapM swapColumns' $ assocs arr of
           Just swapped -> check arr swapped >> (return . Just $ simpleArray swapped)
@@ -626,17 +628,17 @@ translateEquations mp (eq,ineq)
         swapColumns' (0,v) = Just (0,v) -- Never swap the units column
         swapColumns' (x,v) = transformMaybe (\y -> (y,v)) $ transformMaybe fst $ find ((== x) . snd) mp
     
-    check :: Show a => a -> [(CoeffIndex,Integer)] -> Assertion
+    check :: Show a => a -> [(CoeffIndex,Integer)] -> m ()
     check x ies = if length ies == 1 + maximum (map fst ies) then return () else
-       assertFailure $ "Error in translateEquations, not all indexes present after swap: " ++ show ies
+       testFailure $ "Error in translateEquations, not all indexes present after swap: " ++ show ies
          ++ " value beforehand was: " ++ show x ++ " mapping was: " ++ show mp
 
 -- | Asserts that the two problems are equivalent, once you take into account the potentially different variable mappings
-assertEquivalentProblems :: String -> [(Int, A.Expression)] -> [((A.Expression, A.Expression), VarMap, (EqualityProblem, InequalityProblem))] ->
+assertEquivalentProblems :: forall m r. TestMonad m r => String -> [(Int, A.Expression)] -> [((A.Expression, A.Expression), VarMap, (EqualityProblem, InequalityProblem))] ->
-  [((A.Expression, A.Expression), VarMap, (EqualityProblem, InequalityProblem))] -> Assertion
+  [((A.Expression, A.Expression), VarMap, (EqualityProblem, InequalityProblem))] -> m ()
 assertEquivalentProblems title indExpr exp act
   = do transformed <- mapM (uncurry transform) $ map (uncurry checkLabel) $ zip (sortByLabels exp) (sortByLabels act)
-       (uncurry $ assertEqualCustomShow showFunc title)
+       (uncurry $ testEqualCustomShow showFunc title)
          $ pairPairs (length exp, length act) $ transformPair sortProblem sortProblem $ unzip $ transformed
   where
     showFunc :: (Int, [Maybe (EqualityProblem, InequalityProblem)]) -> String
@@ -666,7 +668,7 @@ assertEquivalentProblems title indExpr exp act
         lookup e = maybe (-1) fst $ find ((== e) . snd) indExpr
 
     transform :: (VarMap, (EqualityProblem, InequalityProblem)) -> (VarMap, (EqualityProblem, InequalityProblem)) ->
-                       IO ( Maybe (EqualityProblem, InequalityProblem), Maybe (EqualityProblem, InequalityProblem) )
+                       m ( Maybe (EqualityProblem, InequalityProblem), Maybe (EqualityProblem, InequalityProblem) )
     transform exp@(_, (e_eq, e_ineq)) act@(_, (a_eq, a_ineq))
       = do translatedExp <- case generateMapping (fst exp) (fst act) of
              Just mapping -> translateEquations mapping (resize e_eq, resize e_ineq)
@@ -792,13 +794,14 @@ instance Arbitrary OmegaTestInput where
 qcOmegaEquality :: [LabelledQuickCheckTest]
 qcOmegaEquality = [("Omega Test Equality Solving", scaleQC (40,200,2000,10000) prop)]
   where
+    prop :: OmegaTestInput -> QCProp
     prop (OMI (ans,(eq,ineq))) = omegaCheck actAnswer
       where
         actAnswer = solveConstraints (defaultMapping $ Map.size ans) eq ineq
         -- We use Map.assocs because pshow doesn't work on Maps
         omegaCheck (Just (vm,ineqs)) = (True *==* all (all (== 0) . elems) ineqs)
           *&&* ((Map.assocs ans) *==* (Map.assocs $ getCounterEqs vm))
-        omegaCheck Nothing = mkFailResult ("Found Nothing while expecting answer: " ++ show (eq,ineq))
+        omegaCheck Nothing = testFailure ("Found Nothing while expecting answer: " ++ show (eq,ineq))
 
 -- | A randomly mutated problem ready for testing the inequality pruning.
 -- The first part is the input to the pruning, and the second part is the expected result;

common/FlowGraphTest.hs

@@ -37,6 +37,7 @@ import qualified AST as A
 import FlowGraph
 import Metadata
 import PrettyShow
+import TestFramework
 import TestUtils
 import Utils
 
@@ -694,21 +695,21 @@ testModify =
   where
     -- | Checks that applying any set (from the powerset of identity functions) of identity functions
     -- does not change the AST.
-    prop_Id :: QC (A.Process, Map.Map [Meta] A.Process) -> Result
+    prop_Id :: QC (A.Process, Map.Map [Meta] A.Process) -> QCProp
-    prop_Id (QC (g,_)) = collectAll $ (flip map) (map (foldFuncsM) $ powerset $ pickFuncId $ genGraph g') $ \f -> runIdentity (f g') *==* g'
+    prop_Id (QC (g,_)) = sequence_ $ (flip map) (map (foldFuncsM) $ powerset $ pickFuncId $ genGraph g') $ \f -> runIdentity (f g') *==* g'
       where
         g' = A.Only emptyMeta g
 
     -- | Checks that applying any set (from the powerset of replacement functions) of replacement functions
     -- produces the expected result.
-    prop_Rep :: QC (A.Process, Map.Map [Meta] A.Process) -> Result
+    prop_Rep :: QC (A.Process, Map.Map [Meta] A.Process) -> QCProp
-    prop_Rep (QC (g,rest)) = collectAll $ (flip map) (helper $ pickFuncRep $ genGraph g') $ 
+    prop_Rep (QC (g,rest)) = sequence_ $ (flip map) (helper $ pickFuncRep $ genGraph g') $ 
         \(funcs,ms) -> Just (runIdentity (applyMetas ms funcs g')) *==* (Map.lookup ms rest >>* A.Only emptyMeta)
       where
         g' = A.Only emptyMeta g
   
     -- | This tests our genNumsToTotal function, which is itself a test generator; nasty!
-    prop_gennums :: Int -> Result
+    prop_gennums :: Int -> QCProp
     prop_gennums n = generate 0 (mkStdGen 0) (genNumsToTotal n >>* sum) *==* n
 
     -- | Repeatedly pairs the map with each element of the powerset of its keys
@@ -719,16 +720,6 @@ testModify =
     applyMetas :: Monad m => [Meta] -> Map.Map Meta (A.Structured a -> m (A.Structured a)) -> (A.Structured a -> m (A.Structured a))
     applyMetas ms funcs = foldFuncsM $ concatMap (\m -> Map.lookup m funcs) ms
 
-
-    -- | Collects multiple test results together, using the first failure as its result
-    --  (if there is a failure; otherwise the result will be a pass).
-    collectAll :: [Result] -> Result
-    collectAll = foldl collectAll'(Result {ok = Just True, arguments = [], stamp = []})
-      where
-        -- Only keep the first failure:
-        collectAll' :: Result -> Result -> Result
-        collectAll' r0 r1 | ok r0 == Just False = r0
-                          | otherwise = r1
 -- | Returns the list of tests:
 qcTests :: (Test, [LabelledQuickCheckTest])
 qcTests = (TestLabel "FlowGraphTest" $ TestList

common/TestFramework.hs

@@ -0,0 +1,76 @@
+{-
+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/>.
+-}
+
+-- | A unified test framework that allows tests to be used in either
+-- HUnit, QuickCheck (or any future test frameworks).
+module TestFramework where
+
+import Control.Monad.Error
+import Data.Generics
+import Test.HUnit hiding (Testable)
+import Test.QuickCheck hiding (check)
+
+import PrettyShow
+
+instance Error Result where
+  noMsg = strMsg ""
+  strMsg s = Result (Just False) [s] []
+
+class Monad m => TestMonad m r | m -> r where
+  runTest :: m () -> r
+  testFailure :: String -> m ()
+
+instance TestMonad IO Assertion where
+  runTest = id
+  testFailure = assertFailure
+  
+instance TestMonad (Either Result) Result where
+  runTest = either id (const $ Result (Just True) [] [])
+  testFailure s = Left $ Result (Just False) [] [s]
+
+compareForResult :: TestMonad m r => String -> (a -> String) -> (a -> a -> Bool) -> a -> a -> m ()
+compareForResult msg showFunc cmpFunc exp act
+  | cmpFunc exp act = return ()
+  | otherwise = testFailure (msg ++ "\n" ++ "expected: " ++ showFunc exp ++ "\n but got: " ++ showFunc act)
+
+-- | An equality operator for comparing expected (LHS) to actual (RHS) 
+(*==*) :: (Data a, Eq a, TestMonad m r) => a -> a -> m ()
+(*==*) = compareForResult "" pshow (==)
+
+(*&&*) :: TestMonad m r => m () -> m () -> m ()
+(*&&*) = (>>)
+
+instance (TestMonad m r, Testable r) => Testable (m ()) where
+  property = property . runTest
+
+type QCProp = Either Result ()
+
+testEqual :: (Show a, Eq a, TestMonad m r) => String -> a -> a -> m ()
+testEqual msg = compareForResult msg show (==)
+
+testEqualCustomShow :: (Eq a, TestMonad m r) => (a -> String) -> String -> a -> a -> m ()
+testEqualCustomShow showFunc testName = compareForResult testName showFunc (==)
+
+testCompareCustom :: 
+  (Show a, TestMonad m r) => 
+  String               -- ^ The message\/test name to prefix on failure.
+  -> (a -> a -> Bool)  -- ^ The comparison function.  A return of True means the Assertion will succeed, False means the Assertion will fail.
+  -> a                 -- ^ The expected\/yardstick value.
+  -> a                 -- ^ The actual value from running the test.
+  -> m ()
+testCompareCustom testName = compareForResult testName show

common/TestUtils.hs

@@ -75,21 +75,6 @@ scaleQC (low,med,high,ext) test level
     run :: Testable a => Int -> a -> IO ()
     run n = check (defaultConfig { configMaxTest = n })
 
--- | A form of equality that yields a (QuickCheck) Result rather than a Bool, with the arguments pretty-printed
-(*==*) :: (Data a, Eq a) => a -> a -> Result
-(*==*) x y = Result {ok = Just (x == y), arguments = [pshow x, pshow y], stamp = []}
-
--- | Joins together two results from (*==*).  Not sure what to do with other Results (when will ok be Nothing?).
-(*&&*) :: Result -> Result -> Result
-(*&&*) x@(Result (Just False) _ _) _ = x
-(*&&*) _ y = y
-
-mkPassResult :: Result
-mkPassResult = Result (Just True) [] []
-
-mkFailResult :: String -> Result
-mkFailResult s = Result (Just False) [s] []
-
 data TimedTaskLevel = TT_Low | TT_Medium | TT_High
 
 -- | The numbers are mean, variance
@@ -504,8 +489,3 @@ assertEitherFail testName result
      = case result of
          Left _ -> return ()
          Right _ -> assertFailure $ testName ++ "; test expected to fail but passed"
-
-assertEqualCustomShow :: Eq a => (a -> String) -> String -> a -> a -> Assertion
-assertEqualCustomShow showFunc testName exp act
-  | exp == act = return ()
-  | otherwise  = assertFailure $ testName ++ "\n" ++ "expected: " ++ showFunc exp ++ "\n but got: " ++ showFunc act