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

-- * The 'Constructible' class

-- | A 'Constructible' type is associated with a type of "finite descriptions"
-- that can be generated, shown (e.g., as counterexamples in QuickCheck), and
-- interpreted as values.
-- This enhances 'Arbitrary' and 'Show' used by vanilla QuickCheck.
--
-- The main motivating example is the type of functions, which can be
-- finitely represented by the type @('Test.QuickCheck.HigherOrder.:->')@
-- (see also "Test.Fun").
--
-- It turns out we can define 'Constructible' for just about anything
-- except 'IO' (for now...).
class (Arbitrary (Repr a), Show (Repr a)) => Constructible a where
  -- | The observable representation of a value.
  type Repr a
  type instance Repr a = a
  -- | Interpret a representation as a value.
  fromRepr :: Repr a -> a

-- * The 'Constructed' modifier

-- | 'Constructible' wrapper with 'Show' and 'Arbitrary' instances
-- that operate on the representation of the argument type.
--
-- Deconstruct with the 'Construct' pattern.
--
-- This is only useful for property combinators from vanilla QuickCheck, that
-- use the original 'Testable' class instead of
-- 'Test.QuickCheck.HigherOrder.Testable'' from this library.
data Constructed a = Constructed (Repr a) a

-- | A unidirectional pattern to deconstruct 'Constructed' values.
pattern Construct :: a -> Constructed a
pattern $mConstruct :: forall r a. Constructed a -> (a -> r) -> (Void# -> r) -> r
Construct a <- Constructed _ a

-- | A smart constructor for constructible values.
mkConstructed :: Constructible a => Repr a -> Constructed a
mkConstructed :: Repr a -> Constructed a
mkConstructed Repr a
r = Repr a -> a -> Constructed a
forall a. Repr a -> a -> Constructed a
Constructed Repr a
r (Repr a -> a
forall a. Constructible a => Repr a -> a
fromRepr Repr a
r)

instance Constructible a => Arbitrary (Constructed a) where
  arbitrary :: Gen (Constructed a)
arbitrary = (Repr a -> Constructed a) -> Gen (Repr a) -> Gen (Constructed a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Repr a -> Constructed a
forall a. Constructible a => Repr a -> Constructed a
mkConstructed Gen (Repr a)
forall a. Arbitrary a => Gen a
arbitrary
  shrink :: Constructed a -> [Constructed a]
shrink (Constructed Repr a
r a
_) = (Repr a -> Constructed a) -> [Repr a] -> [Constructed a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Repr a -> Constructed a
forall a. Constructible a => Repr a -> Constructed a
mkConstructed (Repr a -> [Repr a]
forall a. Arbitrary a => a -> [a]
shrink Repr a
r)

instance Constructible a => Show (Constructed a) where
  showsPrec :: Int -> Constructed a -> ShowS
showsPrec Int
n (Constructed Repr a
r a
_) = Bool -> ShowS -> ShowS
showParen (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    String -> ShowS
showString String
"Constructed " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Repr a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Repr a
r ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" _"


-- 'Constructible' instances

instance (CoArbitrary a, Function a, Show a, Constructible b) => Constructible (Fun a b) where
  type Repr (Fun a b) = Fun a (Repr b)
  fromRepr :: Repr (Fun a b) -> Fun a b
fromRepr = (Repr b -> b) -> Fun a (Repr b) -> Fun a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Repr b -> b
forall a. Constructible a => Repr a -> a
fromRepr

instance Constructible a => Constructible (Identity a) where
  type Repr (Identity a) = Repr a
  fromRepr :: Repr (Identity a) -> Identity a
fromRepr = a -> Identity a
forall a. a -> Identity a
Identity (a -> Identity a) -> (Repr a -> a) -> Repr a -> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Repr a -> a
forall a. Constructible a => Repr a -> a
fromRepr

instance (Constructible a, Constructible b) => Constructible (a, b) where
  type Repr (a, b) = (Repr a, Repr b)
  fromRepr :: Repr (a, b) -> (a, b)
fromRepr (a, b) = (Repr a -> a
forall a. Constructible a => Repr a -> a
fromRepr Repr a
a, Repr b -> b
forall a. Constructible a => Repr a -> a
fromRepr Repr b
b)

instance (Constructible a, Constructible b) => Constructible (Either a b) where
  type Repr (Either a b) = Either (Repr a) (Repr b)
  fromRepr :: Repr (Either a b) -> Either a b
fromRepr (Left a) = a -> Either a b
forall a b. a -> Either a b
Left (Repr a -> a
forall a. Constructible a => Repr a -> a
fromRepr Repr a
a)
  fromRepr (Right b) = b -> Either a b
forall a b. b -> Either a b
Right (Repr b -> b
forall a. Constructible a => Repr a -> a
fromRepr Repr b
b)

instance Constructible a => Constructible (Maybe a) where
  type Repr (Maybe a) = Maybe (Repr a)
  fromRepr :: Repr (Maybe a) -> Maybe a
fromRepr = (Repr a -> a) -> Maybe (Repr a) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Repr a -> a
forall a. Constructible a => Repr a -> a
fromRepr

instance Constructible a => Constructible [a] where
  type Repr [a] = [Repr a]
  fromRepr :: Repr [a] -> [a]
fromRepr = (Repr a -> a) -> [Repr a] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Repr a -> a
forall a. Constructible a => Repr a -> a
fromRepr

instance Constructible Integer where fromRepr :: Repr Integer -> Integer
fromRepr = Repr Integer -> Integer
forall a. a -> a
id
instance Constructible Int where fromRepr :: Repr Int -> Int
fromRepr = Repr Int -> Int
forall a. a -> a
id
instance Constructible Word where fromRepr :: Repr Word -> Word
fromRepr = Repr Word -> Word
forall a. a -> a
id
instance Constructible Double where fromRepr :: Repr Double -> Double
fromRepr = Repr Double -> Double
forall a. a -> a
id
instance Constructible Char where fromRepr :: Repr Char -> Char
fromRepr = Repr Char -> Char
forall a. a -> a
id
instance Constructible () where fromRepr :: Repr () -> ()
fromRepr = Repr () -> ()
forall a. a -> a
id
instance Constructible Bool where fromRepr :: Repr Bool -> Bool
fromRepr = Repr Bool -> Bool
forall a. a -> a
id
instance Constructible Ordering where fromRepr :: Repr Ordering -> Ordering
fromRepr = Repr Ordering -> Ordering
forall a. a -> a
id

instance Constructible a => Constructible (Monoid.Sum a) where
  type Repr (Monoid.Sum a) = Monoid.Sum (Repr a)
  fromRepr :: Repr (Sum a) -> Sum a
fromRepr = a -> Sum a
forall a. a -> Sum a
Monoid.Sum (a -> Sum a) -> (Sum (Repr a) -> a) -> Sum (Repr a) -> Sum a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Repr a -> a
forall a. Constructible a => Repr a -> a
fromRepr (Repr a -> a) -> (Sum (Repr a) -> Repr a) -> Sum (Repr a) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sum (Repr a) -> Repr a
forall a. Sum a -> a
Monoid.getSum