{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Test.QuickCheck.HigherOrder.Internal.Constructible where
import Data.Functor.Identity
import qualified Data.Monoid as Monoid
import Test.QuickCheck (Arbitrary(..), Function, CoArbitrary, Fun)
class (Arbitrary (Repr a), Show (Repr a)) => Constructible a where
type Repr a
type instance Repr a = a
fromRepr :: Repr a -> a
data Constructed a = Constructed (Repr a) a
pattern Construct :: a -> Constructed a
pattern Construct a <- Constructed _ a
mkConstructed :: Constructible a => Repr a -> Constructed a
mkConstructed r = Constructed r (fromRepr r)
instance Constructible a => Arbitrary (Constructed a) where
arbitrary = fmap mkConstructed arbitrary
shrink (Constructed r _) = fmap mkConstructed (shrink r)
instance Constructible a => Show (Constructed a) where
showsPrec n (Constructed r _) = showParen (n > 10) $
showString "Constructed " . showsPrec 11 r . showString " _"
instance (CoArbitrary a, Function a, Show a, Constructible b) => Constructible (Fun a b) where
type Repr (Fun a b) = Fun a (Repr b)
fromRepr = fmap fromRepr
instance Constructible a => Constructible (Identity a) where
type Repr (Identity a) = Repr a
fromRepr = Identity . fromRepr
instance (Constructible a, Constructible b) => Constructible (a, b) where
type Repr (a, b) = (Repr a, Repr b)
fromRepr (a, b) = (fromRepr a, fromRepr b)
instance (Constructible a, Constructible b) => Constructible (Either a b) where
type Repr (Either a b) = Either (Repr a) (Repr b)
fromRepr (Left a) = Left (fromRepr a)
fromRepr (Right b) = Right (fromRepr b)
instance Constructible a => Constructible (Maybe a) where
type Repr (Maybe a) = Maybe (Repr a)
fromRepr = fmap fromRepr
instance Constructible a => Constructible [a] where
type Repr [a] = [Repr a]
fromRepr = fmap fromRepr
instance Constructible Integer where fromRepr = id
instance Constructible Int where fromRepr = id
instance Constructible Word where fromRepr = id
instance Constructible Double where fromRepr = id
instance Constructible Char where fromRepr = id
instance Constructible () where fromRepr = id
instance Constructible Bool where fromRepr = id
instance Constructible Ordering where fromRepr = id
instance Constructible a => Constructible (Monoid.Sum a) where
type Repr (Monoid.Sum a) = Monoid.Sum (Repr a)
fromRepr = Monoid.Sum . fromRepr . Monoid.getSum