Added a new test framework, based on simple monads, to allow easy unification of HUnit and QuickCheck tests with the minimum of work
This commit is contained in:
Neil Brown
parent
5bc57689f8
commit
914e9c3d71
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
76
common/TestFramework.hs
Normal file
76
common/TestFramework.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user