{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances
           , FlexibleContexts, TypeSynonymInstances, GeneralizedNewtypeDeriving
           , UndecidableInstances, ScopedTypeVariables, DefaultSignatures
           , TypeOperators, CPP
  #-}
{-# 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, involution, inverseL, inverse
  , FracT, NumT, OrdT, T
  -- * Generalized equality
  , EqProp(..), eq
  , BinRel, reflexive, transitive, symmetric, antiSymmetric
  , 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, denotationFor
  , Model1(..)
  -- * Some handy testing types
  -- , Positive, NonZero(..), NonNegative(..)
  -- , suchThat, suchThatMaybe
  , arbs, gens
  , (.&.)
  , arbitrarySatisfying
  ) where

import Data.Function (on)
import Control.Applicative
import Control.Arrow ((***),first)
import qualified Control.Exception as Ex
import Data.List (foldl')
import Data.List.NonEmpty (NonEmpty (..))
import Data.Monoid hiding (First, Last)

import Data.Complex
import Data.Proxy
import Data.Ratio
import Data.Functor.Identity

#if __GLASGOW_HASKELL__ >= 800
import Data.Functor.Compose
import qualified Data.Functor.Product as F
import qualified Data.Functor.Sum as F
#endif
import Data.Semigroup
import GHC.Generics
import System.Random
import Test.QuickCheck hiding (generate)
import Test.QuickCheck.Random (QCGen, newQCGen)
-- import System.IO.Unsafe

import Test.QuickCheck.Gen      (Gen (..)) -- for rand
-- import Test.QuickCheck.Property (Prop(..)) -- for evaluate

import Test.QuickCheck.Utils

-- import Test.QuickCheck.Utils
-- 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 :: TestBatch -> [Test]
unbatch (String
batchName,[Test]
props) = (Test -> Test) -> [Test] -> [Test]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String) -> Test -> Test
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((String
batchName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": ")String -> String -> String
forall a. [a] -> [a] -> [a]
++)) [Test]
props

-- TODO: consider a tree structure so that flattening is unnecessary.

type QuickCheckRunner = Args -> Property -> IO ()

-- | Run a batch of tests.  See 'quickBatch' and 'verboseBatch'.
checkBatch' :: QuickCheckRunner -> Args -> TestBatch -> IO ()
checkBatch' :: QuickCheckRunner -> Args -> TestBatch -> IO ()
checkBatch' QuickCheckRunner
runner Args
args (String
name,[Test]
tests) =
  do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
     (Test -> IO ()) -> [Test] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Test -> IO ()
pr [Test]
tests
 where
   pr :: Test -> IO ()
pr (String
s,Property
p) = do String -> IO ()
putStr (Int -> String -> String
padTo (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) (String
"  "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"))
                 IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Ex.catch (QuickCheckRunner
runner Args
args Property
p)
                          (SomeException -> IO ()
forall a. Show a => a -> IO ()
print :: Ex.SomeException -> IO ())
   width :: Int
width    = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 ((Test -> Int) -> [Test] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length(String -> Int) -> (Test -> String) -> Test -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Test -> String
forall a b. (a, b) -> a
fst) [Test]
tests)

checkBatch :: Args -> TestBatch -> IO ()
checkBatch :: Args -> TestBatch -> IO ()
checkBatch = QuickCheckRunner -> Args -> TestBatch -> IO ()
checkBatch' QuickCheckRunner
forall prop. Testable prop => Args -> prop -> IO ()
quickCheckWith

padTo :: Int -> String -> String
padTo :: Int -> String -> String
padTo Int
n = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
n (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
repeat Char
' ')

-- | Check a batch tersely.
quickBatch :: TestBatch -> IO ()
quickBatch :: TestBatch -> IO ()
quickBatch = Args -> TestBatch -> IO ()
checkBatch Args
quick'

-- | Check a batch verbosely.
verboseBatch :: TestBatch -> IO ()
verboseBatch :: TestBatch -> IO ()
verboseBatch = QuickCheckRunner -> Args -> TestBatch -> IO ()
checkBatch' QuickCheckRunner
forall prop. Testable prop => Args -> prop -> IO ()
verboseCheckWith Args
quick'

quick' :: Args
quick' :: Args
quick'   = Args
stdArgs { maxSuccess :: Int
maxSuccess = Int
500 }

{-

-- 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  = Int -- Char -- randomR is broken on Char
-- | Token uninteresting type for tests
type T     = Char

genR :: Random a => (a, a) -> Gen a
genR :: (a, a) -> Gen a
genR (a
lo,a
hi) = (QCGen -> a) -> Gen QCGen -> Gen a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a, QCGen) -> a
forall a b. (a, b) -> a
fst ((a, QCGen) -> a) -> (QCGen -> (a, QCGen)) -> QCGen -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, a) -> QCGen -> (a, QCGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (a
lo,a
hi)) Gen QCGen
rand

