From 914e9c3d71d17f57e32b158ccb66c43a1e095962 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Fri, 8 Feb 2008 16:56:32 +0000 Subject: [PATCH] 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 | 1 + checks/ArrayUsageCheckTest.hs | 25 +++++++----- common/FlowGraphTest.hs | 21 +++------- common/TestFramework.hs | 76 +++++++++++++++++++++++++++++++++++ common/TestUtils.hs | 20 --------- 5 files changed, 97 insertions(+), 46 deletions(-) create mode 100644 common/TestFramework.hs diff --git a/Makefile.am b/Makefile.am index 05e4f2b..bbc3faf 100644 --- a/Makefile.am +++ b/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 diff --git a/checks/ArrayUsageCheckTest.hs b/checks/ArrayUsageCheckTest.hs index 7d582e4..124a31b 100644 --- a/checks/ArrayUsageCheckTest.hs +++ b/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) - assertCompareCustom "translateEquations input not square" (>=) 1 $ length $ nub $ map (snd . bounds) $ eq ++ ineq + = do testEqual "translateEquations mapping not one-to-one" (sort $ map fst mp) (sort $ map snd mp) + 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))] -> - [((A.Expression, A.Expression), VarMap, (EqualityProblem, InequalityProblem))] -> Assertion +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))] -> 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; diff --git a/common/FlowGraphTest.hs b/common/FlowGraphTest.hs index 120a37f..eccb794 100644 --- a/common/FlowGraphTest.hs +++ b/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 (g,_)) = collectAll $ (flip map) (map (foldFuncsM) $ powerset $ pickFuncId $ genGraph g') $ \f -> runIdentity (f g') *==* g' + prop_Id :: QC (A.Process, Map.Map [Meta] A.Process) -> QCProp + 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 (g,rest)) = collectAll $ (flip map) (helper $ pickFuncRep $ genGraph g') $ + prop_Rep :: QC (A.Process, Map.Map [Meta] A.Process) -> QCProp + 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 diff --git a/common/TestFramework.hs b/common/TestFramework.hs new file mode 100644 index 0000000..e75cd9a --- /dev/null +++ b/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 . +-} + +-- | 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 diff --git a/common/TestUtils.hs b/common/TestUtils.hs index d0c5ce2..2e947fe 100644 --- a/common/TestUtils.hs +++ b/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