packages feed

checkers (empty) → 0.1

raw patch · 23 files changed

+1443/−0 lines, 23 filesdep +QuickCheckdep +arraydep +basesetup-changed

Dependencies added: QuickCheck, array, base, random

Files

+ Makefile view
@@ -0,0 +1,2 @@+# On code.haskell.org+include ../cho-cabal-make.inc
+ README view
@@ -0,0 +1,21 @@+Checkers [1] is a library for reusable QuickCheck properties, particularly+for standard type classes (class laws and class morphisms [2]).  Most of+Reactive [3] can be specified and tested using just these properties.+Also lots of support for randomly generating data values (thanks to Thomas+Davie).++Please share any comments & suggestions on the discussion (talk) page at+[1].++You can configure, build, and install all in the usual way with Cabal+commands.++  runhaskell Setup.lhs configure+  runhaskell Setup.lhs build+  runhaskell Setup.lhs install++References:++[1] http://haskell.org/haskellwiki/checkers+[2] http://conal.net/papers/simply-reactive+[3] http://haskell.org/haskellwiki/reactive
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ changes.tw view
@@ -0,0 +1,5 @@+== Version 0 ==++=== Version 0.0 ===++*
+ checkers.cabal view
@@ -0,0 +1,54 @@+Name:                checkers+Version:             0.1+Cabal-Version:       >= 1.2+Synopsis:            Check properties on standard classes and data structures.+Category:            Testing+Description:+  ''Checkers'' wraps up the expected properties associated with various+  standard type classes as QuickCheck properties.  Also some morphism+  properties.  It also provides arbitrary instances and generator combinators+  for common data types.+  .+  Project wiki page: <http://haskell.org/haskellwiki/checkers>+  .+  The module documentation pages have links to colorized source code and+  to wiki pages where you can read and contribute user comments.  Enjoy!+  .+  &#169; 2008 by Conal Elliott; BSD3 license.+  .+  Contributions from: Thomas Davie.+Author:              Conal Elliott +Maintainer:          conal@conal.net+Homepage:            http://haskell.org/haskellwiki/checkers+Package-Url:         http://code.haskell.org/checkers+Copyright:           (c) 2008 by Conal Elliott+License:             BSD3+Stability:           experimental+build-type:          Simple++Library+  hs-Source-Dirs:      src+  Extensions:+  Build-Depends:       base, random, QuickCheck < 2.0, array >= 0.1+  Exposed-Modules:     +                       Test.QuickCheck.Checkers+                       Test.QuickCheck.Applicative+                       Test.QuickCheck.Classes+                       Test.QuickCheck.Bottoms+                       Test.QuickCheck.Instances+                       Test.QuickCheck.Instances.Array+                       Test.QuickCheck.Instances.Char+                       Test.QuickCheck.Instances.Eq+                       Test.QuickCheck.Instances.Int+                       Test.QuickCheck.Instances.List+                       Test.QuickCheck.Instances.Maybe+                       Test.QuickCheck.Instances.Num+                       Test.QuickCheck.Instances.Ord+                       Test.QuickCheck.Instances.Tuple+                       Test.QuickCheck.Instances.Word+                       Test.QuickCheck.Later+  Other-modules:+                       Control.Monad.Extensions+  ghc-options:         -Wall -fno-warn-orphans++--  ghc-prof-options:    -prof -auto-all
+ src/Control/Monad/Extensions.hs view
@@ -0,0 +1,10 @@+module Control.Monad.Extensions (satisfiesM,if') where++import Control.Applicative+import Control.Monad++satisfiesM :: Monad m => (a -> Bool) -> m a -> m a+satisfiesM p x = x >>= if' p return (const (satisfiesM p x))++if' :: Applicative f => f Bool -> f a -> f a -> f a+if' = liftA3 (\ c t e -> if c then t else e)
+ src/Test/QuickCheck/Applicative.hs view
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+module Test.QuickCheck.Applicative where++import Test.QuickCheck+import Control.Monad+import Control.Applicative++instance Applicative Gen where { pure = return ; (<*>) = ap }
+ src/Test/QuickCheck/Bottoms.hs view
@@ -0,0 +1,34 @@+module Test.QuickCheck.Bottoms (bottom,infiniteComp) where++import Test.QuickCheck++import Control.Monad (forever)+import System.IO.Unsafe+import Control.Concurrent++bottom :: Gen a+bottom = return undefined++infiniteComp :: Gen a+infiniteComp = return hang++-- Without using unsafePerformIO, is there a way to define a+-- non-terminating but non-erroring pure value that consume very little+-- resources while not terminating?++-- | Never yield an answer.  Like 'undefined' or 'error "whatever"', but+-- don't raise an error, and don't consume computational resources.+hang :: a+hang = unsafePerformIO hangIO++-- | Block forever+hangIO :: IO a+hangIO = do -- putStrLn "warning: blocking forever."+            -- Any never-terminating computation goes here+            -- This one can yield an exception "thread blocked indefinitely"+            -- newEmptyMVar >>= takeMVar+            -- sjanssen suggests this alternative:+            forever $ threadDelay maxBound+            -- forever's return type is (), though it could be fully+            -- polymorphic.  Until it's fixed, I need the following line.+            return undefined
+ src/Test/QuickCheck/Checkers.hs view
@@ -0,0 +1,448 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances+           , FlexibleContexts, TypeSynonymInstances, GeneralizedNewtypeDeriving+           , UndecidableInstances, ScopedTypeVariables+  #-}+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}++----------------------------------------------------------------------+-- |+-- Module      :  Test.QuickCheck.Checkers+-- Copyright   :  (c) Conal Elliott 2007,2008+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Some QuickCheck helpers+----------------------------------------------------------------------++module Test.QuickCheck.Checkers+  (+  -- * Misc+    Test, TestBatch, unbatch, checkBatch, quickBatch, verboseBatch+  , probablisticPureCheck+  , Unop, Binop, genR, inverseL, inverse+  , FracT, NumT, OrdT, T+  -- * Generalized equality+  , EqProp(..), eq+  , leftId, rightId, bothId, isAssoc, isCommut, commutes+  , MonoidD, monoidD, endoMonoidD, homomorphism+  , idempotent, idempotent2, idemElem+  -- , funEq, AsFun(..)+  -- * Model-based (semantics-based) testing+  , Model(..)+  , meq, meq1, meq2, meq3, meq4, meq5+  , eqModels+  , Model1(..)+  -- * Some handy testing types+  , Positive, NonZero(..), NonNegative(..)+  , suchThat, suchThatMaybe+  , arbs, gens+  , (.&.)+  , arbitrarySatisfying+  ) where++-- import Data.Function (on)+import Data.Monoid+import Data.Function (on)+import Control.Applicative+import Control.Arrow ((***),first)+import Data.List (foldl')+import System.Random+import Test.QuickCheck+import System.IO.Unsafe++import Test.QuickCheck.Utils+import Test.QuickCheck.Applicative ()+import Test.QuickCheck.Instances.Num+import Control.Monad.Extensions+++-- import qualified Data.Stream as S+++{----------------------------------------------------------+    Misc+----------------------------------------------------------}++-- | Named test+type Test = (String,Property)++-- | Named batch of tests+type TestBatch = (String,[Test])++-- | Flatten a test batch for inclusion in another+unbatch :: TestBatch -> [Test]+unbatch (batchName,props) = map (first ((batchName ++ ": ")++)) props++-- TODO: consider a tree structure so that flattening is unnecessary.++-- | Run a batch of tests.  See 'quickBatch' and 'verboseBatch'.+checkBatch :: Config -> TestBatch -> IO ()+checkBatch config (name,tests) =+  do putStrLn $ "\n" ++ name ++ ":"+     mapM_ pr tests+ where+   pr (s,p) = do putStr (padTo (width + 4) ("  "++s ++ ":"))+                 catch (check config p) print+   width    = foldl' max 0 (map (length.fst) tests)++padTo :: Int -> String -> String+padTo n = take n . (++ repeat ' ')++-- | Check a batch tersely.+quickBatch :: TestBatch -> IO ()+quickBatch = checkBatch quick'+ +-- | Check a batch verbosely.+verboseBatch :: TestBatch -> IO ()+verboseBatch = checkBatch verbose'++quick', verbose' :: Config+quick'   = defaultConfig { configMaxTest = 500 }+verbose' = quick' { configEvery = \ n args -> show n ++ ":\n" ++ unlines args }++{-++-- TODO: change TestBatch to be hierarchical/recursive, rather than+-- two-level.++data Batch n t = Test t | Batch [LBatch n t]+type LBatch n t = (n, Batch n t)++-- | Run a batch of tests.  See 'quickBatch' and 'verboseBatch'.+checkL :: Config -> LBatch -> IO ()+checkL config = checkL' 0+ where+   checkL' :: Int -> LBatch -> IO ()+   ...+-}++-- | Unary function, handy for type annotations+type Unop a = a -> a++-- | Binary function, handy for type annotations+type Binop a = a -> a -> a++-- Testing types++-- | Token 'Fractional' type for tests+type FracT = Float+-- | Token 'Num' type for tests+type NumT  = Int+-- | Token 'Ord' type for tests+type OrdT  = Char+-- | Token uninteresting type for tests+type T     = Char++genR :: Random a => (a, a) -> Gen a+genR (lo,hi) = fmap (fst . randomR (lo,hi)) rand+++-- | @f@ is a left inverse of @g@.  See also 'inverse'.+inverseL :: (EqProp b, Arbitrary b, Show b) =>+            (a -> b) -> (b -> a) -> Property+f `inverseL` g = f . g =-= id ++-- | @f@ is a left and right inverse of @g@.  See also 'inverseL'.+inverse :: ( EqProp a, Arbitrary a, Show a+           , EqProp b, Arbitrary b, Show b ) =>+           (a -> b) -> (b -> a) -> Property+f `inverse` g = f `inverseL` g .&. g `inverseL` f+++{----------------------------------------------------------+    Generalized equality+----------------------------------------------------------}++infix  4 =-=++-- | Types of values that can be tested for equality, perhaps through+-- random sampling.+class EqProp a where (=-=) :: a -> a -> Property++-- | For 'Eq' types as 'EqProp' types+eq :: Eq a => a -> a -> Property+a `eq` a' = property (a == a')++-- Template: fill in with Eq types for a+--   instance EqProp a where (=-=) = eq+-- E.g.,++instance         EqProp Bool      where (=-=) = eq+instance         EqProp Char      where (=-=) = eq+instance         EqProp Int       where (=-=) = eq+instance         EqProp Double    where (=-=) = eq++-- Lists+instance EqProp a => EqProp [a] where+    [] =-= [] = property True+    x:xs =-= y:ys = x =-= y .&. xs =-= ys+    _ =-= _ = property False++-- Maybe+instance EqProp a => EqProp (Maybe a) where+    Nothing =-= Nothing = property True+    Just x =-= Just y = x =-= y+    _ =-= _ = property False++-- Pairing+instance (EqProp a, EqProp b) => EqProp (a,b) where+  (a,b) =-= (a',b') = a =-= a' .&. b =-= b'++-- Either+instance (EqProp a, EqProp b) => EqProp (Either a b) where+  (Left x)  =-=  (Left x') = x =-= x'+  (Right x) =-= (Right x') = x =-= x'+  _         =-=          _ = property False++-- Function equality+instance (Show a, Arbitrary a, EqProp b) => EqProp (a -> b) where+  f =-= f' = property (liftA2 (=-=) f f')+-- Alternative definition:+-- instance (Show a, Arbitrary a, EqProp b) => EqProp (a -> b) where+--   f =-= f' = property (probablisticPureCheck defaultConfig+--                                              (\x -> f x =-= g x))++eqModels :: (Model a b, EqProp b) => a -> a -> Property+eqModels = (=-=) `on` model++-- Other types+-- instance EqProp a => EqProp (S.Stream a) where (=-=) = eqModels+++-- | Has a given left identity, according to '(=-=)'+leftId :: (Show a, Arbitrary a, EqProp a) => (i -> a -> a) -> i -> Property+leftId  op i = (i `op`) =-= id++-- | Has a given right identity, according to '(=-=)'+rightId :: (Show a, Arbitrary a, EqProp a) => (a -> i -> a) -> i -> Property+rightId op i = (`op` i) =-= id++-- | Has a given left and right identity, according to '(=-=)'+bothId :: (Show a, Arbitrary a, EqProp a) => (a -> a -> a) -> a -> Property+bothId = (liftA2.liftA2) (.&.) leftId rightId++-- bothId op i = leftId op i .&. rightId op i++-- | Associative, according to '(=-=)'+isAssoc :: (EqProp a, Show a, Arbitrary a) => (a -> a -> a) -> Property+isAssoc = isAssociativeBy (=-=) arbitrary++-- | Commutative, according to '(=-=)'+commutes :: EqProp z => (a -> a -> z) -> a -> a -> Property+commutes (#) a b = a # b =-= b # a++-- | Commutative, according to '(=-=)'+isCommut :: (EqProp a, Show a, Arbitrary a) => (a -> a -> a) -> Property+isCommut = isCommutableBy (=-=) arbitrary++-- | Explicit 'Monoid' dictionary.  Doesn't have to correspond to an+-- actual 'Monoid' instance, though see 'monoidD'.+data MonoidD a = MonoidD a (a -> a -> a)++-- | 'Monoid' dictionary built from the 'Monoid' methods.+monoidD :: Monoid a => MonoidD a+monoidD = MonoidD mempty mappend++-- | Monoid dictionary for an unwrapped endomorphism.  See also 'monoidD'+-- and 'Endo'.+endoMonoidD :: MonoidD (a -> a)+endoMonoidD = MonoidD id (.)++-- | Homomorphism properties with respect to given monoid dictionaries.+-- See also 'monoidMorphism'.+homomorphism :: (EqProp b, Show a, Arbitrary a) =>+                MonoidD a -> MonoidD b -> (a -> b) -> [(String,Property)]+homomorphism (MonoidD ida opa) (MonoidD idb opb) q =+  [ ("identity" , q ida =-= idb)+  , ("binop", property $ \ u v -> q (u `opa` v) =-= q u `opb` q v)+  ]++-- | The unary function @f@ is idempotent, i.e., @f . f == f@+idempotent :: (Show a, Arbitrary a, EqProp a) =>+               (a -> a) -> Property+idempotent f = idemElem (.) f++-- | A binary function @op@ is idempotent, i.e., @x `op` x == x@, for all @x@+idempotent2 :: (Show a, Arbitrary a, EqProp a) =>+               (a -> a -> a) -> Property+idempotent2 = property . idemElem++-- | A binary function @op@ is has an idempotent element @x@, i.e.,+-- @x `op` x == x@+idemElem :: EqProp a => (a -> a -> a) -> a -> Property+idemElem op x = x `op` x =-= x++{-+-- TODO: phase out AsFun, in favor of Model. withArray++-- | Types that can be modeled as functions.+class AsFun h a b | h -> a b where+  asFun :: h -> (a -> b)++instance AsFun (a->b) a b where asFun = id++-- | Equality of function-like types+funEq :: (AsFun h a b, EqProp (a -> b)) => h -> h -> Property+h `funEq` h' = asFun h =-= asFun h'+-}+++{----------------------------------------------------------+    Model-based (semantics-based) testing+----------------------------------------------------------}++---- From bytestring++class Model a b | a -> b where+  model :: a -> b  -- get the model from a concrete value++-- note: bytestring doesn't make the fundep++---- Compare representation-level and model-level operations (commuting diagrams)++meq  :: (Model a b, EqProp b) => a -> b -> Property+meq1 :: (Model a b, Model a1 b1, EqProp b) =>+	(a1 -> a) -> (b1 -> b) -> a1 -> Property+meq2 :: (Model a b, Model a1 b1, Model a2 b2, EqProp b) =>+	(a1 -> a2 -> a) -> (b1 -> b2 -> b) -> a1 -> a2 -> Property+meq3 :: (Model a b, Model a1 b1, Model a2 b2, Model a3 b3, EqProp b) =>+	(a1 -> a2 -> a3 -> a)+     -> (b1 -> b2 -> b3 -> b)+     -> a1 -> a2 -> a3 -> Property+meq4 :: ( Model a b, Model a1 b1, Model a2 b2+        , Model a3 b3, Model a4 b4, EqProp b) =>+        (a1 -> a2 -> a3 -> a4 -> a)+     -> (b1 -> b2 -> b3 -> b4 -> b)+     -> a1 -> a2 -> a3 -> a4 -> Property+meq5 :: ( Model a b, Model a1 b1, Model a2 b2, Model a3 b3+        , Model a4 b4, Model a5 b5, EqProp b) =>+	(a1 -> a2 -> a3 -> a4 -> a5 -> a)+     -> (b1 -> b2 -> b3 -> b4 -> b5 -> b)+     -> a1 -> a2 -> a3 -> a4 -> a5 -> Property++meq  a b =+     model a             =-= b+meq1 f g = \a         ->+     model (f a)         =-= g (model a)+meq2 f g = \a b       ->+     model (f a b)       =-= g (model a) (model b)+meq3 f g = \a b c     ->+     model (f a b c)     =-= g (model a) (model b) (model c)+meq4 f g = \a b c d   ->+     model (f a b c d)   =-= g (model a) (model b) (model c) (model d)+meq5 f g = \a b c d e ->+     model (f a b c d e) =-= g (model a) (model b) (model c) (model d) (model e)+++---- Some model instances++instance Model Bool   Bool   where model = id+instance Model Char   Char   where model = id+instance Model Int    Int    where model = id+instance Model Float  Float  where model = id+instance Model Double Double where model = id+instance Model String String where model = id++-- This next one requires UndecidableInstances+instance (Model a b, Model a' b') => Model (a,a') (b,b') where+  model = model *** model++-- instance Model (S.Stream a) (NonNegative Int -> a) where+--   model s (NonNegative i) = s S.!! i+++-- | Like 'Model' but for unary type constructors.+class Model1 f g | f -> g where+  model1 :: forall a. f a -> g a+++{----------------------------------------------------------+    Some handy testing types+----------------------------------------------------------}++-- from QC2, plus tweaks++type Positive a = NonZero (NonNegative a)++newtype NonZero a = NonZero { unNonZero :: a }+ deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )++instance (Num a, Arbitrary a) => Arbitrary (NonZero a) where+  arbitrary   = fmap NonZero $ arbitrary `suchThat` (/= 0)+  coarbitrary = coarbitrary . unNonZero++newtype NonNegative a = NonNegative { unNonNegative :: a }+ deriving ( Eq, Ord, Num, Integral, Real, Enum, Show, Read )++instance (Num a, Arbitrary a) => Arbitrary (NonNegative a) where+  arbitrary   = nonNegative+  coarbitrary = coarbitrary . unNonNegative++arbitrarySatisfying :: Arbitrary a => (a -> Bool) -> Gen a+arbitrarySatisfying = (arbitrary `suchThat`)++-- | Generates a value that satisfies a predicate.+suchThat :: Gen a -> (a -> Bool) -> Gen a+gen `suchThat` p = satisfiesM p gen++-- | Tries to generate a value that satisfies a predicate.+suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a)+gen `suchThatMaybe` p = sized (try 0 . max 1)+ where+  try _ 0 = return Nothing+  try k n = do x <- resize (2*k+n) gen+               if p x then return (Just x) else try (k+1) (n-1)++-- | Generate n arbitrary values+arbs :: Arbitrary a => Int -> IO [a]+arbs n = fmap (\ rnd -> generate n rnd (vector n)) newStdGen++-- | Produce n values from a generator+gens :: Int -> Gen a -> IO [a]+gens n gen =+  fmap (\ rnd -> generate 1000 rnd (sequence (replicate n gen))) newStdGen++-- The next two are from twanvl:++infixr 3 .&.+-- | Property conjunction+(.&.) :: (Testable prop1, Testable prop2) => prop1 -> prop2 -> Property+p1 .&. p2 = property $ \b -> if b then property p1 else property p2++instance Testable a => Testable [a] where+  property []    = property True+  property props = property $ \n -> props !! (n `mod` len)+    where len = length props++instance (Testable a, Testable b) => Testable (a,b) where+  property = uncurry (.&.)++probablisticPureCheck :: Testable a => Config -> a -> Bool+probablisticPureCheck config a = unsafePerformIO $+  do rnd <- newStdGen+     probablisticPureTests config (evaluate a) rnd 0 0 []++probablisticPureTests :: Config+                      -> Gen Result+                      -> StdGen+                      -> Int+                      -> Int+                      -> [[String]]+                      -> IO Bool+probablisticPureTests config gen rnd0 ntest nfail stamps+  | ntest == configMaxTest config = return True+  | nfail == configMaxFail config = return True+  | otherwise                     =+      case ok result of+        Nothing    ->+          probablisticPureTests config gen rnd1 ntest (nfail+1) stamps+        Just True  ->+          probablisticPureTests config gen rnd1 (ntest+1) nfail+                                (stamp result:stamps)+        Just False ->+          return False+     where+      result      = generate (configSize config ntest) rnd2 gen+      (rnd1,rnd2) = split rnd0
+ src/Test/QuickCheck/Classes.hs view
@@ -0,0 +1,460 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, KindSignatures+           , Rank2Types, TypeOperators+  #-}++{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module      :  Test.QuickCheck.Classes+-- Copyright   :  (c) Conal Elliott 2008+-- License     :  BSD3+-- +-- Maintainer  :  conal@conal.net+-- Stability   :  experimental+-- +-- Some QuickCheck properties for standard type classes+----------------------------------------------------------------------++module Test.QuickCheck.Classes+  (+    monoid, monoidMorphism, semanticMonoid+  , functor, functorMorphism, semanticFunctor, functorMonoid+  , applicative, applicativeMorphism, semanticApplicative+  , monad, monadMorphism, semanticMonad, monadFunctor+  , monadApplicative, arrow, arrowChoice, traversable+  , monadPlus, monadOr+  )+  where++import Data.Monoid+import Data.Foldable (foldMap)+import Data.Traversable (Traversable (..), fmapDefault, foldMapDefault)+import Control.Applicative+import Control.Monad (MonadPlus (..), ap, join)+import Control.Arrow (Arrow,ArrowChoice,first,second,left,right,(>>>),arr)+import Test.QuickCheck+import Text.Show.Functions ()++import Test.QuickCheck.Checkers+import Test.QuickCheck.Instances.Char ()+++-- | Properties to check that the 'Monoid' 'a' satisfies the monoid+-- properties.  The argument value is ignored and is present only for its+-- type.+monoid :: forall a. (Monoid a, Show a, Arbitrary a, EqProp a) =>+          a -> TestBatch+monoid = const ( "monoid"+               , [ ("left  identity", leftId  mappend (mempty :: a))+                 , ("right identity", rightId mappend (mempty :: a))+                 , ("associativity" , isAssoc (mappend :: Binop a))+                 ]+               )++-- | Monoid homomorphism properties.  See also 'homomorphism'.+monoidMorphism :: (Monoid a, Monoid b, EqProp b, Show a, Arbitrary a) =>+                  (a -> b) -> TestBatch+monoidMorphism q = ("monoid morphism", homomorphism monoidD monoidD q)++semanticMonoid :: forall a b.+  ( Model a b+  , Monoid a+  , Monoid b+  , Show a+  , Arbitrary a+  , EqProp b+  ) =>+  a -> TestBatch+semanticMonoid = const (first ("semantic " ++)+                              (monoidMorphism (model:: a -> b)))++functorMonoid :: forall m a b.+  ( Functor m+  , Monoid (m a)+  , Monoid (m b)+  , Arbitrary (a->b)+  , Arbitrary (m a)+  , Show (m a)+  , EqProp (m b)) =>+  m (a,b) -> TestBatch+functorMonoid = const ("functor-monoid"+                      , [ ( "identity",property identityP )+                        , ( "binop", property binopP )+                        ]+                      )+  where+    identityP :: (a->b) -> Property+    identityP f = (fmap f) (mempty :: m a) =-= (mempty :: m b)+    binopP :: (a->b) -> (m a) -> (m a) -> Property+    binopP f u v = (fmap f) (u `mappend` v) =-= (fmap f u) `mappend` (fmap f v)++-- <camio> There I have an attempt at doing this. I eventually implemented +-- those semanticMorphisms as their own functions. I'm not too thrilled with+-- that implementation, but it works.++-- TODO: figure out out to eliminate the redundancy.++-- | Properties to check that the 'Functor' @m@ satisfies the functor+-- properties.+functor :: forall m a b c.+           ( Functor m+           , Arbitrary a, Arbitrary b, Arbitrary c+           , Show (m a), Arbitrary (m a), EqProp (m a), EqProp (m c)) =>+           m (a,b,c) -> TestBatch+functor = const ( "functor"+                , [ ("identity", property identityP)+                  , ("compose" , property composeP) ]+                )+ where+   identityP :: Property+   composeP  :: (b -> c) -> (a -> b) -> Property+   +   identityP = fmap id =-= (id :: m a -> m a)+   composeP g f = fmap g . fmap f =-= (fmap (g.f) :: m a -> m c)++-- Note the similarity between 'functor' and 'monoidMorphism'.  The+-- functor laws say that 'fmap' is a homomorphism w.r.t '(.)':+-- +--   functor = const ("functor", homomorphism endoMonoidD endoMonoidD fmap)+-- +-- However, I don't think the types can work out, since 'fmap' is used at+-- three different types.+++-- | 'Functor' morphism (natural transformation) properties+functorMorphism :: forall f g.+                   ( Functor f, Functor g+                   , Arbitrary (f NumT), Show (f NumT)+                   , EqProp (g T)+                   ) =>+                  (forall a. f a -> g a) -> TestBatch+functorMorphism q = ("functor morphism", [("fmap", property fmapP)])+ where+   -- fmapP :: (NumT -> T) -> f NumT -> Property+   -- fmapP h l = q (fmap h l) =-= fmap h (q l)+   fmapP :: (NumT -> T) -> Property+   fmapP h = q . fmap h =-= fmap h . q++-- Note: monomorphism prevent us from saying @commutes (.) q (fmap h)@,+-- since @fmap h@ is used at two different types.++semanticFunctor :: forall f g.+  ( Model1 f g+  , Functor f+  , Functor g+  , Arbitrary (f NumT)+  , Show (f NumT)+  , EqProp (g T)+  ) =>+  f () -> TestBatch+semanticFunctor = const (functorMorphism (model1 :: forall b. f b -> g b))+++-- | Properties to check that the 'Applicative' @m@ satisfies the monad+-- properties+applicative :: forall m a b c.+               ( Applicative m+               , Arbitrary a, Arbitrary b, Arbitrary (m a)+               , Arbitrary (m (b -> c)), Show (m (b -> c))+               , Arbitrary (m (a -> b)), Show (m (a -> b))+               , Show a, Show (m a)+               , EqProp (m a), EqProp (m b), EqProp (m c)+               ) =>+               m (a,b,c) -> TestBatch+applicative = const ( "applicative"+                    , [ ("identity"    , property identityP)+                      , ("composition" , property compositionP)+                      , ("homomorphism", property homomorphismP)+                      , ("interchange" , property interchangeP)+                      , ("functor"     , property functorP)+                      ]+                    )+ where+   identityP     :: m a -> Property+   compositionP  :: m (b -> c) -> m (a -> b) -> m a -> Property+   homomorphismP :: (a -> b) -> a -> Property+   interchangeP  :: m (a -> b) -> a -> Property+   functorP      :: (a -> b) -> m a -> Property+   +   identityP v        = (pure id <*> v) =-= v+   compositionP u v w = (pure (.) <*> u <*> v <*> w) =-= (u <*> (v <*> w))+   homomorphismP f x  = (pure f <*> pure x) =-= (pure (f x) :: m b)+   interchangeP u y   = (u <*> pure y) =-= (pure ($ y) <*> u)+   functorP f x       = (fmap f x) =-= (pure f <*> x)+++-- | 'Applicative' morphism properties+applicativeMorphism :: forall f g.+                       ( Applicative f, Applicative g+                       , Show (f NumT), Arbitrary (f NumT)+                       , EqProp (g NumT), EqProp (g T)+                       , Show (f (NumT -> T))+                       , Arbitrary (f (NumT -> T))+                       ) =>+                       (forall a. f a -> g a) -> TestBatch+applicativeMorphism q =+  ( "applicative morphism"+  , [("pure", property pureP), ("apply", property applyP)] )+ where+   pureP  :: NumT -> Property+   applyP :: f (NumT->T) -> f NumT -> Property+   +   pureP a = q (pure a) =-= pure a+   applyP mf mx = q (mf <*> mx) =-= (q mf <*> q mx)+++semanticApplicative :: forall f g.+  ( Model1 f g+  , Applicative f, Applicative g+  , Arbitrary (f NumT), Arbitrary (f (NumT -> T))+  , EqProp (g NumT), EqProp (g T)+  , Show (f NumT), Show (f (NumT -> T))+  ) =>+  f () -> TestBatch+semanticApplicative =+  const (applicativeMorphism (model1 :: forall b. f b -> g b))+++-- | Properties to check that the 'Monad' @m@ satisfies the monad properties+monad :: forall m a b c.+         ( Monad m+         , Show a, Arbitrary a, Arbitrary b+         , Arbitrary (m a), EqProp (m a), Show (m a)+         , Arbitrary (m b), EqProp (m b)+         , Arbitrary (m c), EqProp (m c)+         ) =>+         m (a,b,c) -> TestBatch+monad = const ( "monad laws"+              , [ ("left  identity", property leftP)+                , ("right identity", property rightP)+                , ("associativity" , property assocP)+                ]+              )+ where+   leftP  :: (a -> m b) -> a -> Property+   rightP :: m a -> Property+   assocP :: m a -> (a -> m b) -> (b -> m c) -> Property+   +   leftP f a    = (return a >>= f)  =-= f a+   rightP m     = (m >>= return)    =-=  m+   assocP m f g = ((m >>= f) >>= g) =-= (m >>= (\x -> f x >>= g))++-- | Law for monads that are also instances of 'Functor'.+monadFunctor :: forall m a b.+                ( Functor m, Monad m+                , Arbitrary a, Arbitrary b+                , Arbitrary (m a), Show (m a), EqProp (m b)) =>+                m (a, b) -> TestBatch+monadFunctor = const ( "monad functor"+                     , [("bind return", property bindReturnP)])+ where+   bindReturnP :: (a -> b) -> m a -> Property+   bindReturnP f xs = fmap f xs =-= (xs >>= return . f)++monadApplicative :: forall m a b.+                    ( Applicative m, Monad m+                    , EqProp (m a), EqProp (m b)+                    , Show a, Arbitrary a+                    , Show (m a), Arbitrary (m a)+                    , Show (m (a -> b)), Arbitrary (m (a -> b))) =>+                    m (a, b) -> TestBatch+monadApplicative = const ( "monad applicative"+                         , [ ("pure", property pureP)+                           , ("ap", property apP)+                           ]+                         )+ where+   pureP :: a -> Property+   apP :: m (a -> b) -> m a -> Property++   pureP x = (pure x :: m a) =-= return x+   apP f x = (f <*> x) =-= (f `ap` x)++-- | 'Monad' morphism properties++-- | 'Applicative' morphism properties+monadMorphism :: forall f g.+                 ( Monad f, Monad g, Functor g+                 , Show (f NumT)+                 , Show (f (NumT -> T))+                 , Show (f (f (NumT -> T)))+                 , Arbitrary (f NumT), Arbitrary (f T)+                 , Arbitrary (f (NumT -> T))+                 , Arbitrary (f (f (NumT -> T)))+                 , EqProp (g NumT), EqProp (g T)+                 , EqProp (g (NumT -> T))+                 ) =>+                (forall a. f a -> g a) -> TestBatch+monadMorphism q =+  ( "monad morphism"+  , [ ("return", property returnP), ("bind", property bindP), ("join", property joinP) ] )+ where+   returnP :: NumT -> Property+   bindP :: f NumT -> (NumT -> f T) -> Property+   joinP :: f (f (NumT->T)) -> Property+   +   returnP a = q (return a) =-= return a+   bindP u k = q (u >>= k)  =-= (q u >>= q . k)+   joinP uu  = q (join uu)  =-= join (fmap q (q uu))++-- The join and bind properties are redundant.  Pick one.++--      q (join uu)+--   == q (uu >>= id)+--   == q uu >>= q . id+--   == q uu >>= q+--   == join (fmap q (q uu))++--      q (u >>= k)+--   == q (fmap k (join u))+--   == fmap k (q (join u))  -- if also a functor morphism+--   == fmap k (join (fmap q (q uu)))+--   == fmap k (q u >>= q)+--   == ???++-- I'm stuck at the end here.  What's missing?++semanticMonad :: forall f g.+  ( Model1 f g+  , Monad f, Monad g+  , EqProp (g T) , EqProp (g NumT)+  , EqProp (g (NumT -> T))+  , Arbitrary (f T) , Arbitrary (f NumT)+  , Arbitrary (f (f (NumT -> T)))+  , Arbitrary (f (NumT -> T))+  , Show (f (f (NumT -> T)))+  , Show (f (NumT -> T)) , Show (f NumT)+  , Functor g+  ) =>+  f () -> TestBatch+semanticMonad = const (monadMorphism (model1 :: forall b. f b -> g b))++-- | Laws for MonadPlus instances with left distribution.+monadPlus :: forall m a b.+             ( MonadPlus m, Show (m a)+             , Arbitrary a, Arbitrary (m a), Arbitrary (m b)+             , EqProp (m a), EqProp (m b)) =>+             m (a, b) -> TestBatch+monadPlus = const ( "MonadPlus laws"+                  , [ ("left zero", property leftZeroP)+                    , ("left identity", leftId mplus (mzero :: m a))+                    , ("right identity", rightId mplus (mzero :: m a))+                    , ("associativity" , isAssoc (mplus :: Binop (m a)))+                    , ("left distribution", property leftDistP)+                    ]+                  )+ where+   leftZeroP :: (a -> m b) -> Property+   leftDistP :: m a -> m a -> (a -> m b) -> Property++   leftZeroP k = (mzero >>= k) =-= mzero+   leftDistP a b k = (a `mplus` b >>= k) =-= ((a >>= k) `mplus` (b >>= k))++-- | Laws for MonadPlus instances with left catch.+monadOr :: forall m a b.+           ( MonadPlus m, Show a, Show (m a)+           , Arbitrary a, Arbitrary (m a), Arbitrary (m b)+           , EqProp (m a), EqProp (m b)) =>+           m (a, b) -> TestBatch+monadOr = const ( "MonadOr laws"+                , [ ("left zero", property leftZeroP)+                  , ("left identity", leftId mplus (mzero :: m a))+                  , ("right identity", rightId mplus (mzero :: m a))+                  , ("associativity" , isAssoc (mplus :: Binop (m a)))+                  , ("left catch", property leftCatchP)+                  ]+                )+ where+   leftZeroP :: (a -> m b) -> Property+   leftCatchP :: a -> m a -> Property++   leftZeroP k = (mzero >>= k) =-= mzero+   leftCatchP a b = return a `mplus` b =-= return a+++arrow :: forall (~>) b c d e.+         ( Arrow (~>)+         , Show (d ~> e), Show (c ~> d), Show (b ~> c)+         , Show b, Show c, Show d, Show e+         , Arbitrary (d ~> e), Arbitrary (c ~> d), Arbitrary (b ~> c)+         , Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e+         , EqProp (b ~> e), EqProp (b ~> d)+         , EqProp ((b,d) ~> c)+         , EqProp ((b,d) ~> (c,d)), EqProp ((b,e) ~> (d,e))+         , EqProp ((b,d) ~> (c,e))+         , EqProp b, EqProp c, EqProp d, EqProp e+         ) =>+         b ~> (c,d,e) -> TestBatch+arrow = const ("arrow laws"+              , [ ("associativity"           , property assocP)+                , ("arr distributes"         , property arrDistributesP)+-- TODO: how to define h is onto or one-to-one?+--                , ("extensionality principle"     , property extensionalityP)+--                , ("extensionality dual"          , property extensionalityDualP)+                 , ("first works as funs"    , property firstAsFunP)+                 , ("first keeps composition", property firstKeepCompP)+                 , ("first works as fst"     , property firstIsFstP)+                 , ("second can move"        , property secondMovesP)+                 ]+              )+  where+    assocP :: b ~> c -> c ~> d -> d ~> e -> Property+    assocP f g h = ((f >>> g) >>> h) =-= (f >>> (g >>> h))+    +    arrDistributesP :: (b -> c) -> (c -> d) -> Property+    arrDistributesP f g = ((arr (f >>> g)) :: b ~> d) =-= (arr f >>> arr g)+    +    firstAsFunP :: (b -> c) -> Property+    firstAsFunP f = (first (arr f) :: (b,d) ~> (c,d)) =-= arr (first f)++    firstKeepCompP :: b ~> c -> c ~> d -> Property+    firstKeepCompP f g =+      ((first (f >>> g)) :: ((b,e) ~> (d,e))) =-= (first f >>> first g)+ +    firstIsFstP :: b ~> c -> Property+    firstIsFstP f = ((first f :: (b,d) ~> (c,d)) >>> arr fst)+                      =-= (arr fst >>> f)+    +    secondMovesP :: (b ~> c) -> (d -> e) -> Property+    secondMovesP f g = (first f >>> second (arr g))+                         =-= ((second (arr g)) >>> first f)++arrowChoice :: forall (~>) b c d e.+               ( ArrowChoice (~>)+               , Show (b ~> c)+               , Arbitrary (b ~> c)+               , Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e+               , EqProp ((Either b d) ~> (Either c e))+               , EqProp ((Either b d) ~> (Either c d))+               ) =>+               b ~> (c,d,e) -> TestBatch+arrowChoice = const ("arrow choice laws"+                    , [ ("left works as funs"     , property leftAsFunP)+                      , ("right can move"         , property rightMovesP)+                      ]+                    )+  where+    leftAsFunP :: (b -> c) -> Property+    leftAsFunP f = (left (arr f) :: (Either b d) ~> (Either c d))+                     =-= arr (left f)++    rightMovesP :: (b ~> c) -> (d -> e) -> Property+    rightMovesP f g = (left f >>> right (arr g))+                        =-= ((right (arr g)) >>> left f)++traversable :: forall f a b m.+               ( Traversable f, Monoid m, Show (f a)+               , Arbitrary (f a), Arbitrary b, Arbitrary a, Arbitrary m+               , EqProp (f b), EqProp m) =>+               f (a, b, m) -> TestBatch+traversable = const ( "traversable"+                    , [ ("fmap", property fmapP)+                      , ("foldMap", property foldMapP)+                      ]+                    )+ where+   fmapP :: (a -> b) -> f a -> Property+   foldMapP :: (a -> m) -> f a -> Property++   fmapP f x = f `fmap` x =-= f `fmapDefault` x+   foldMapP f x = f `foldMap` x =-= f `foldMapDefault` x
+ src/Test/QuickCheck/Instances.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}+module Test.QuickCheck.Instances+       (module Test.QuickCheck.Instances.Char+       ,module Test.QuickCheck.Instances.Eq+       ,module Test.QuickCheck.Instances.List+       ,module Test.QuickCheck.Instances.Num+       ,module Test.QuickCheck.Instances.Ord+       ,module Test.QuickCheck.Instances.Tuple+       ) where+       +import Test.QuickCheck.Instances.Array ()+import Test.QuickCheck.Instances.Char +import Test.QuickCheck.Instances.Eq+import Test.QuickCheck.Instances.Int   ()+import Test.QuickCheck.Instances.List+import Test.QuickCheck.Instances.Maybe ()+import Test.QuickCheck.Instances.Num+import Test.QuickCheck.Instances.Ord+import Test.QuickCheck.Instances.Tuple+import Test.QuickCheck.Instances.Word  ()
+ src/Test/QuickCheck/Instances/Array.hs view
@@ -0,0 +1,10 @@+module Test.QuickCheck.Instances.Array where++import Test.QuickCheck+import Control.Applicative+import Data.Array++instance (Ix a, Integral a, Arbitrary b) => Arbitrary (Array a b) where+  arbitrary   =+    (\x -> listArray (0,fromIntegral (length x - 1)) x) <$> arbitrary +  coarbitrary = coarbitrary . elems
+ src/Test/QuickCheck/Instances/Char.hs view
@@ -0,0 +1,75 @@+module Test.QuickCheck.Instances.Char+       (nonSpace,whitespace,space,newline+       ,lowerAlpha,upperAlpha,numeric+       ,parenthesis,bracket,brace+       ,operator+       ) where++import Data.Char+import Test.QuickCheck+import Test.QuickCheck.Instances.Eq++instance Arbitrary Char where+    arbitrary   = choose ('\0','\255')+    coarbitrary = variant . ord++-- Bob: why the `rem` 4 ?++{- | Generates a 'non space' character, i.e. any ascii except+     ' ', '\t', '\n' and '\r'.+-}+nonSpace :: Gen Char+nonSpace = notOneof " \t\n\r"++{- | Generates any whitespace character, including new lines.+-}+whitespace :: Gen Char+whitespace = oneof [space,newline]++{- | Generates a whitespace charecter, not a newline.+-}+space :: Gen Char+space = oneof (map return " \t")++{- | Generates either a '\n' or '\r'.+-}+newline :: Gen Char+newline = oneof (map return "\n\r")++letters :: String+letters = "abcdefghijklmnopqrstuvwxyz"++{- | Generates any lower case alpha character.+-}+lowerAlpha :: Gen Char+lowerAlpha = oneof (map return letters)++{- | Generates any upper case alpha character.+-}+upperAlpha :: Gen Char+upperAlpha = oneof (map (return . toUpper) letters)++{- | Generates a digit character.+-}+numeric :: Gen Char+numeric = oneof (map return "1234567890")++{- | Generates one or other of '(' and ')'.+-}+parenthesis :: Gen Char+parenthesis = oneof (map return "()")++{- | Generates one or other of '[' and ']'.+-}+bracket :: Gen Char+bracket = oneof (map return "[]")++{- | Generates one or other of '{' and '}'.+-}+brace :: Gen Char+brace = oneof (map return "{}")++{- | Generates one of '*', '/', '-', '+', '<', '>', '|' and '#'.+-}+operator :: Gen Char+operator = oneof (map return "*/-+<>|#")
+ src/Test/QuickCheck/Instances/Eq.hs view
@@ -0,0 +1,12 @@+module Test.QuickCheck.Instances.Eq (notEqualTo, notOneof) where++import Test.QuickCheck+import Test.QuickCheck.Checkers+import Control.Monad.Extensions++notEqualTo :: (Eq a,Arbitrary a) => a -> Gen a -> Gen a+notEqualTo v = satisfiesM (/= v)++notOneof :: (Eq a,Arbitrary a) => [a] -> Gen a+notOneof es = arbitrarySatisfying (not . (`elem` es))+
+ src/Test/QuickCheck/Instances/Int.hs view
@@ -0,0 +1,21 @@+module Test.QuickCheck.Instances.Int where++import Control.Applicative+import Test.QuickCheck+import Data.Int++instance Arbitrary Int64 where+  arbitrary   = fromInteger <$> arbitrary+  coarbitrary = variant . fromIntegral++instance Arbitrary Int32 where+  arbitrary   = fromInteger <$> arbitrary+  coarbitrary = variant . fromIntegral++instance Arbitrary Int16 where+  arbitrary   = fromInteger <$> arbitrary+  coarbitrary = variant . fromIntegral++instance Arbitrary Int8 where+  arbitrary   = fromInteger <$> arbitrary+  coarbitrary = variant . fromIntegral
+ src/Test/QuickCheck/Instances/List.hs view
@@ -0,0 +1,72 @@+module Test.QuickCheck.Instances.List+       (anyList,nonEmpty+       ,infiniteList+       ,increasing,nondecreasing+       ,increasingInf,nondecreasingInf+       ,decreasing,nonincreasing+       ,decreasingInf,nonincreasingInf+       ) where++import Test.QuickCheck+import Test.QuickCheck.Applicative ()+import Test.QuickCheck.Instances.Num+import Control.Applicative++{- | Generates a non-empty list with the contents generated using its+     argument.+-}+nonEmpty :: Gen a -> Gen [a]+nonEmpty x = liftA2 (:) x (anyList x)++{- | Generates any list (possibly empty) with the contents generated using+     its argument.+-}+anyList :: Gen a -> Gen [a]+anyList x = frequency [(1, pure []), (4, nonEmpty x)]++{- | Generates an infinite list with contents generated using its argument+-}+infiniteList :: Gen a -> Gen [a]+infiniteList x = liftA2 (:) x (infiniteList x)++sumA :: (Applicative f, Num a) => f a -> f [a] -> f [a]+sumA = liftA2 (scanl (+))++monotonic_ :: (Arbitrary a, Num a) => (Gen a -> Gen [a]) -> Gen a -> Gen [a]+monotonic_ listGen gen = sumA arbitrary (listGen gen)++-- TODO: Generalise this to Ord a.+monotonic :: (Arbitrary a, Num a) => Gen a -> Gen [a]+monotonic gen = monotonic_ anyList gen++-- | Generate increasing towards infinity+increasing :: (Arbitrary a, Num a) => Gen [a]+increasing = monotonic positive++-- | Generate an infinite list of increasing values+increasingInf :: (Arbitrary a, Num a) => Gen [a]+increasingInf = monotonic_ infiniteList positive++-- | Generate nondecreasing values+nondecreasing :: (Arbitrary a, Num a) => Gen [a]+nondecreasing = monotonic nonNegative++-- | Generate an infinite list of nondecreasing values+nondecreasingInf :: (Arbitrary a, Num a) => Gen [a]+nondecreasingInf = monotonic_ infiniteList nonNegative++-- | Generate increasing towards infinity+decreasing :: (Arbitrary a, Num a) => Gen [a]+decreasing = monotonic negative++-- | Generate an infinite list of increasing values+decreasingInf :: (Arbitrary a, Num a) => Gen [a]+decreasingInf = monotonic_ infiniteList negative++-- | Generate nondecreasing values+nonincreasing :: (Arbitrary a, Num a) => Gen [a]+nonincreasing = monotonic nonPositive++-- | Generate an infinite list of nondecreasing values+nonincreasingInf :: (Arbitrary a, Num a) => Gen [a]+nonincreasingInf = monotonic_ infiniteList nonPositive
+ src/Test/QuickCheck/Instances/Maybe.hs view
@@ -0,0 +1,9 @@+module Test.QuickCheck.Instances.Maybe where++import Test.QuickCheck+import Test.QuickCheck.Applicative ()+import Control.Applicative++maybeGen :: Gen a -> Gen (Maybe a)+maybeGen x = oneof [pure Nothing+                   ,Just <$> x]
+ src/Test/QuickCheck/Instances/Num.hs view
@@ -0,0 +1,28 @@+module Test.QuickCheck.Instances.Num +       (nonNegative,nonPositive+       ,negative,positive+       ,nonZero,nonZero_+       ) where++import Test.QuickCheck+import Control.Monad.Extensions+import Control.Applicative++nonNegative :: (Num a, Arbitrary a) => Gen a+nonNegative = abs <$> arbitrary++positive :: (Num a, Arbitrary a) => Gen a+positive = nonZero nonNegative++nonPositive :: (Num a, Arbitrary a) => Gen a+nonPositive = negate <$> nonNegative++negative :: (Num a, Arbitrary a) => Gen a+negative = negate <$> positive++nonZero :: (Num a, Arbitrary a) => Gen a -> Gen a+nonZero g =+  sized (\s -> satisfiesM (/= 0) (if (s == 0) then (resize 1 g) else g))++nonZero_ :: (Num a, Arbitrary a) => Gen a+nonZero_ = nonZero arbitrary
+ src/Test/QuickCheck/Instances/Ord.hs view
@@ -0,0 +1,10 @@+module Test.QuickCheck.Instances.Ord where++import Test.QuickCheck+import Control.Monad.Extensions++greaterThan :: (Ord a,Arbitrary a) => a -> Gen a -> Gen a+greaterThan v = satisfiesM (> v)++lessThan :: (Ord a,Arbitrary a) => a -> Gen a -> Gen a+lessThan v = satisfiesM (< v)
+ src/Test/QuickCheck/Instances/Tuple.hs view
@@ -0,0 +1,25 @@+module Test.QuickCheck.Instances.Tuple where++import Test.QuickCheck+import Control.Monad++{- | Generates a 2-tuple using its arguments to generate the parts.+-}+(>*<) :: Gen a -> Gen b -> Gen (a,b)+x >*< y = liftM2 (,) x y++{- | Generates a 3-tuple using its arguments to generate the parts.+-}+(>**<) :: Gen a -> Gen b -> Gen c -> Gen (a,b,c)+(>**<) x y z = liftM3 (,,) x y z++{- | Generates a 4-tuple using its arguments to generate the parts.+-}+(>***<) :: Gen a -> Gen b -> Gen c -> Gen d -> Gen (a,b,c,d)+(>***<) x y z a = liftM4 (,,,) x y z a++{- | Generates a 5-tuple using its arguments to generate the parts.+-}+(>****<) :: Gen a -> Gen b -> Gen c -> Gen d -> Gen e -> Gen (a,b,c,d,e)+(>****<) x y z a b= liftM5 (,,,,) x y z a b+
+ src/Test/QuickCheck/Instances/Word.hs view
@@ -0,0 +1,21 @@+module Test.QuickCheck.Instances.Word where++import Control.Applicative+import Test.QuickCheck+import Data.Word++instance Arbitrary Word64 where+  arbitrary   = fromInteger <$> arbitrary+  coarbitrary = variant . fromIntegral++instance Arbitrary Word32 where+  arbitrary   = fromInteger <$> arbitrary+  coarbitrary = variant . fromIntegral++instance Arbitrary Word16 where+  arbitrary   = fromInteger <$> arbitrary+  coarbitrary = variant . fromIntegral++instance Arbitrary Word8 where+  arbitrary   = fromInteger <$> arbitrary+  coarbitrary = variant . fromIntegral
+ src/Test/QuickCheck/Later.hs view
@@ -0,0 +1,82 @@+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module      :  Data.Later+-- Copyright   :  (c) David Sankel 2008+-- License     :  BSD3+-- +-- Maintainer  :  david@sankelsoftware.com+-- Stability   :  experimental+-- +-- Later. Allows for testing of functions that depend on the order of+-- evaluation.+--+-- TODO: move this functionality to the testing package for Unamb.+----------------------------------------------------------------------++module Test.QuickCheck.Later+  ( isAssocTimes+  , isCommutTimes+  , delay+  , delayForever+  ) where++import Test.QuickCheck.Checkers+import Test.QuickCheck++import System.Random (Random)++import System.IO.Unsafe+import Control.Concurrent+import Control.Monad (forever)++-- Generate a random delay up to given max seconds for a property.+delayP :: (Num t, System.Random.Random t, Testable b) => t -> (t -> b) -> Property+delayP d = forAll (genR (0,d))++-- | Is the given function commutative when restricted to the same value+-- but possibly different times?+isCommutTimes :: (EqProp b, Arbitrary a, Show a) => Double -> (a -> a -> b) -> Property++isCommutTimes d (#) =+  delayP d $ \ t1 ->+  delayP d $ \ t2 ->+  \ v -> let del = flip delay v in+           del t1 # del t2 =-= del t2 # del t1++-- Note that we delay v by t1 and by t2 twice.+-- +-- TODO: make sure CSE isn't kicking in.  Examine the core code.++-- | Is the given function associative when restricted to the same value+-- but possibly different times?+isAssocTimes :: (EqProp a, Arbitrary a, Show a) => Double -> (a -> a -> a) -> Property++isAssocTimes d (#) =+  delayP d $ \ t1 ->+  delayP d $ \ t2 ->+  delayP d $ \ t3 ->+  \ v -> let del = flip delay v in+           (del t1 # del t2) # del t3 =-= del t1 # (del t2 # del t3)+++-- The value eventually returned by an action.  Probably handy elsewhere.+-- TODO: what are the necessary preconditions in order to make this+-- function referentially transparent?+eventually :: IO a -> a+eventually = unsafePerformIO . unsafeInterleaveIO++-- Why unsafeInterleaveIO?  Because ...++-- | Delay a value's availability by the given duration in seconds.+-- Note that the delay happens only on the first evaluation.+delay :: RealFrac t => t -> a -> a+delay d a = eventually $ threadDelay (round (1.0e6 * d)) >> return a++-- | A value that is never available.  Rerun of @hang@ from unamb, but+-- replicated to avoid mutual dependency.+-- +-- TODO: Remove when this module is moved into the unamb-test package.+delayForever :: a+delayForever = unsafePerformIO $ do forever (threadDelay maxBound)+                                    return undefined
+ wikipage.tw view
@@ -0,0 +1,13 @@+[[Category:Packages]]++== Abstract ==++'''checkers''' is a library for reusable QuickCheck properties, particularly for standard type classes (class laws and [http://conal.net/papers/simply-reactive class morphisms]).  For instance, most of [[Reactive]] can be specified and tested using just these properties.  Checkers also lots of support for randomly generating data values (thanks to Thomas Davie).++Besides this wiki page, here are more ways to find out about checkers:+* Read [http://code.haskell.org/checkers/doc/html/ the library documentation].+* Get the code repository: '''<tt>darcs get http://code.haskell.org/checkers</tt>'''.+* Install from [http://hackage.haskell.org/cgi-bin/hackage-scripts/package/checkers Hackage].+* See the [[checkers/Versions| version history]].++Please leave comments at the [[Talk:checkers|Talk page]].