Add DerivingVia newtype for generic arbitrary

Add a newtype, GenericArbitrary, which can be used with -XDerivingVia to
derive Arbitrary instances for types with Generic, via patching
generic-arbitrary to expose the underlying typeclass it uses for
surfacing the type information.

1 files changed, 16 insertions, 1 deletions

diff --git a/src/Xanthous/Util/QuickCheck.hs b/src/Xanthous/Util/QuickCheck.hs
index ac76a4c930..ba04f9ffb2 100644
--- a/src/Xanthous/Util/QuickCheck.hs
+++ b/src/Xanthous/Util/QuickCheck.hs
@@ -1,15 +1,21 @@
+{-# LANGUAGE UndecidableInstances #-}
 module Xanthous.Util.QuickCheck
-  ( FunctionShow(..)
+  ( functionShow
+  , FunctionShow(..)
   , functionJSON
   , FunctionJSON(..)
+  , genericArbitrary
+  , GenericArbitrary(..)
   ) where
 --------------------------------------------------------------------------------
 import Xanthous.Prelude
 import Test.QuickCheck
 import Test.QuickCheck.Function
 import Test.QuickCheck.Instances.ByteString ()
+import Test.QuickCheck.Arbitrary.Generic
 import Data.Aeson
 import Data.Coerce
+import GHC.Generics (Rep)
 --------------------------------------------------------------------------------
 
 newtype FunctionShow a = FunctionShow a
@@ -26,3 +32,12 @@ newtype FunctionJSON a = FunctionJSON a
 
 instance (ToJSON a, FromJSON a) => Function (FunctionJSON a) where
   function = functionJSON
+
+--------------------------------------------------------------------------------
+
+newtype GenericArbitrary a = GenericArbitrary a
+  deriving newtype Generic
+
+instance (Generic a, GArbitrary rep, Rep a ~ rep)
+  => Arbitrary (GenericArbitrary a) where
+  arbitrary = genericArbitrary