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.
This commit is contained in:
Griffin Smith 2019-11-29 22:57:58 -05:00
parent 0abcd8c958
commit 7d8ce026a2
5 changed files with 47 additions and 4 deletions

View file

@ -1,8 +1,11 @@
{ nixpkgs ? import ./nixpkgs.nix {}, compiler ? "ghc865" }: { nixpkgs ? import ./nixpkgs.nix {}
, compiler ? "ghc865" }:
let let
inherit (nixpkgs) pkgs; inherit (nixpkgs) pkgs;
all-hies = import (fetchTarball "https://github.com/infinisil/all-hies/tarball/master") {}; all-hies = import (fetchTarball "https://github.com/infinisil/all-hies/tarball/master") {};
hie = all-hies.selection { selector = p: { inherit (p) ghc865; }; }; 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 in
xanthous // { inherit hie; } xanthous // { inherit hie; }

View file

@ -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

7
haskell-overlay.nix Normal file
View file

@ -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 ];
}

View file

@ -8,7 +8,9 @@ let
if compiler == "default" if compiler == "default"
then pkgs.haskellPackages then pkgs.haskellPackages
else pkgs.haskell.packages.${compiler} else pkgs.haskell.packages.${compiler}
); ).override {
overrides = import ./haskell-overlay.nix { inherit nixpkgs; };
};
haskellPackages = ( haskellPackages = (
if withHoogle if withHoogle
@ -16,6 +18,10 @@ let
overrides = (self: super: { overrides = (self: super: {
ghc = super.ghc // { withPackages = super.ghc.withHoogle; }; ghc = super.ghc // { withPackages = super.ghc.withHoogle; };
ghcWithPackages = self.ghc.withPackages; 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 else packageSet

View file

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