Arbitrary.Product.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}

module Arbitrary.Product where

import Test.QuickCheck

-- Example

data Record = R Int Bool String

test :: Gen Record
test = arbitraryProduct R

data S
  = S1 Int Double
  | S2 Double String

test2 :: Gen S
test2 = frequency
  [ 97 % S1
  ,  3 % S2
  ]

-- Implementation

arbitraryProduct
  :: (Uncurry ctor, Arbitrary tuple, Uncurried ctor ~ (tuple -> record))
  => ctor -> Gen record
arbitraryProduct con = uncurry_ con <$> arbitrary

-- | > Uncurried (a -> b -> c -> d -> e) = (((a, b), c), d) -> e
type family Uncurried a where
  Uncurried (a -> b -> c) = Uncurried ((a, b) -> c)
  Uncurried (a -> b) = a -> b

class Uncurry a where
  uncurry_ :: a -> Uncurried a

instance {-# OVERLAPPING #-} Uncurry ((a, b) -> c) => Uncurry (a -> b -> c) where
  uncurry_ = uncurry_ . uncurry

instance (Uncurried (a -> b) ~ (a -> b)) => Uncurry (a -> b) where
  uncurry_ = id
  
(%)
  :: (Uncurry ctor, Arbitrary tuple, Uncurried ctor ~ (tuple -> record))
  => Int -> ctor -> (Int, Gen record)
n % ctor = (n, arbitraryProduct ctor)