about summary refs log tree commit diff
path: root/src/Xanthous
diff options
context:
space:
mode:
authorGriffin Smith <root@gws.fyi>2019-11-30T03·57-0500
committerGriffin Smith <root@gws.fyi>2019-11-30T03·57-0500
commit7d8ce026a2acc5a4d208110750be188f0ce5591c (patch)
tree7a2fc4080eae2b4c1280977fb0ea25b26b25ce96 /src/Xanthous
parent0abcd8c9581f0017cb2bd59a09e93800ea8f3b1f (diff)
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.
Diffstat (limited to 'src/Xanthous')
-rw-r--r--src/Xanthous/Util/QuickCheck.hs17
1 files changed, 16 insertions, 1 deletions
diff --git a/src/Xanthous/Util/QuickCheck.hs b/src/Xanthous/Util/QuickCheck.hs
index ac76a4c930d9..ba04f9ffb28f 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