GenDefault class to derive generators

lib/src/Test/Falsify/GenDefault.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | This module defines something similar to QuickCheck's Arbitrary class along with
+-- some DerivingVia helpers. Our version, 'GenDefault', allows one to choose between
+-- sets of default generators with a user-defined tag. See 'Test.Falsify.GenDefault.Std' for
+-- the standard tag with a few useful instances.
+module Test.Falsify.GenDefault
+  ( GenDefault (..)
+  , ViaTag (..)
+  , ViaIntegral (..)
+  , ViaEnum (..)
+  , ViaList (..)
+  , ViaString (..)
+  , ViaGeneric (..)
+  ) where
+
+import Control.Applicative (liftA2)
+import Data.Proxy (Proxy (..))
+import GHC.Generics (Generic (..), K1 (..), M1 (..), U1 (..), (:+:) (..), (:*:) (..))
+import Test.Falsify.Generator (Gen)
+import qualified Test.Falsify.Generator as Gen
+import qualified Test.Falsify.Range as Range
+import Data.Bits (FiniteBits)
+import GHC.Exts (IsList (..), IsString (..))
+import GHC.TypeLits (KnownNat, natVal, Nat)
+
+class GenDefault tag a where
+  -- | Default generator for @a@
+  --
+  -- The type-level @tag@ allows types @a@ to have multiple defaults.
+  genDefault :: Proxy tag -> Gen a
+
+-- | DerivingVia wrapper for types with default instances under other tags
+newtype ViaTag tag' a = ViaTag {unViaTag :: a}
+
+instance GenDefault tag' a => GenDefault tag (ViaTag tag' a) where
+  genDefault _ = fmap ViaTag (genDefault @tag' Proxy)
+
+-- | DerivingVia wrapper for Integral types
+newtype ViaIntegral a = ViaIntegral {unViaIntegral :: a}
+
+instance (Integral a, FiniteBits a, Bounded a) => GenDefault tag (ViaIntegral a) where
+  genDefault _ = fmap ViaIntegral (Gen.inRange (Range.between (minBound, maxBound)))
+
+-- | DerivingVia wrapper for Enum types
+newtype ViaEnum a = ViaEnum {unViaEnum :: a}
+
+instance (Enum a, Bounded a) => GenDefault tag (ViaEnum a) where
+  genDefault _ = fmap ViaEnum (Gen.inRange (Range.enum (minBound, maxBound)))
+
+-- | DerivingVia wrapper for FromList types
+newtype ViaList l (mn :: Nat) (mx :: Nat) = ViaList {unViaList :: l}
+
+instance (IsList l, GenDefault tag (Item l), KnownNat mn, KnownNat mx) => GenDefault tag (ViaList l mn mx) where
+  genDefault p =
+    let bn = fromInteger (natVal (Proxy @mn))
+        bx = fromInteger (natVal (Proxy @mx))
+    in fmap (ViaList . fromList) (Gen.list (Range.between (bn, bx)) (genDefault p))
+
+-- | DerivingVia wrapper for FromString types
+newtype ViaString s (mn :: Nat) (mx :: Nat) = ViaString {unViaString :: s}
+
+instance (IsString s, GenDefault tag Char, KnownNat mn, KnownNat mx) => GenDefault tag (ViaString s mn mx) where
+  genDefault p =
+    let bn = fromInteger (natVal (Proxy @mn))
+        bx = fromInteger (natVal (Proxy @mx))
+    in fmap (ViaString . fromString) (Gen.list (Range.between (bn, bx)) (genDefault p))
+
+class GGenDefault tag f where
+  ggenDefault :: Proxy tag -> Gen (f a)
+
+instance GGenDefault tag U1 where
+  ggenDefault _ = pure U1
+
+instance GGenDefault tag a => GGenDefault tag (M1 i c a) where
+  ggenDefault = fmap M1 . ggenDefault
+
+instance (GGenDefault tag a, GGenDefault tag b) => GGenDefault tag (a :*: b) where
+  ggenDefault p = liftA2 (:*:) (ggenDefault p) (ggenDefault p)
+
+instance (GGenDefault tag a, GGenDefault tag b) => GGenDefault tag (a :+: b) where
+  ggenDefault p = Gen.choose (fmap L1 (ggenDefault p)) (fmap R1 (ggenDefault p))
+
+instance GenDefault tag a => GGenDefault tag (K1 i a) where
+  ggenDefault = fmap K1 . genDefault
+
+-- | DerivingVia wrapper for Generic types
+newtype ViaGeneric tag a = ViaGeneric {unViaGeneric :: a}
+
+instance (Generic t, GGenDefault tag (Rep t)) => GenDefault tag (ViaGeneric tag t) where
+  genDefault = fmap (ViaGeneric . to) . ggenDefault

lib/src/Test/Falsify/GenDefault/Std.hs

@@ -0,0 +1,57 @@
+module Test.Falsify.GenDefault.Std
+  ( Std
+  ) where
+
+import Test.Falsify.GenDefault (ViaIntegral (..), GenDefault, ViaEnum (..), ViaGeneric (..))
+import Data.Int (Int8, Int16, Int32, Int64)
+import Data.Word (Word8, Word16, Word32, Word64)
+
+-- | Type tag for these "standard" default generators.
+-- You can use this tag directly or choose type-by-type with 'ViaTag'.
+data Std
+
+deriving via (ViaEnum ()) instance GenDefault Std ()
+deriving via (ViaEnum Bool) instance GenDefault Std Bool
+deriving via (ViaEnum Char) instance GenDefault Std Char
+
+deriving via (ViaIntegral Int) instance GenDefault Std Int
+deriving via (ViaIntegral Int8) instance GenDefault Std Int8
+deriving via (ViaIntegral Int16) instance GenDefault Std Int16
+deriving via (ViaIntegral Int32) instance GenDefault Std Int32
+deriving via (ViaIntegral Int64) instance GenDefault Std Int64
+
+deriving via (ViaIntegral Word) instance GenDefault Std Word
+deriving via (ViaIntegral Word8) instance GenDefault Std Word8
+deriving via (ViaIntegral Word16) instance GenDefault Std Word16
+deriving via (ViaIntegral Word32) instance GenDefault Std Word32
+deriving via (ViaIntegral Word64) instance GenDefault Std Word64
+
+deriving via (ViaGeneric Std (Maybe a))
+  instance GenDefault Std a => GenDefault Std (Maybe a)
+
+deriving via (ViaGeneric Std (Either a b))
+  instance (GenDefault Std a, GenDefault Std b) => GenDefault Std (Either a b)
+
+deriving via
+  (ViaGeneric Std (a, b))
+  instance
+    (GenDefault Std a, GenDefault Std b)
+    => GenDefault Std (a, b)
+
+deriving via
+  (ViaGeneric Std (a, b, c))
+  instance
+    (GenDefault Std a, GenDefault Std b, GenDefault Std c)
+    => GenDefault Std (a, b, c)
+
+deriving via
+  (ViaGeneric Std (a, b, c, d))
+  instance
+    (GenDefault Std a, GenDefault Std b, GenDefault Std c, GenDefault Std d)
+    => GenDefault Std (a, b, c, d)
+
+deriving via
+  (ViaGeneric Std (a, b, c, d, e))
+  instance
+    (GenDefault Std a, GenDefault Std b, GenDefault Std c, GenDefault Std d, GenDefault Std e)
+    => GenDefault Std (a, b, c, d, e)