compactable-0.2.0.0: test/Core.hs

{-# LANGUAGE CPP                        #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE UndecidableInstances       #-}


module Core where


import           Control.Applicative         (WrappedMonad (..))
import           Control.Functor.Dichotomous
import           Data.Proxy                  (Proxy (..))
import           Data.Semigroup              (Option (Option), Sum)
import           Data.These                  (These (..))
import qualified Data.Vector                 as Vector
import           Debug.Trace                 (trace)
import           GHC.Generics                (Rec1 (Rec1))
import           Test.QuickCheck             (CoArbitrary, choose)
import           Test.QuickCheck.Arbitrary   (Arbitrary (..), Arbitrary1 (..),
                                              arbitrary1, shrink1)
import           Test.QuickCheck.Function    (Function)
import           Test.QuickCheck.Gen         (elements)
import           Test.Syd                    (TestDefM, modifyMaxSize)


type Case' w g f =
  ( Arbitrary (f Int)
  , Arbitrary (f String)
  , Show (f Int)
  , Show (f String)
  , Arbitrary (f (Maybe Int))
  , Arbitrary (f (These String Int))
  , Show (f (Maybe Int))
  , Show (f (These String Int))
  , Eq (f Int)
  , Eq (f (Maybe Int))
  , Eq (f (These Int Int))
  , Eq (f (These String Int))
  , Eq (f (These Int String))
  , Eq (f (Maybe (These Int Int)))
  , Eq (f (Maybe (TheseOrNot Int Int)))
  , w f
  , g f
  )


limitSize :: Int -> TestDefM a b c -> TestDefM a b c
limitSize x = modifyMaxSize $ \y -> y * x `div` 100


#if __GLASGOW_HASKELL__ < 900
deriving instance Arbitrary a => Arbitrary (Option a)
#endif
instance Arbitrary1 Vector.Vector where
  liftArbitrary = fmap Vector.fromList . liftArbitrary
  liftShrink shr = fmap Vector.fromList . liftShrink shr . Vector.toList
instance Arbitrary a => Arbitrary (Vector.Vector a) where
  arbitrary = arbitrary1
  shrink = shrink1
instance Arbitrary (Proxy a) where
  arbitrary = return Proxy

instance Arbitrary (a b) => Arbitrary (Rec1 a b) where
  arbitrary = Rec1 <$> arbitrary


instance (Arbitrary a, Arbitrary b) => Arbitrary (These a b) where
  arbitrary = do
    x <- arbitrary
    y <- arbitrary
    elements [This x, That y, These x y]


deriving instance Show (m a) => Show (WrappedMonad m a)
deriving instance Eq (m a) => Eq (WrappedMonad m a)
deriving instance (Monad m, Foldable m, Foldable (WrappedMonad m), Traversable m) => Traversable (WrappedMonad m)
deriving instance Foldable (WrappedMonad [])


instance Arbitrary (None a b) where
  arbitrary = pure None

instance (Arbitrary a, Arbitrary b) => Arbitrary (MaybeBoth a b) where
  arbitrary = MaybeBoth <$> arbitrary

instance Arbitrary a => Arbitrary (MaybeLeft a b) where
  arbitrary = do
    x <- arbitrary
    elements [ MLNothing, MLeft x ]

instance Arbitrary b => Arbitrary (MaybeRight a b) where
  arbitrary = do
    x <- arbitrary
    elements [ MRNothing, MRight x ]

instance (Arbitrary a, Arbitrary b) => Arbitrary (TheseOrNot a b) where
  arbitrary = do
    a <- arbitrary
    b <- arbitrary
    elements [ Not, This' a, That' b, These' a b ]

instance Arbitrary a => Arbitrary (LeftOnly a b) where
  arbitrary = LeftOnly <$> arbitrary

instance ( Arbitrary a, Arbitrary b ) => Arbitrary (LeftOrBoth a b) where
  arbitrary = do
    l <- arbitrary
    r <- arbitrary
    elements [Left' l, LBoth l r]

instance Arbitrary b => Arbitrary (RightOnly a b) where
  arbitrary = RightOnly <$> arbitrary

instance ( Arbitrary a, Arbitrary b ) => Arbitrary (RightOrBoth a b) where
  arbitrary = do
    l <- arbitrary
    r <- arbitrary
    elements [Right' r, RBoth l r]

instance ( Arbitrary a, Arbitrary b ) => Arbitrary (MaybeRightOrBoth a b) where
  arbitrary = do
    l <- arbitrary
    r <- arbitrary
    elements [MRBRight r, MRBoth l r, MRBNothing]

instance ( Arbitrary a, Arbitrary b ) => Arbitrary (MaybeLeftOrBoth a b) where
  arbitrary = do
    l <- arbitrary
    r <- arbitrary
    elements [MLBLeft l, MLBoth l r, MLBNothing]

instance ( Arbitrary a, Arbitrary b ) => Arbitrary (MaybeEither a b) where
  arbitrary = do
    l <- arbitrary
    r <- arbitrary
    elements [MELeft l, MERight r, MENothing]

instance Function (These Int Int)
instance CoArbitrary (These Int Int)