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.

5 files changed, 47 insertions, 4 deletions

diff --git a/default.nix b/default.nix
index 7cf9f4beb451..ca163c8e56d7 100644
--- a/default.nix
+++ b/default.nix
@@ -1,8 +1,11 @@
-{ nixpkgs ? import ./nixpkgs.nix {}, compiler ? "ghc865" }:
+{ nixpkgs ? import ./nixpkgs.nix {}
+, compiler ? "ghc865" }:
 let
   inherit (nixpkgs) pkgs;
   all-hies = import (fetchTarball "https://github.com/infinisil/all-hies/tarball/master") {};
   hie = all-hies.selection { selector = p: { inherit (p) ghc865; }; };
-  xanthous = pkgs.haskellPackages.callPackage (import ./pkg.nix { inherit nixpkgs; }) {};
+  xanthous = (pkgs.haskellPackages
+    .extend (import ./haskell-overlay.nix { inherit nixpkgs; }))
+    .callPackage (import ./pkg.nix { inherit nixpkgs; }) {};
 in
 xanthous // { inherit hie; }
diff --git a/generic-arbitrary-export-garbitrary.patch b/generic-arbitrary-export-garbitrary.patch
new file mode 100644
index 000000000000..f0c936bfca18
--- /dev/null
+++ b/generic-arbitrary-export-garbitrary.patch
@@ -0,0 +1,12 @@
+diff --git a/src/Test/QuickCheck/Arbitrary/Generic.hs b/src/Test/QuickCheck/Arbitrary/Generic.hs
+index fed6ab3..91f59f1 100644
+--- a/src/Test/QuickCheck/Arbitrary/Generic.hs
++++ b/src/Test/QuickCheck/Arbitrary/Generic.hs
+@@ -23,6 +23,7 @@ The generated 'arbitrary' method is equivalent to
+ 
+ module Test.QuickCheck.Arbitrary.Generic
+   ( Arbitrary(..)
++  , GArbitrary
+   , genericArbitrary
+   , genericShrink
+   ) where
diff --git a/haskell-overlay.nix b/haskell-overlay.nix
new file mode 100644
index 000000000000..90ba35c6af6e
--- /dev/null
+++ b/haskell-overlay.nix
@@ -0,0 +1,7 @@
+{ nixpkgs ? import ./nixpkgs.nix {} }:
+let inherit (nixpkgs) pkgs;
+in self: super: rec {
+  generic-arbitrary = pkgs.haskell.lib.appendPatch
+    super.generic-arbitrary
+    [ ./generic-arbitrary-export-garbitrary.patch ];
+}
diff --git a/shell.nix b/shell.nix
index 966ab0bb0857..d1c2b7ad911a 100644
--- a/shell.nix
+++ b/shell.nix
@@ -8,7 +8,9 @@ let
     if compiler == "default"
     then pkgs.haskellPackages
     else pkgs.haskell.packages.${compiler}
-  );
+  ).override {
+    overrides = import ./haskell-overlay.nix { inherit nixpkgs; };
+  };
 
   haskellPackages = (
     if withHoogle
@@ -16,6 +18,10 @@ let
       overrides = (self: super: {
         ghc = super.ghc // { withPackages = super.ghc.withHoogle; };
         ghcWithPackages = self.ghc.withPackages;
+        # eww https://github.com/NixOS/nixpkgs/issues/16394
+        generic-arbitrary = pkgs.haskell.lib.appendPatch
+          super.generic-arbitrary
+          [ ./generic-arbitrary-export-garbitrary.patch ];
       });
     }
     else packageSet
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