-
Notifications
You must be signed in to change notification settings - Fork 5
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge pull request #61 from ejconlon/ejconlon/default
GenDefault class to derive generators
- Loading branch information
Showing
2 changed files
with
148 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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) |