-- | @f@ is its own inverse. See also 'inverse'.
involution :: (Show a, Arbitrary a, EqProp a) =>
              (a -> a) -> Property
involution :: (a -> a) -> Property
involution a -> a
f = a -> a
f (a -> a) -> (a -> a) -> Property
forall b a.
(EqProp b, Arbitrary b, Show b) =>
(a -> b) -> (b -> a) -> Property
`inverseL` a -> a
f

-- | @f@ is a left inverse of @g@.  See also 'inverse'.
inverseL :: (EqProp b, Arbitrary b, Show b) =>
            (a -> b) -> (b -> a) -> Property
a -> b
f inverseL :: (a -> b) -> (b -> a) -> Property
`inverseL` b -> a
g = a -> b
f (a -> b) -> (b -> a) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
g (b -> b) -> (b -> b) -> Property
forall a. EqProp a => a -> a -> Property
=-= b -> b
forall a. a -> a
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
a -> b
f inverse :: (a -> b) -> (b -> a) -> Property
`inverse` b -> a
g = a -> b
f (a -> b) -> (b -> a) -> Property
forall b a.
(EqProp b, Arbitrary b, Show b) =>
(a -> b) -> (b -> a) -> Property
`inverseL` b -> a
g Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&. b -> a
g (b -> a) -> (a -> b) -> Property
forall b a.
(EqProp b, Arbitrary b, Show b) =>
(a -> b) -> (b -> a) -> Property
`inverseL` a -> b
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
  default (=-=) :: (Generic a, GEqProp (Rep a)) => a -> a -> Property
  (=-=) = Rep a Any -> Rep a Any -> Property
