+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Debug.QuickCheck
--- Copyright : (c) Koen Claessen, John Hughes 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : portable
---
--- QuickCheck v.0.2
--- DRAFT implementation; last update 000104.
--- Koen Claessen, John Hughes.
--- This file represents work in progress, and might change at a later date.
---
------------------------------------------------------------------------------
-
-module Debug.QuickCheck
- -- testing functions
- ( quickCheck -- :: prop -> IO ()
- , verboseCheck -- :: prop -> IO ()
- , test -- :: prop -> IO () -- = quickCheck
-
- , Config(..) -- :: *
- , check -- :: Config -> prop -> IO ()
-
- -- property combinators
- , forAll -- :: Gen a -> (a -> prop) -> prop
- , (==>) -- :: Bool -> prop -> prop
-
- -- gathering test-case information
- , label -- :: String -> prop -> prop
- , collect -- :: Show a => a -> prop -> prop
- , classify -- :: Bool -> String -> prop -> prop
- , trivial -- :: Bool -> prop -> prop
-
- -- generator combinators
- , Gen -- :: * -> * ; Functor, Monad
-
- , elements -- :: [a] -> Gen a
- , two -- :: Gen a -> Gen (a,a)
- , three -- :: Gen a -> Gen (a,a,a)
- , four -- :: Gen a -> Gen (a,a,a,a)
-
- , sized -- :: (Int -> Gen a) -> Gen a
- , resize -- :: Int -> Gen a -> Gen a
- , choose -- :: Random a => (a, a) -> Gen a
- , oneof -- :: [Gen a] -> Gen a
- , frequency -- :: [(Int, Gen a)] -> Gen a
-
- , vector -- :: Arbitrary a => Int -> Gen [a]
-
- -- default generators
- , Arbitrary(..) -- :: class
- , rand -- :: Gen StdGen
- , promote -- :: (a -> Gen b) -> Gen (a -> b)
- , variant -- :: Int -> Gen a -> Gen a
-
- -- testable
- , Testable(..) -- :: class
- , Property -- :: *
-
- -- For writing your own driver
- , Result(..) -- :: data
- , generate -- :: Int -> StdGen -> Gen a -> a
- , evaluate -- :: Testable a => a -> Gen Result
- )
- where
-
-import Prelude
-
-import System.Random
-import Data.List( group, sort, intersperse )
-import Control.Monad( liftM2, liftM3, liftM4 )
-
-infixr 0 ==>
-infix 1 `classify`
-
---------------------------------------------------------------------
--- Generator
-
-newtype Gen a
- = Gen (Int -> StdGen -> a)
-
-sized :: (Int -> Gen a) -> Gen a
-sized fgen = Gen (\n r -> let Gen m = fgen n in m n r)
-
-resize :: Int -> Gen a -> Gen a
-resize n (Gen m) = Gen (\_ r -> m n r)
-
-rand :: Gen StdGen
-rand = Gen (\n r -> r)
-
-promote :: (a -> Gen b) -> Gen (a -> b)
-promote f = Gen (\n r -> \a -> let Gen m = f a in m n r)
-
-variant :: Int -> Gen a -> Gen a
-variant v (Gen m) = Gen (\n r -> m n (rands r !! (v+1)))
- where
- rands r0 = r1 : rands r2 where (r1, r2) = split r0
-
-generate :: Int -> StdGen -> Gen a -> a
-generate n rnd (Gen m) = m size rnd'
- where
- (size, rnd') = randomR (0, n) rnd
-
-instance Functor Gen where
- fmap f m = m >>= return . f
-
-instance Monad Gen where
- return a = Gen (\n r -> a)
- Gen m >>= k =
- Gen (\n r0 -> let (r1,r2) = split r0
- Gen m' = k (m n r1)
- in m' n r2)
-
--- derived
-
-choose :: Random a => (a, a) -> Gen a
-choose bounds = (fst . randomR bounds) `fmap` rand
-
-elements :: [a] -> Gen a
-elements xs = (xs !!) `fmap` choose (0, length xs - 1)
-
-vector :: Arbitrary a => Int -> Gen [a]
-vector n = sequence [ arbitrary | i <- [1..n] ]
-
-oneof :: [Gen a] -> Gen a
-oneof gens = elements gens >>= id
-
-frequency :: [(Int, Gen a)] -> Gen a
-frequency xs = choose (1, tot) >>= (`pick` xs)
- where
- tot = sum (map fst xs)
-
- pick n ((k,x):xs)
- | n <= k = x
- | otherwise = pick (n-k) xs
-
--- general monadic
-
-two :: Monad m => m a -> m (a, a)
-two m = liftM2 (,) m m
-
-three :: Monad m => m a -> m (a, a, a)
-three m = liftM3 (,,) m m m
-
-four :: Monad m => m a -> m (a, a, a, a)
-four m = liftM4 (,,,) m m m m
-
---------------------------------------------------------------------
--- Arbitrary
-
-class Arbitrary a where
- arbitrary :: Gen a
- coarbitrary :: a -> Gen b -> Gen b
-
-instance Arbitrary () where
- arbitrary = return ()
- coarbitrary _ = variant 0
-
-instance Arbitrary Bool where
- arbitrary = elements [True, False]
- coarbitrary b = if b then variant 0 else variant 1
-
-instance Arbitrary Int where
- arbitrary = sized $ \n -> choose (-n,n)
- coarbitrary n = variant (if n >= 0 then 2*n else 2*(-n) + 1)
-
-instance Arbitrary Integer where
- arbitrary = sized $ \n -> choose (-fromIntegral n,fromIntegral n)
- coarbitrary n = variant (fromInteger (if n >= 0 then 2*n else 2*(-n) + 1))
-
-instance Arbitrary Float where
- arbitrary = liftM3 fraction arbitrary arbitrary arbitrary
- coarbitrary x = coarbitrary (decodeFloat x)
-
-instance Arbitrary Double where
- arbitrary = liftM3 fraction arbitrary arbitrary arbitrary
- coarbitrary x = coarbitrary (decodeFloat x)
-
-fraction a b c = fromInteger a + (fromInteger b / (abs (fromInteger c) + 1))
-
-instance (Arbitrary a, Arbitrary b) => Arbitrary (a, b) where
- arbitrary = liftM2 (,) arbitrary arbitrary
- coarbitrary (a, b) = coarbitrary a . coarbitrary b
-
-instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (a, b, c) where
- arbitrary = liftM3 (,,) arbitrary arbitrary arbitrary
- coarbitrary (a, b, c) = coarbitrary a . coarbitrary b . coarbitrary c
-
-instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)
- => Arbitrary (a, b, c, d)
- where
- arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary
- coarbitrary (a, b, c, d) =
- coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d
-
-instance Arbitrary a => Arbitrary [a] where
- arbitrary = sized (\n -> choose (0,n) >>= vector)
- coarbitrary [] = variant 0
- coarbitrary (a:as) = coarbitrary a . variant 1 . coarbitrary as
-
-instance (Arbitrary a, Arbitrary b) => Arbitrary (a -> b) where
- arbitrary = promote (`coarbitrary` arbitrary)
- coarbitrary f gen = arbitrary >>= ((`coarbitrary` gen) . f)
-
---------------------------------------------------------------------
--- Testable
-
-data Result
- = Result { ok :: Maybe Bool, stamp :: [String], arguments :: [String] }
-
-nothing :: Result
-nothing = Result{ ok = Nothing, stamp = [], arguments = [] }
-
-newtype Property
- = Prop (Gen Result)
-
-result :: Result -> Property
-result res = Prop (return res)
-
-evaluate :: Testable a => a -> Gen Result
-evaluate a = gen where Prop gen = property a
-
-class Testable a where
- property :: a -> Property
-
-instance Testable () where
- property _ = result nothing
-
-instance Testable Bool where
- property b = result (nothing{ ok = Just b })
-
-instance Testable Result where
- property res = result res
-
-instance Testable Property where
- property prop = prop
-
-instance (Arbitrary a, Show a, Testable b) => Testable (a -> b) where
- property f = forAll arbitrary f
-
-forAll :: (Show a, Testable b) => Gen a -> (a -> b) -> Property
-forAll gen body = Prop $
- do a <- gen
- res <- evaluate (body a)
- return (argument a res)
- where
- argument a res = res{ arguments = show a : arguments res }
-
-(==>) :: Testable a => Bool -> a -> Property
-True ==> a = property a
-False ==> a = property ()
-
-label :: Testable a => String -> a -> Property
-label s a = Prop (add `fmap` evaluate a)
- where
- add res = res{ stamp = s : stamp res }
-
-classify :: Testable a => Bool -> String -> a -> Property
-classify True name = label name
-classify False _ = property
-
-trivial :: Testable a => Bool -> a -> Property
-trivial = (`classify` "trivial")
-
-collect :: (Show a, Testable b) => a -> b -> Property
-collect v = label (show v)
-
---------------------------------------------------------------------
--- Testing
-
-data Config = Config
- { configMaxTest :: Int
- , configMaxFail :: Int
- , configSize :: Int -> Int
- , configEvery :: Int -> [String] -> String
- }
-
-quick :: Config
-quick = Config
- { configMaxTest = 100
- , configMaxFail = 1000
- , configSize = (+ 3) . (`div` 2)
- , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
- }
-
-verbose :: Config
-verbose = quick
- { configEvery = \n args -> show n ++ ":\n" ++ unlines args
- }
-
-test, quickCheck, verboseCheck :: Testable a => a -> IO ()
-test = check quick
-quickCheck = check quick
-verboseCheck = check verbose
-
-check :: Testable a => Config -> a -> IO ()
-check config a =
- do rnd <- newStdGen
- tests config (evaluate a) rnd 0 0 []
-
-tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO ()
-tests config gen rnd0 ntest nfail stamps
- | ntest == configMaxTest config = do done "OK, passed" ntest stamps
- | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps
- | otherwise =
- do putStr (configEvery config ntest (arguments result))
- 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 ->
- putStr ( "Falsifiable, after "
- ++ show ntest
- ++ " tests:\n"
- ++ unlines (arguments result)
- )
- where
- result = generate (configSize config ntest) rnd2 gen
- (rnd1,rnd2) = split rnd0
-
-done :: String -> Int -> [[String]] -> IO ()
-done mesg ntest stamps =
- do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
- where
- table = display
- . map entry
- . reverse
- . sort
- . map pairLength
- . group
- . sort
- . filter (not . null)
- $ stamps
-
- display [] = ".\n"
- display [x] = " (" ++ x ++ ").\n"
- display xs = ".\n" ++ unlines (map (++ ".") xs)
-
- pairLength xss@(xs:_) = (length xss, xs)
- entry (n, xs) = percentage n ntest
- ++ " "
- ++ concat (intersperse ", " xs)
-
- percentage n m = show ((100 * n) `div` m) ++ "%"
-
---------------------------------------------------------------------
--- the end.
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Debug.QuickCheck.Batch
--- Copyright : (c) Andy Gill 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (uses Control.Exception, Control.Concurrent)
---
--- This is a batch driver for running QuickCheck (GHC only).
---
------------------------------------------------------------------------------
-
-{-
- - Here is the key for reading the output.
- - . = test successful
- - ? = every example passed, but quickcheck did not find enough good examples
- - * = test aborted for some reason (out-of-time, bottom, etc)
- - # = test failed outright
- -
- - We also provide the dangerous "isBottom".
- -
- - Here is is an example of use for sorting:
- -
- - testOptions :: TestOptions
- - testOptions = TestOptions
- - { no_of_tests = 100 -- number of tests to run
- - , length_of_tests = 1 -- 1 second max per check
- - -- where a check == n tests
- - , debug_tests = False -- True => debugging info
- - }
- -
- - prop_sort1 xs = sort xs == sortBy compare xs
- - where types = (xs :: [OrdALPHA])
- - prop_sort2 xs =
- - (not (null xs)) ==>
- - (head (sort xs) == minimum xs)
- - where types = (xs :: [OrdALPHA])
- - prop_sort3 xs = (not (null xs)) ==>
- - last (sort xs) == maximum xs
- - where types = (xs :: [OrdALPHA])
- - prop_sort4 xs ys =
- - (not (null xs)) ==>
- - (not (null ys)) ==>
- - (head (sort (xs ++ ys)) == min (minimum xs) (minimum ys))
- - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
- - prop_sort6 xs ys =
- - (not (null xs)) ==>
- - (not (null ys)) ==>
- - (last (sort (xs ++ ys)) == max (maximum xs) (maximum ys))
- - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
- - prop_sort5 xs ys =
- - (not (null xs)) ==>
- - (not (null ys)) ==>
- - (head (sort (xs ++ ys)) == max (maximum xs) (maximum ys))
- - where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
- -
- - test_sort = runTests "sort" testOptions
- - [ run prop_sort1
- - , run prop_sort2
- - , run prop_sort3
- - , run prop_sort4
- - , run prop_sort5
- - ]
- -
- - When run, this gives
- - Main> test_sort
- - sort : .....
- -
- - You would tie together all the test_* functions
- - into one test_everything, on a per module basis.
- -
- - Examples of use of bottom and isBottom:
- - {- test for abort -}
- - prop_head2 = isBottom (head [])
- - {- test for strictness -}
- - prop_head3 = isBottom (head bottom)
- -}
-
-module Debug.QuickCheck.Batch
- ( run -- :: Testable a => a -> TestOptions -> IO TestResult
- , runTests -- :: String -> TestOptions ->
- -- [TestOptions -> IO TestResult] -> IO ()
- , defOpt -- :: TestOptions
- , TestOptions (..)
- , TestResult (..)
- , isBottom -- :: a -> Bool
- , bottom -- :: a {- _|_ -}
- ) where
-
-import Prelude
-
-import System.Random
-import Control.Concurrent
-import Control.Exception hiding (catch, evaluate)
-import qualified Control.Exception as Exception (catch, evaluate)
-import Debug.QuickCheck
-import System.IO.Unsafe
-
-data TestOptions = TestOptions {
- no_of_tests :: Int,
- length_of_tests :: Int,
- debug_tests :: Bool }
-
-defOpt :: TestOptions
-defOpt = TestOptions
- { no_of_tests = 100
- , length_of_tests = 1
- , debug_tests = False
- }
-
-data TestResult = TestOk String Int [[String]]
- | TestExausted String Int [[String]]
- | TestFailed [String] Int
- | TestAborted Exception
-
-tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]]
- -> IO TestResult
-tests config gen rnd0 ntest nfail stamps
- | ntest == configMaxTest config = return (TestOk "OK, passed" ntest stamps)
- | nfail == configMaxFail config = return (TestExausted "Arguments exhausted after"
- ntest stamps)
- | otherwise =
- do (if not (null txt) then putStr txt else return ())
- 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 ->
- do return (TestFailed (arguments result) ntest)
- where
- txt = configEvery config ntest (arguments result)
- result = generate (configSize config ntest) rnd2 gen
- (rnd1,rnd2) = split rnd0
-
-batch n v = Config
- { configMaxTest = n
- , configMaxFail = n * 10
- , configSize = (+ 3) . (`div` 2)
- , configEvery = \n args -> if v then show n ++ ":\n" ++ unlines args else ""
- }
-
--- Here we use the same random number each time,
--- so we get reproducable results!
-run :: Testable a => a -> TestOptions -> IO TestResult
-run a TestOptions { no_of_tests = n, length_of_tests = len, debug_tests = debug } =
- do me <- myThreadId
- ready <- newEmptyMVar
- r <- if len == 0
- then try theTest
- else try (do
- -- This waits a bit, then raises an exception in its parent,
- -- saying, right, you've had long enough!
- watcher <- forkIO (Exception.catch
- (do threadDelay (len * 1000 * 1000)
- takeMVar ready
- throwTo me NonTermination
- return ())
- (\ _ -> return ()))
- -- Tell the watcher we are starting...
- putMVar ready ()
- -- This is cheating, because possibly some of the internal message
- -- inside "r" might be _|_, but anyway....
- r <- theTest
- -- Now, we turn off the watcher.
- -- Ignored if the watcher is already dead,
- -- (unless some unlucky thread picks up the same name)
- killThread watcher
- return r)
- case r of
- Right r -> return r
- Left e -> return (TestAborted e)
- where
- theTest = tests (batch n debug) (evaluate a) (mkStdGen 0) 0 0 []
-
--- Prints a one line summary of various tests with common theme
-runTests :: String -> TestOptions -> [TestOptions -> IO TestResult] -> IO ()
-runTests name scale actions =
- do putStr (rjustify 25 name ++ " : ")
- f <- tr 1 actions [] 0
- mapM fa f
- return ()
- where
- rjustify n s = replicate (max 0 (n - length s)) ' ' ++ s
-
- tr n [] xs c = do
- putStr (rjustify (max 0 (35-n)) " (" ++ show c ++ ")\n")
- return xs
- tr n (action:actions) others c =
- do r <- action scale
- case r of
- (TestOk _ m _)
- -> do { putStr "." ;
- tr (n+1) actions others (c+m) }
- (TestExausted s m ss)
-
- -> do { putStr "?" ;
- tr (n+1) actions others (c+m) }
- (TestAborted e)
- -> do { putStr "*" ;
- tr (n+1) actions others c }
- (TestFailed f num)
- -> do { putStr "#" ;
- tr (n+1) actions ((f,n,num):others) (c+num) }
-
- fa :: ([String],Int,Int) -> IO ()
- fa (f,n,no) =
- do putStr "\n"
- putStr (" ** test "
- ++ show (n :: Int)
- ++ " of "
- ++ name
- ++ " failed with the binding(s)\n")
- sequence_ [putStr (" ** " ++ v ++ "\n")
- | v <- f ]
- putStr "\n"
-
--- Look out behind you! These can be misused badly.
--- However, in the context of a batch tester, can also be very useful.
-
-bottom = error "_|_"
-
-isBottom :: a -> Bool
-isBottom a = unsafePerformIO (do
- a' <- try (Exception.evaluate a)
- case a' of
- Left _ -> return True
- Right _ -> return False)
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : Debug.QuickCheck.Poly
--- Copyright : (c) Andy Gill 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : experimental
--- Portability : non-portable (uses Control.Exception, Control.Concurrent)
---
--- This is an attempt to emulate polymorphic types for the
--- purposes of testing by using abstract monomorphic types.
---
--- It is likely that future versions of QuickCheck will
--- include some polymorphic emulation testing facility,
--- but this module can be used for now.
---
------------------------------------------------------------------------------
-
-module Debug.QuickCheck.Poly
- ( ALPHA
- , BETA
- , GAMMA
- , OrdALPHA
- , OrdBETA
- , OrdGAMMA
- ) where
-
-import Prelude
-
-import Debug.QuickCheck
-import Debug.QuickCheck.Utils
-
-{- This is the basic pseudo-polymorphic object.
- - The idea is you can't cheat, and use the integer
- - directly, but need to use the abstraction.
- -
- - We use phantom types (ref: Domain Specific Embedded Compilers,
- - Daan Leijen & Erik Meijer, 2nd Conference of Domain Specific
- - Languages, Austin, TX, 1999)
- -}
-
-newtype Poly a = Poly Int
-
-instance Show (Poly a) where
- show (Poly a) = "_" ++ show a
-
-instance Arbitrary (Poly a) where
- arbitrary = sized $ \n -> (choose (1,n) >>= return . Poly)
- coarbitrary (Poly n) = variant (if n >= 0 then 2*n else 2*(-n) + 1)
-
-instance Eq a => Eq (Poly a) where
- (Poly a) == (Poly b) = a == b
-
-instance Ord a => Ord (Poly a) where
- (Poly a) `compare` (Poly b) = a `compare` b
-
-{-
- - These are what we export, our pseudo-polymorphic instances.
- -}
-
-type ALPHA = Poly ALPHA_
-data ALPHA_ = ALPHA_ deriving (Eq)
-
-type BETA = Poly BETA_
-data BETA_ = BETA_ deriving (Eq)
-
-type GAMMA = Poly GAMMA_
-data GAMMA_ = GAMMA_ deriving (Eq)
-
-type OrdALPHA = Poly OrdALPHA_
-data OrdALPHA_ = OrdALPHA_ deriving (Eq,Ord)
-
-type OrdBETA = Poly OrdBETA_
-data OrdBETA_ = OrdBETA_ deriving (Eq,Ord)
-
-type OrdGAMMA = Poly OrdGAMMA_
-data OrdGAMMA_ = OrdGAMMA_ deriving (Eq,Ord)
-
-{-
- - This is a condition on OrdALPHA, OrdBETA, etc, itself.
- - It states that all OrdALPHA objects obey total ordering.
- -}
-
-prop_OrdPOLY x y = isTotalOrder x y
- where types = (x :: OrdALPHA, y :: OrdALPHA)
projects / ghc-base.git / commitdiff