Nicer pretty printing of counterexamples for tuple generators

QCUtil.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module QCUtil (
  HList(..)
, forAllHL
) where

import Control.Applicative
import Data.List (intercalate)
import GHC.Exts (Constraint)
import Test.QuickCheck

infixr 5 :::

data HList (xs :: [*]) where
  HNil :: HList '[]
  (:::) :: x -> HList xs -> HList (x ': xs)

type family All (c :: * -> Constraint) (xs :: [*]) :: Constraint
type instance All c '[] = ()
type instance All c (x ': xs) = (c x, All c xs)

instance All Eq xs => Eq (HList xs) where
  HNil == HNil = True
  (x ::: xs) == (y ::: ys) = x == y && xs == ys
  _ == _ = False

instance All Show xs => Show (HList xs) where
  show HNil = "HNil"
  show (x ::: xs) = show x ++ " ::: " ++ show xs

newtype GenList xs = GenList (HList xs)
  deriving Eq

toStringList :: All Show xs => HList xs -> [String]
toStringList HNil = []
toStringList (x ::: xs) = show x : toStringList xs

instance All Show xs => Show (GenList xs) where
  show (GenList xs) = intercalate "\n" $ toStringList xs

type family HLFun (xs :: [*]) (r :: *) :: *
type instance HLFun '[] r = r
type instance HLFun (x ': xs) r = x -> HLFun xs r

feed :: HList xs -> HLFun xs r -> r
feed HNil r = r
feed (x ::: xs) r = feed xs (r x)

forAllHL :: forall xs. All Show xs => Gen (HList xs) -> HLFun xs Property -> Property
forAllHL gen f = forAll gen' inner
  where gen' :: Gen (GenList xs)
        gen' = GenList <$> gen
        inner :: GenList xs -> Property
        inner (GenList xs) = feed xs f

usage.hs

-- generate a tuple of values (maybe with some dependencies)
gen_inputs :: Gen (HList '[String, Float, Int])
gen_inputs = do
  x <- arbitrary
  y <- arbitrary
  z <- arbitrary
  return $ x ::: y ::: z ::: HNil

-- ... and with this, counterexamples are pretty-printed like usual, not as tuples
prop_foo = forAllHL gen_inputs $ \x y z ->
  property $ f x y z == whatever