forall (g :: * -> *) x. GEqProp g => g x -> g x -> Property
geq (Rep a Any -> Rep a Any -> Property)
-> (a -> Rep a Any) -> a -> a -> Property
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from
  {-# INLINEABLE (=-=) #-}

class GEqProp g where
  geq :: g x -> g x -> Property

instance GEqProp g => GEqProp (M1 _1 _2 g) where
  geq :: M1 _1 _2 g x -> M1 _1 _2 g x -> Property
geq = g x -> g x -> Property
forall (g :: * -> *) x. GEqProp g => g x -> g x -> Property
geq (g x -> g x -> Property)
-> (M1 _1 _2 g x -> g x)
-> M1 _1 _2 g x
-> M1 _1 _2 g x
-> Property
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` M1 _1 _2 g x -> g x
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
  {-# INLINEABLE geq #-}

instance (GEqProp g1, GEqProp g2) => GEqProp (g1 :*: g2) where
  geq :: (:*:) g1 g2 x -> (:*:) g1 g2 x -> Property
geq (g1 x
g1a :*: g2 x
g1b) (g1 x
g2a :*: g2 x
g2b) = g1 x -> g1 x -> Property
forall (g :: * -> *) x. GEqProp g => g x -> g x -> Property
geq g1 x
g1a g1 x
g2a Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. g2 x -> g2 x -> Property
forall (g :: * -> *) x. GEqProp g => g x -> g x -> Property
geq g2 x
g1b g2 x
g2b
  {-# INLINEABLE geq #-}

instance (GEqProp g1, GEqProp g2) => GEqProp (g1 :+: g2) where
  geq :: (:+:) g1 g2 x -> (:+:) g1 g2 x -> Property
geq (L1 g1 x
g1) (L1 g1 x
g2) = g1 x -> g1 x -> Property
forall (g :: * -> *) x. GEqProp g => g x -> g x -> Property
geq g1 x
g1 g1 x
g2
  geq (R1 g2 x
g1) (R1 g2 x
g2) = g2 x -> g2 x -> Property
forall (g :: * -> *) x. GEqProp g => g x -> g x -> Property
geq g2 x
g1 g2 x
g2
  geq (:+:) g1 g2 x
_ (:+:) g1 g2 x
_             = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
  {-# INLINEABLE geq #-}

instance EqProp a => GEqProp (K1 _1 a) where
  geq :: K1 _1 a x -> K1 _1 a x -> Property
geq = a -> a -> Property
forall a. EqProp a => a -> a -> Property
(=-=) (a -> a -> Property)
-> (K1 _1 a x -> a) -> K1 _1 a x -> K1 _1 a x -> Property
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` K1 _1 a x -> a
forall i c k (p :: k). K1 i c p -> c
unK1
  {-# INLINEABLE geq #-}

instance GEqProp U1 where
  geq :: U1 x -> U1 x -> Property
geq U1 x
U1 U1 x
U1 = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
  {-# INLINEABLE geq #-}

instance GEqProp V1 where
  geq :: V1 x -> V1 x -> Property
geq V1 x
_ V1 x
_ = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
  {-# INLINEABLE geq #-}

-- | For 'Eq' types as 'EqProp' types
eq :: Eq a => a -> a -> Property
a
a eq :: a -> a -> Property
`eq` a
a' = Bool -> Property
forall prop. Testable prop => prop -> Property
property (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a')


-- Template: fill in with Eq types for a
--   instance EqProp a where (=-=) = eq
-- E.g.,

instance EqProp ()
instance EqProp Bool
instance EqProp Char where =-= :: Char -> Char -> Property
(=-=) = Char -> Char -> Property
forall a. Eq a => a -> a -> Property
eq
instance EqProp Ordering

-- Numeric
instance EqProp Int     where =-= :: Int -> Int -> Property
(=-=) = Int -> Int -> Property
forall a. Eq a => a -> a -> Property
eq
instance EqProp Float   where =-= :: Float -> Float -> Property
(=-=) = Float -> Float -> Property
forall a. Eq a => a -> a -> Property
eq
instance EqProp Double  where =-= :: Double -> Double -> Property
(=-=) = Double -> Double -> Property
forall a. Eq a => a -> a -> Property
eq
instance EqProp Integer where =-= :: Integer -> Integer -> Property
(=-=) = Integer -> Integer -> Property
forall a. Eq a => a -> a -> Property
eq
instance Eq a => EqProp (Complex a) where =-= :: Complex a -> Complex a -> Property
(=-=) = Complex a -> Complex a -> Property
forall a. Eq a => a -> a -> Property
eq
instance Eq a => EqProp (Ratio a) where =-= :: Ratio a -> Ratio a -> Property
(=-=) = Ratio a -> Ratio a -> Property
forall a. Eq a => a -> a -> Property
eq

-- Semigroups
instance EqProp a => EqProp (Min a)
instance EqProp a => EqProp (Max a)
instance EqProp a => EqProp (First a)
instance EqProp a => EqProp (Last a)

-- Monoids
instance EqProp a => EqProp (Dual a)
instance (Show a, Arbitrary a, EqProp a) => EqProp (Endo a)
instance EqProp All
instance EqProp Any
instance EqProp a => EqProp (Sum a)
instance EqProp a => EqProp (Product a)
instance EqProp (f a) => EqProp (Alt f a)
#if __GLASGOW_HASKELL__ >= 806
instance EqProp (f a) => EqProp (Ap f a)
#endif

-- Lists
instance EqProp a => EqProp [a]
instance EqProp a => EqProp (NonEmpty a)
instance EqProp a => EqProp (ZipList a)

-- Maybe
instance EqProp a => EqProp (Maybe a)

-- Pairing
instance (EqProp a, EqProp b) => EqProp (a,b)
instance (EqProp a, EqProp b, EqProp c) => EqProp (a,b,c)
instance (EqProp a, EqProp b, EqProp c, EqProp d) => EqProp (a,b,c,d)

-- Either
instance (EqProp a, EqProp b) => EqProp (Either a b)

-- Functors
#if __GLASGOW_HASKELL__ >= 800
instance EqProp (f (g a)) => EqProp (Compose f g a)
instance (EqProp (f a), EqProp (g a)) => EqProp (F.Sum f g a)
instance (EqProp (f a), EqProp (g a)) => EqProp (F.Product f g a)
#endif
instance EqProp a => EqProp (Identity a)
instance EqProp a => EqProp (Const a b)
instance EqProp (Proxy a)

-- Function equality
instance (Show a, Arbitrary a, EqProp b) => EqProp (a -> b) where
  a -> b
f =-= :: (a -> b) -> (a -> b) -> Property
=-= a -> b
f' = (a -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((b -> b -> Property) -> (a -> b) -> (a -> b) -> a -> Property
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 b -> b -> Property
forall a. EqProp a => a -> a -> Property
(=-=) a -> b
f a -> b
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 :: a -> a -> Property
eqModels = b -> b -> Property
forall a. EqProp a => a -> a -> Property
(=-=) (b -> b -> Property) -> (a -> b) -> a -> a -> Property
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` a -> b
forall a b. Model a b => a -> b
model


-- | @f `'denotationFor'` g@ proves that @f@ is a model for @g@, ie that
-- @'model' . g '=-=' f@.
denotationFor
    :: (Model b b', Arbitrary a, EqProp b', Show a)
    => (a -> b')
    -> (a -> b)
    -> TestBatch
denotationFor :: (a -> b') -> (a -> b) -> TestBatch
denotationFor a -> b'
f a -> b
g =
  ( String
"denotation"
  , [(String
"eq", b -> b'
forall a b. Model a b => a -> b
model (b -> b') -> (a -> b) -> a -> b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
g (a -> b') -> (a -> b') -> Property
forall a. EqProp a => a -> a -> Property
=-= a -> b'
f)]
  )

-- Other types
-- instance EqProp a => EqProp (S.Stream a) where (=-=) = eqModels

-- Binary relation
type BinRel  a = a -> a -> Bool

-- | Reflexive property: @a `rel` a@
reflexive :: (Arbitrary a, Show a) =>
             BinRel a -> Property
reflexive :: BinRel a -> Property
reflexive BinRel a
rel = (a -> Bool) -> Property
forall prop. Testable prop => prop -> Property
property ((a -> Bool) -> Property) -> (a -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \ a
a -> a
a BinRel a
`rel` a
a

-- | Transitive property: @a `rel` b && b `rel` c ==> a `rel` c@.
-- Generate @a@ randomly, but use @gen a@ to generate @b@ and @gen b@ to
-- generate @c@.  @gen@ ought to satisfy @rel@ fairly often.
transitive :: (Arbitrary a, Show a) =>
              BinRel a -> (a -> Gen a) -> Property
transitive :: BinRel a -> (a -> Gen a) -> Property
transitive BinRel a
rel a -> Gen a
gen =
  (a -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((a -> Property) -> Property) -> (a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ a
a ->
    Gen a -> (a -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (a -> Gen a
gen a
a) ((a -> Property) -> Property) -> (a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ a
b ->
      Gen a -> (a -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (a -> Gen a
gen a
b) ((a -> Property) -> Property) -> (a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ a
c ->
        (a
a BinRel a
`rel` a
b) Bool -> Bool -> Bool
&& (a
b BinRel a
`rel` a
c) Bool -> Bool -> Property
forall prop. Testable prop => Bool -> prop -> Property
==> (a
a BinRel a
`rel` a
c)

-- | Symmetric property: @a `rel` b ==> b `rel` a@.  Generate @a@
-- randomly, but use @gen a@ to generate @b@.  @gen@ ought to satisfy
-- @rel@ fairly often.
symmetric :: (Arbitrary a, Show a) =>
             BinRel a -> (a -> Gen a) -> Property
symmetric :: BinRel a -> (a -> Gen a) -> Property
symmetric BinRel a
rel a -> Gen a
gen =
  (a -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((a -> Property) -> Property) -> (a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ a
a ->
    Gen a -> (a -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (a -> Gen a
gen a
a) ((a -> Property) -> Property) -> (a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ a
b ->
      (a
a BinRel a
`rel` a
b) Bool -> Bool -> Property
forall prop. Testable prop => Bool -> prop -> Property
==> (a
b BinRel a
`rel` a
a)

-- | Antisymmetric property: @(a `rel` b) && (a /= b) ==> not (b `rel` a)@.
--
-- @since 0.5.0
antiSymmetric :: (Arbitrary a, Show a, Eq a) =>
                 BinRel a -> Property
antiSymmetric :: BinRel a -> Property
antiSymmetric BinRel a
rel =
  (a -> a -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((a -> a -> Property) -> Property)
-> (a -> a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ a
a a
b -> (a
a BinRel a
`rel` a
b) Bool -> Bool -> Bool
&& (a
a BinRel a
forall a. Eq a => a -> a -> Bool
/= a
b) Bool -> Bool -> Property
forall prop. Testable prop => Bool -> prop -> Property
==> Bool -> Bool
not (a
b BinRel a
`rel` a
a)

-- | Has a given left identity, according to '(=-=)'
leftId :: (Show a, Arbitrary a, EqProp a) => (i -> a -> a) -> i -> Property
leftId :: (i -> a -> a) -> i -> Property
leftId  i -> a -> a
op i
i = (i
i i -> a -> a
`op`) (a -> a) -> (a -> a) -> Property
forall a. EqProp a => a -> a -> Property
=-= a -> a
forall a. a -> a
id

-- | Has a given right identity, according to '(=-=)'
rightId :: (Show a, Arbitrary a, EqProp a) => (a -> i -> a) -> i -> Property
rightId :: (a -> i -> a) -> i -> Property
rightId a -> i -> a
op i
i = (a -> i -> a
`op` i
i) (a -> a) -> (a -> a) -> Property
forall a. EqProp a => a -> a -> Property
=-= a -> a
forall a. a -> a
id

-- | Has a given left and right identity, according to '(=-=)'
bothId :: (Show a, Arbitrary a, EqProp a) => (a -> a -> a) -> a -> Property
bothId :: (a -> a -> a) -> a -> Property
bothId = (((a -> Property) -> (a -> Property) -> a -> Property)
-> ((a -> a -> a) -> a -> Property)
-> ((a -> a -> a) -> a -> Property)
-> (a -> a -> a)
-> a
-> Property
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2(((a -> Property) -> (a -> Property) -> a -> Property)
 -> ((a -> a -> a) -> a -> Property)
 -> ((a -> a -> a) -> a -> Property)
 -> (a -> a -> a)
 -> a
 -> Property)
-> ((Property -> Property -> Property)
    -> (a -> Property) -> (a -> Property) -> a -> Property)
-> (Property -> Property -> Property)
-> ((a -> a -> a) -> a -> Property)
-> ((a -> a -> a) -> a -> Property)
-> (a -> a -> a)
-> a
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Property -> Property -> Property)
-> (a -> Property) -> (a -> Property) -> a -> Property
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2) Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
(.&.) (a -> a -> a) -> a -> Property
forall a i.
(Show a, Arbitrary a, EqProp a) =>
(i -> a -> a) -> i -> Property
leftId (a -> a -> a) -> a -> Property
forall a i.
(Show a, Arbitrary a, EqProp a) =>
(a -> i -> a) -> i -> Property
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 :: (a -> a -> a) -> Property
isAssoc = (a -> a -> Property) -> Gen a -> (a -> a -> a) -> Property
forall a prop.
(Show a, Testable prop) =>
(a -> a -> prop) -> Gen a -> (a -> a -> a) -> Property
isAssociativeBy a -> a -> Property
forall a. EqProp a => a -> a -> Property
(=-=) Gen a
forall a. Arbitrary a => Gen a
arbitrary

-- | Commutative, according to '(=-=)'
commutes :: EqProp z => (a -> a -> z) -> a -> a -> Property
commutes :: (a -> a -> z) -> a -> a -> Property
commutes a -> a -> z
(#) a
a a
b = a
a a -> a -> z
# a
b z -> z -> Property
forall a. EqProp a => a -> a -> Property
=-= a
b a -> a -> z
# a
a

-- | Commutative, according to '(=-=)'
isCommut :: (EqProp a, Show a, Arbitrary a) => (a -> a -> a) -> Property
isCommut :: (a -> a -> a) -> Property
isCommut = (a -> a -> Property) -> Gen a -> (a -> a -> a) -> Property
forall a prop b.
(Show a, Testable prop) =>
(b -> b -> prop) -> Gen a -> (a -> a -> b) -> Property
isCommutableBy a -> a -> Property
forall a. EqProp a => a -> a -> Property
(=-=) Gen a
forall a. Arbitrary a => Gen a
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 a
monoidD = a -> (a -> a -> a) -> MonoidD a
forall a. a -> (a -> a -> a) -> MonoidD a
MonoidD a
forall a. Monoid a => a
mempty a -> a -> a
forall a. Monoid a => a -> a -> a
mappend

-- | Monoid dictionary for an unwrapped endomorphism.  See also 'monoidD'
-- and 'Endo'.
endoMonoidD :: MonoidD (a -> a)
endoMonoidD :: MonoidD (a -> a)
endoMonoidD = (a -> a) -> ((a -> a) -> (a -> a) -> a -> a) -> MonoidD (a -> a)
forall a. a -> (a -> a -> a) -> MonoidD a
MonoidD a -> a
forall a. a -> a
id (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)

-- | 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 a -> MonoidD b -> (a -> b) -> [Test]
homomorphism (MonoidD a
ida a -> a -> a
opa) (MonoidD b
idb b -> b -> b
opb) a -> b
q =
  [ (String
"identity" , a -> b
q a
ida b -> b -> Property
forall a. EqProp a => a -> a -> Property
=-= b
idb)
  , (String
"binop", (a -> a -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((a -> a -> Property) -> Property)
-> (a -> a -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ a
u a
v -> a -> b
q (a
u a -> a -> a
`opa` a
v) b -> b -> Property
forall a. EqProp a => a -> a -> Property
=-= a -> b
q a
u b -> b -> b
`opb` a -> b
q a
v)
  ]

-- | The unary function @f@ is idempotent, i.e., @f . f == f@
idempotent :: (Show a, Arbitrary a, EqProp a) =>
               (a -> a) -> Property
idempotent :: (a -> a) -> Property
idempotent a -> a
f = ((a -> a) -> (a -> a) -> a -> a) -> (a -> a) -> Property
forall a. EqProp a => (a -> a -> a) -> a -> Property
idemElem (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) a -> a
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 :: (a -> a -> a) -> Property
idempotent2 = (a -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((a -> Property) -> Property)
-> ((a -> a -> a) -> a -> Property) -> (a -> a -> a) -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> a) -> a -> Property
forall a. EqProp a => (a -> a -> a) -> a -> 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 :: (a -> a -> a) -> a -> Property
idemElem a -> a -> a
op a
x = a
x a -> a -> a
`op` a
x a -> a -> Property
forall a. EqProp a => a -> a -> Property
=-= a
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 -> Property
meq  a
a b
b =
     a -> b
forall a b. Model a b => a -> b
model a
a             b -> b -> Property
forall a. EqProp a => a -> a -> Property
=-= b
b
meq1 :: (a1 -> a) -> (b1 -> b) -> a1 -> Property
meq1 a1 -> a
f b1 -> b
g = \a1
a         ->
     a -> b
forall a b. Model a b => a -> b
model (a1 -> a
f a1
a)         b -> b -> Property
forall a. EqProp a => a -> a -> Property
=-= b1 -> b
g (a1 -> b1
forall a b. Model a b => a -> b
model a1
a)
meq2 :: (a1 -> a2 -> a) -> (b1 -> b2 -> b) -> a1 -> a2 -> Property
meq2 a1 -> a2 -> a
f b1 -> b2 -> b
g = \a1
a a2
b       ->
     a -> b
forall a b. Model a b => a -> b
model (a1 -> a2 -> a
f a1
a a2
b)       b -> b -> Property
forall a. EqProp a => a -> a -> Property
=-= b1 -> b2 -> b
g (a1 -> b1
forall a b. Model a b => a -> b
model a1
a) (a2 -> b2
forall a b. Model a b => a -> b
model a2
b)
meq3 :: (a1 -> a2 -> a3 -> a)
-> (b1 -> b2 -> b3 -> b) -> a1 -> a2 -> a3 -> Property
meq3 a1 -> a2 -> a3 -> a
f b1 -> b2 -> b3 -> b
g = \a1
a a2
b a3
c     ->
     a -> b
forall a b. Model a b => a -> b
model (a1 -> a2 -> a3 -> a
f a1
a a2
b a3
c)     b -> b -> Property
forall a. EqProp a => a -> a -> Property
=-= b1 -> b2 -> b3 -> b
g (a1 -> b1
forall a b. Model a b => a -> b
model a1
a) (a2 -> b2
forall a b. Model a b => a -> b
model a2
b) (a3 -> b3
forall a b. Model a b => a -> b
model a3
c)
meq4 :: (a1 -> a2 -> a3 -> a4 -> a)
-> (b1 -> b2 -> b3 -> b4 -> b) -> a1 -> a2 -> a3 -> a4 -> Property
meq4 a1 -> a2 -> a3 -> a4 -> a
f b1 -> b2 -> b3 -> b4 -> b
g = \a1
a a2
b a3
c a4
d   ->
     a -> b
forall a b. Model a b => a -> b
model (a1 -> a2 -> a3 -> a4 -> a
f a1
a a2
b a3
c a4
d)   b -> b -> Property
forall a. EqProp a => a -> a -> Property
=-= b1 -> b2 -> b3 -> b4 -> b
g (a1 -> b1
forall a b. Model a b => a -> b
model a1
a) (a2 -> b2
forall a b. Model a b => a -> b
model a2
b) (a3 -> b3
forall a b. Model a b => a -> b
model a3
c) (a4 -> b4
forall a b. Model a b => a -> b
model a4
d)
meq5 :: (a1 -> a2 -> a3 -> a4 -> a5 -> a)
-> (b1 -> b2 -> b3 -> b4 -> b5 -> b)
-> a1
-> a2
-> a3
-> a4
-> a5
-> Property
meq5 a1 -> a2 -> a3 -> a4 -> a5 -> a
f b1 -> b2 -> b3 -> b4 -> b5 -> b
g = \a1
a a2
b a3
c a4
d a5
e ->
     a -> b
forall a b. Model a b => a -> b
model (a1 -> a2 -> a3 -> a4 -> a5 -> a
f a1
a a2
b a3
c a4
d a5
e) b -> b -> Property
forall a. EqProp a => a -> a -> Property
=-= b1 -> b2 -> b3 -> b4 -> b5 -> b
g (a1 -> b1
forall a b. Model a b => a -> b
model a1
a) (a2 -> b2
forall a b. Model a b => a -> b
model a2
b) (a3 -> b3
forall a b. Model a b => a -> b
model a3
c) (a4 -> b4
forall a b. Model a b => a -> b
model a4
d) (a5 -> b5
forall a b. Model a b => a -> b
model a5
e)


---- Some model instances

instance Model Bool   Bool   where model :: Bool -> Bool
model = Bool -> Bool
forall a. a -> a
id
instance Model Char   Char   where model :: Char -> Char
model = Char -> Char
forall a. a -> a
id
instance Model Int    Int    where model :: Int -> Int
model = Int -> Int
forall a. a -> a
id
instance Model Float  Float  where model :: Float -> Float
model = Float -> Float
forall a. a -> a
id
instance Model Double Double where model :: Double -> Double
model = Double -> Double
forall a. a -> a
id
instance Model String String where model :: String -> String
model = String -> String
forall a. a -> a
id

-- These next two require UndecidableInstances
instance (Model a b, Model a' b') => Model (a,a') (b,b') where
  model :: (a, a') -> (b, b')
model = a -> b
forall a b. Model a b => a -> b
model (a -> b) -> (a' -> b') -> (a, a') -> (b, b')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** a' -> b'
forall a b. Model a b => a -> b
model

instance Model b b' => Model (a -> b) (a -> b') where
  model :: (a -> b) -> a -> b'
model a -> b
f = b -> b'
forall a b. Model a b => a -> b
model (b -> b') -> (a -> b) -> a -> b'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

-- 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)

arbitrarySatisfying :: Arbitrary a => (a -> Bool) -> Gen a
arbitrarySatisfying :: (a -> Bool) -> Gen a
arbitrarySatisfying = (Gen a
forall a. Arbitrary a => Gen a
arbitrary Gen a -> (a -> Bool) -> Gen a
forall a. Gen a -> (a -> Bool) -> Gen a
`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 :: Int -> IO [a]
arbs Int
n = (QCGen -> [a]) -> IO QCGen -> IO [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ QCGen
rnd -> Int -> QCGen -> Gen [a] -> [a]
forall a. Int -> QCGen -> Gen a -> a
generate Int
n QCGen
rnd (Int -> Gen [a]
forall a. Arbitrary a => Int -> Gen [a]
vector Int
n)) IO QCGen
newQCGen

-- | Produce n values from a generator
gens :: Int -> Gen a -> IO [a]
gens :: Int -> Gen a -> IO [a]
gens Int
n Gen a
gen =
  (QCGen -> [a]) -> IO QCGen -> IO [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ QCGen
rnd -> Int -> QCGen -> Gen [a] -> [a]
forall a. Int -> QCGen -> Gen a -> a
generate Int
1000 QCGen
rnd ([Gen a] -> Gen [a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Int -> Gen a -> [Gen a]
forall a. Int -> a -> [a]
replicate Int
n Gen a
gen))) IO QCGen
newQCGen

-- The next two are from twanvl:

instance Testable a => Testable [a] where
  property :: [a] -> Property
property []    = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
  property [a]
props = (Int -> a) -> Property
forall prop. Testable prop => prop -> Property
property ((Int -> a) -> Property) -> (Int -> a) -> Property
forall a b. (a -> b) -> a -> b
$ \Int
n -> [a]
props [a] -> Int -> a
forall a. [a] -> Int -> a
!! (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
len)
    where len :: Int
len = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
props

instance (Testable a, Testable b) => Testable (a,b) where
  property :: (a, b) -> Property
property = (a -> b -> Property) -> (a, b) -> Property
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> b -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
(.&.)

{-
probablisticPureCheck :: Testable a => Args -> a -> Bool
probablisticPureCheck args a = unsafePerformIO $
  do rnd <- newStdGen
     probablisticPureTests args (evaluate a) rnd 0 0 []


probablisticPureTests :: Args
                      -> Gen Result
                      -> StdGen
                      -> Int
                      -> Int
                      -> [[String]]
                      -> IO Bool
probablisticPureTests args gen rnd0 ntest nfail stamps
  | ntest == maxSuccess args = return True
  | nfail == maxDiscard args = return True
  | otherwise                     =
      case ok result of
        Nothing    ->
          probablisticPureTests args gen rnd1 ntest (nfail+1) stamps
        Just True  ->
          probablisticPureTests args gen rnd1 (ntest+1) nfail
                                (stamp result:stamps)
        Just False ->
          return False
     where
      result      = generate (maxSize config ntest) rnd2 gen
      (rnd1,rnd2) = split rnd0

-}

-- TODO: resurrect probablistic stuff.  bob?


{--------------------------------------------------------------------
    Copied (& tweaked) from QC1
--------------------------------------------------------------------}

-- TODO: are there QC2 replacements for these QC1 operations?

rand :: Gen QCGen
rand :: Gen QCGen
rand = (QCGen -> Int -> QCGen) -> Gen QCGen
forall a. (QCGen -> Int -> a) -> Gen a
MkGen (\QCGen
r Int
_ -> QCGen
r)

generate :: Int -> QCGen -> Gen a -> a
generate :: Int -> QCGen -> Gen a -> a
generate Int
n QCGen
rnd (MkGen QCGen -> Int -> a
m) = QCGen -> Int -> a
m QCGen
rnd' Int
size
 where
  (Int
size, QCGen
rnd') = (Int, Int) -> QCGen -> (Int, QCGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, Int
n) QCGen
rnd

-- evaluate :: Testable a => a -> Gen Result
-- evaluate a = gen where MkProp gen = property a