Debug/QuickCheck/Poly.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Debug.QuickCheck.Poly
   4 -- Copyright   :  (c) Andy Gill 2001
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  experimental
   9 -- Portability :  non-portable (uses Control.Exception, Control.Concurrent)
  10 --
  11 -- This is an attempt to emulate polymorphic types for the
  12 -- purposes of testing by using abstract monomorphic types.
  13 --
  14 -- It is likely that future versions of QuickCheck will
  15 -- include some polymorphic emulation testing facility,
  16 -- but this module can be used for now.
  17 --
  18 -----------------------------------------------------------------------------
  19
  20 module Debug.QuickCheck.Poly
  21   ( ALPHA
  22   , BETA
  23   , GAMMA
  24   , OrdALPHA
  25   , OrdBETA
  26   , OrdGAMMA
  27   ) where
  28
  29 import Prelude
  30
  31 import Debug.QuickCheck
  32 import Debug.QuickCheck.Utils
  33
  34 {- This is the basic pseudo-polymorphic object.
  35  - The idea is you can't cheat, and use the integer
  36  - directly, but need to use the abstraction.
  37  -
  38  - We use phantom types (ref: Domain Specific Embedded Compilers,
  39  - Daan Leijen & Erik Meijer, 2nd Conference of Domain Specific
  40  - Languages, Austin, TX, 1999)
  41  -}
  42
  43 newtype Poly a = Poly Int
  44
  45 instance Show (Poly a) where
  46         show (Poly a) = "_" ++ show a
  47
  48 instance Arbitrary (Poly a) where
  49     arbitrary            = sized $ \n -> (choose (1,n) >>= return . Poly)
  50     coarbitrary (Poly n) = variant (if n >= 0 then 2*n else 2*(-n) + 1)
  51
  52 instance Eq a => Eq (Poly a) where
  53         (Poly a) == (Poly b) = a == b
  54
  55 instance Ord a => Ord (Poly a) where
  56         (Poly a) `compare` (Poly b) = a `compare` b
  57
  58 {-
  59  - These are what we export, our pseudo-polymorphic instances.
  60  -}
  61
  62 type ALPHA = Poly ALPHA_
  63 data ALPHA_ = ALPHA_ deriving (Eq)
  64
  65 type BETA = Poly BETA_
  66 data BETA_ = BETA_ deriving (Eq)
  67
  68 type GAMMA = Poly GAMMA_
  69 data GAMMA_ = GAMMA_ deriving (Eq)
  70
  71 type OrdALPHA = Poly OrdALPHA_
  72 data OrdALPHA_ = OrdALPHA_ deriving (Eq,Ord)
  73
  74 type OrdBETA = Poly OrdBETA_
  75 data OrdBETA_ = OrdBETA_ deriving (Eq,Ord)
  76
  77 type OrdGAMMA = Poly OrdGAMMA_
  78 data OrdGAMMA_ = OrdGAMMA_ deriving (Eq,Ord)
  79
  80 {-
  81  - This is a condition on OrdALPHA, OrdBETA, etc, itself.
  82  - It states that all OrdALPHA objects obey total ordering.
  83  -}
  84
  85 prop_OrdPOLY x y = isTotalOrder x y
  86     where types = (x :: OrdALPHA, y :: OrdALPHA)