diff --git a/Makefile.am b/Makefile.am index 9b3661e..ed5cc7c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -23,7 +23,7 @@ GHC_OPTS = \ -package parsec \ -package pretty \ -package process \ - -package @LIB_VER_quickcheck@ \ + -package QuickCheck \ -package random \ -package regex-compat \ -package @LIB_VER_syb@ \ diff --git a/backends/BackendPassesTest.hs b/backends/BackendPassesTest.hs index a617739..e5d4387 100644 --- a/backends/BackendPassesTest.hs +++ b/backends/BackendPassesTest.hs @@ -178,20 +178,17 @@ testTransformWaitFor5 = TestCase $ testPass "testTransformWaitFor5" exp transfor newtype PosInts = PosInts [Int] deriving (Show) instance Arbitrary PosInts where - coarbitrary = error "coarbitrary" arbitrary = do len <- choose (1, 10) replicateM len (choose (1,1000)) >>* PosInts newtype PosInt = PosInt Int deriving (Show) instance Arbitrary PosInt where - coarbitrary = error "coarbitrary" arbitrary = choose (1,20) >>* PosInt newtype StaticTypeList = StaticTypeList [A.Type] deriving (Show) instance Arbitrary StaticTypeList where - coarbitrary = error "coarbitrary" arbitrary = do len <- choose (1,10) tl <- replicateM len $ frequency [ (10, return A.Int) @@ -206,7 +203,6 @@ instance Arbitrary StaticTypeList where newtype DynTypeList = DynTypeList [A.Type] deriving (Show) instance Arbitrary DynTypeList where - coarbitrary = error "coarbitrary" arbitrary = do len <- choose (1,10) tl <- replicateM len $ frequency [ (10, return A.Int) @@ -224,7 +220,6 @@ instance Arbitrary DynTypeList where newtype AbbrevTypesIs = AbbrevTypesIs ([A.Dimension], [A.Dimension], [A.Subscript]) deriving (Show) instance Arbitrary AbbrevTypesIs where - coarbitrary = error "coarbitrary" arbitrary = do lenSrc <- choose (1,10) lenDest <- choose (1, lenSrc) srcDims <- replicateM lenSrc $ oneof [return A.UnknownDimension, choose (1,1000) >>* dimension] diff --git a/checks/ArrayUsageCheckTest.hs b/checks/ArrayUsageCheckTest.hs index 2b14e4e..fa9a9bc 100644 --- a/checks/ArrayUsageCheckTest.hs +++ b/checks/ArrayUsageCheckTest.hs @@ -30,7 +30,7 @@ import Data.Ord import qualified Data.Set as Set import Prelude hiding ((**),fail) import Test.HUnit -import Test.QuickCheck hiding (check) +import Test.QuickCheck import ArrayUsageCheck @@ -543,7 +543,6 @@ instance Show MakeEquationInput where show = const "" instance Arbitrary MakeEquationInput where - coarbitrary = error "coarbitrary" arbitrary = generateEquationInput >>* MEI frequency' :: [(Int, StateT s Gen a)] -> StateT s Gen a @@ -1054,7 +1053,6 @@ generateProblem = choose (1,10) >>= (\n -> replicateM n $ choose (-20,20)) >>= makeAns = Map.fromList instance Arbitrary OmegaTestInput where - coarbitrary = error "coarbitrary" arbitrary = generateProblem >>* OMI qcOmegaEquality :: [LabelledQuickCheckTest] @@ -1140,7 +1138,6 @@ normaliseEquality eq = case listToMaybe $ filter (/= 0) $ elems eq of newtype OmegaPruneInput = OPI MutatedProblem deriving (Show) instance Arbitrary OmegaPruneInput where - coarbitrary = error "coarbitrary" arbitrary = ((generateProblem >>* snd) >>= (return . snd) >>= mutateEquations) >>* OPI qcOmegaPrune :: [LabelledQuickCheckTest] diff --git a/common/TestFramework.hs b/common/TestFramework.hs index 6cc7604..73e4cbe 100644 --- a/common/TestFramework.hs +++ b/common/TestFramework.hs @@ -23,14 +23,21 @@ module TestFramework where import Control.Monad.Error import Data.Generics (Data) import System.IO.Unsafe +import System.Random (mkStdGen) import Test.HUnit hiding (Testable) -import Test.QuickCheck hiding (check) +import Test.QuickCheck +import qualified Test.QuickCheck.Property as QCP import PrettyShow -instance Error Result where +-- Test.QuickCheck.Property is qualified because QuickCheck 2 has two different +-- types both called Result: the one that Test.QuickCheck exports represents +-- the result of running a set of tests, and QCP.Result the result of a single +-- test. The latter's what QC 1 called Result, and what we want here. + +instance Error QCP.Result where noMsg = strMsg "" - strMsg s = Result (Just False) [s] [] + strMsg s = QCP.failed { QCP.reason = s } class Monad m => TestMonad m r | m -> r where runTest :: m () -> r @@ -42,9 +49,9 @@ instance TestMonad IO Assertion where testFailure = assertFailure runIO = id -instance TestMonad (Either Result) Result where - runTest = either id (const $ Result (Just True) [] []) - testFailure s = Left $ Result (Just False) [] [s] +instance TestMonad (Either QCP.Result) QCP.Result where + runTest = either id (const QCP.succeeded) + testFailure s = Left $ QCP.failed { QCP.reason = s } runIO f = return (unsafePerformIO f) compareForResult :: TestMonad m r => String -> (a -> String) -> (a -> a -> Bool) -> a -> a -> m () @@ -59,10 +66,10 @@ compareForResult msg showFunc cmpFunc exp act (*&&*) :: TestMonad m r => m () -> m () -> m () (*&&*) = (>>) -type QCProp = Either Result () +type QCProp = Either QCP.Result () -- | A type-constrained version of runTest for QuickCheck Testable things: -runQCTest :: QCProp -> Result +runQCTest :: QCProp -> QCP.Result runQCTest = runTest testEqual :: (Show a, Eq a, TestMonad m r) => String -> a -> a -> m () diff --git a/common/TestUtils.hs b/common/TestUtils.hs index 9af9653..3d3484d 100644 --- a/common/TestUtils.hs +++ b/common/TestUtils.hs @@ -78,33 +78,19 @@ scaleQC (low,med,high,ext) test level QC_Extensive -> run ext test where run :: Testable a => Int -> a -> Test - run n = testCheck $ defaultConfig { configMaxTest = n } + run n = testCheck $ stdArgs { maxSuccess = n } -- | Run a QuickCheck test as an HUnit test. -testCheck :: Testable a => Config -> a -> Test -testCheck config property = - TestCase $ do rnd <- newStdGen - tests config (evaluate property) rnd 0 0 [] - where - -- | The 'tests' function from QuickCheck, modified to throw assertion - -- failures when something goes wrong. (This is taken from MissingH.) - tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () - tests config gen rnd0 ntest nfail stamps - | ntest == configMaxTest config = return () - | nfail == configMaxFail config - = assertFailure $ "Arguments exhausted after " ++ show ntest ++ " tests" - | otherwise - = case ok result of - Nothing -> - tests config gen rnd1 ntest (nfail+1) stamps - Just True -> - tests config gen rnd1 (ntest+1) nfail (stamp result:stamps) - Just False -> - assertFailure $ "Falsifiable, after " ++ show ntest - ++ " tests:\n" ++ unlines (arguments result) - where - result = generate (configSize config ntest) rnd2 gen - (rnd1,rnd2) = split rnd0 +testCheck :: Testable a => Args -> a -> Test +testCheck args property = + TestCase $ do result <- quickCheckWithResult args property + case result of + Success _ _ _ -> return () + GaveUp _ _ _ -> return () + Failure numTests _ _ _ reason _ _ -> + assertFailure $ "Falsifiable, after " ++ show numTests ++ " tests:\n" ++ reason + NoExpectedFailure numTests _ _ -> + assertFailure $ "No expected failure, after " ++ show numTests ++ " tests" --}}} --{{{ building AST fragments and patterns diff --git a/configure.ac b/configure.ac index 837a1ad..6a0b0a5 100644 --- a/configure.ac +++ b/configure.ac @@ -111,8 +111,6 @@ else AC_PICK_HASKELL_LIB_VER([base],[4],[LIB_VER_base]) AC_PICK_HASKELL_LIB_VER([syb],[0],LIB_VER_syb) fi -#For now, we need QuickCheck 1: -AC_PICK_HASKELL_LIB_VER([QuickCheck],[1],[LIB_VER_quickcheck]) PKG_CHECK_MODULES(CCSP, ccsp-1.6 >= 1.6.3,, AC_MSG_WARN([CCSP not located using pkg-config; you will not be able to compile output from the C backend on this machine: ] $CCSP_PKG_ERRORS) diff --git a/flow/FlowGraphTest.hs b/flow/FlowGraphTest.hs index 99ed409..bf8edee 100644 --- a/flow/FlowGraphTest.hs +++ b/flow/FlowGraphTest.hs @@ -558,7 +558,6 @@ enforceSize1 f = sized $ \n -> if n == 0 then resize 1 f else f -- | An instance of Arbitrary for A.Structured that wraps the "genStructured" function. instance Arbitrary (QC (A.Process, Map.Map [Meta] A.Process)) where - coarbitrary = error "coarbitrary" arbitrary = enforceSize1 $ sized $ \n -> evalStateT (genProcess n) (Id 0) >>* findEmpty >>* QC where -- Copies the value for the empty-list key into the first element of the tuple: @@ -566,10 +565,6 @@ instance Arbitrary (QC (A.Process, Map.Map [Meta] A.Process)) where findEmpty xs = (fromJust $ Map.lookup [] m, m) where m = Map.fromList xs - -- coarbitrary is for defined "twiddle" functions over data generated by arbitrary. - -- For example, we could have the twiddle functions changing an expression - -- in the tree. I don't think this would be of use right now, given what we're testing - instance Show (QC (A.Process, Map.Map [Meta] A.Process)) where show (QC (p,m)) = pshow (p,nub $ concat $ Map.keys m) @@ -808,13 +803,13 @@ pickFuncRep gr = Map.fromList $ filter ((/= emptyMeta) . fst) $ map (helpApplyFu -- | It is important to have these functions in the right ratio. The number of possible trees is -- 2^N, where N is the test size. Therefore I suggest keeping N <= 10 as a sensible limit. -- Hence, if there are 1000 tests, we divide the test number by 100 to get the test size. -configForSize :: Int -> Config -configForSize n = defaultConfig { configMaxTest = n, configSize = \x -> x `div` scale } +argsForSize :: Int -> Args +argsForSize n = stdArgs { maxSuccess = n, maxSize = n `div` scale } where scale = n `div` 10 deepCheck :: Testable a => a -> QuickCheckTest -deepCheck test level = (flip testCheck) test $ configForSize $ +deepCheck test level = (flip testCheck) test $ argsForSize $ case level of QC_Low -> 100 QC_Medium -> 1000