polysemy-check 0.4.0.0 → 0.5.0.0

raw patch · 9 files changed

+333/−296 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−0
• polysemy-check.cabal +2/−3
• src/Polysemy/Check.hs +17/−16
• src/Polysemy/Check/Arbitrary.hs +234/−3
• src/Polysemy/Check/Arbitrary/AnyEff.hs +0/−150
• src/Polysemy/Check/Arbitrary/Generic.hs +0/−100
• src/Polysemy/Check/Arbitrary/Generic.hs-boot +0/−20
• src/Polysemy/Check/Orphans.hs +4/−4
• test/CoverageSpec.hs +64/−0

@@ -1,5 +1,17 @@ # Changelog for polysemy-check +## v0.5.0.0 (2021-10-14)++- Flattened the module structure of `Polysemy.Check.Arbitrary`.+- Fixed a bug where `arbitraryActionFromRowOfType` would return bottom.+- Added an `Arbitrary` instance for `Sem r a`.+- Added tests to prove all generators have a uniform distribution for actions.+- `prepropLaw` now prints the actions it ran before and after your test.+- Changed the orphan `Show` instances for standard Polysemy effects to more+    easily be used for testing coverage.+- Added a `Show` instance for `SomeEffOfType`.+- (Internal) Removed the `GArbitraryKTerm` class+ ## v0.4.0.0 (2021-10-12)  - `GArbitraryK` now supports actions that contain existential types.

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           polysemy-check-version:        0.4.0.0+version:        0.5.0.0 synopsis:       QuickCheck for Polysemy description:    Please see the README on GitHub at <https://github.com/polysemy-research/polysemy-check#readme> category:       Polysemy@@ -30,8 +30,6 @@       Generics.Kind.Unexported       Polysemy.Check       Polysemy.Check.Arbitrary-      Polysemy.Check.Arbitrary.AnyEff-      Polysemy.Check.Arbitrary.Generic       Polysemy.Check.Orphans       Polysemy.Internal.Union.Inject   other-modules:@@ -71,6 +69,7 @@   main-is: Main.hs   other-modules:       CommutativeSpec+      CoverageSpec       EquivSpec       LawSpec       WeirdEffectsSpec

@@ -38,8 +38,6 @@ import Generics.Kind.TH (deriveGenericK) import Polysemy import Polysemy.Check.Arbitrary-import Polysemy.Check.Arbitrary.AnyEff-import Polysemy.Check.Arbitrary.Generic (GArbitraryK, ExistentialFor) import Polysemy.Check.Orphans () import Polysemy.Internal import Polysemy.Internal.Union.Inject (Inject, inject)@@ -124,20 +122,23 @@   SomeEff pre <- arbitraryActionFromRow @effs @r   (m1, m2) <- g   SomeEff post <- arbitraryActionFromRow @effs @r-  pure $ ioProperty $ do-    a1 <--      lower $ do-        void $ send pre-        a1 <- m1-        r <- send post-        pure (a1, r)-    a2 <--      lower $ do-        void $ send pre-        a2 <- m2-        r <- send post-        pure (a2, r)-    pure $ a1 === a2+  pure $+    counterexample ("before = " <> show pre) $+    counterexample ("after  = " <> show post) $+      ioProperty $ do+        a1 <-+          lower $ do+            void $ send pre+            a1 <- m1+            r <- send post+            pure (a1, r)+        a2 <-+          lower $ do+            void $ send pre+            a2 <- m2+            r <- send post+            pure (a2, r)+        pure $ a1 === a2   ------------------------------------------------------------------------------

@@ -1,13 +1,108 @@+{-# OPTIONS_GHC -Wno-orphans #-}+ module Polysemy.Check.Arbitrary where -import Generics.Kind+import Control.Applicative (liftA2)+import Data.Kind (Type)+import GHC.Exts (type (~~))+import Generics.Kind hiding (SubstRep)+import Generics.Kind.Unexported import Polysemy-import Polysemy.Check.Arbitrary.AnyEff-import Polysemy.Check.Arbitrary.Generic+import Polysemy.Internal import Test.QuickCheck   ------------------------------------------------------------------------------+-- | Data family for the instantiation of existential variables. If you want to+-- check properties for an effect @e@ that contains an existential type, the+-- synthesized 'Arbitrary' instance will instantiate all of @e@'s existential+-- types at @'ExistentialFor' e@.+--+-- @'ExistentialFor' e@ must have instances for every dictionary required by+-- @e@, and will likely require an 'Arbitrary' instance.+data family ExistentialFor (e :: Effect)+++------------------------------------------------------------------------------+-- | Given @'GArbitraryK' e ('RepK' e) r a@, this typeclass computes+-- generators for every well-typed constructor of @e (Sem r) a@. It is capable+-- of building generators for GADTs.+class GArbitraryK (e :: Effect) (f :: LoT Effect -> Type) (r :: EffectRow) (a :: Type)  where+  garbitraryk :: [Gen (f (LoT2 (Sem r) a))]++instance GArbitraryK e U1 r a where+  garbitraryk = pure $ pure U1++instance (GArbitraryK e f r a, GArbitraryK e g r a) => GArbitraryK e (f :*: g) r a where+  garbitraryk = liftA2 (liftA2 (:*:)) (garbitraryk @e) (garbitraryk @e)++instance Arbitrary (Interpret f (LoT2 (Sem r) a)) => GArbitraryK e (Field f) r a where+  garbitraryk = pure $ fmap Field arbitrary++instance+    ( GArbitraryK e (SubstRep f (ExistentialFor e)) r a+    , SubstRep' f (ExistentialFor e) (LoT2 (Sem r) a)+    ) => GArbitraryK e (Exists Type f) r a where+  garbitraryk = fmap (Exists . unsubstRep @_ @_ @_ @(ExistentialFor e)) <$>+    garbitraryk @e @(SubstRep f (ExistentialFor e)) @r @a++instance (GArbitraryK e f r a, GArbitraryK e g r a) => GArbitraryK e (f :+: g) r a where+  garbitraryk = fmap (fmap L1) (garbitraryk @e @f)+             <> fmap (fmap R1) (garbitraryk @e @g)++instance (Interpret c (LoT2 (Sem r) a), GArbitraryK e f r a) => GArbitraryK e (c :=>: f) r a where+  garbitraryk = fmap (fmap SuchThat) (garbitraryk @e @f)++instance {-# OVERLAPPING #-} GArbitraryK e (c1 :=>: (c2 :=>: f)) r a+    => GArbitraryK e ((c1 ':&: c2) :=>: f) r a where+  garbitraryk =+    fmap+      ((\(SuchThat (SuchThat x)) -> SuchThat x)+            :: (c1 :=>: (c2 :=>: f)) x -> ((c1 ':&: c2) :=>: f) x)+        <$> garbitraryk @e++instance {-# OVERLAPPING #-} GArbitraryK e f r a => GArbitraryK e ('Kon ((~~) a) ':@: Var1 :=>: f) r a where+  garbitraryk = fmap SuchThat <$> garbitraryk @e @f++instance {-# OVERLAPPING #-} GArbitraryK e f r a => GArbitraryK e ('Kon (~~) ':@: Var1 ':@: 'Kon a :=>: f) r a where+  garbitraryk = fmap SuchThat <$> garbitraryk @e @f++instance {-# INCOHERENT #-} GArbitraryK e ('Kon ((~~) b) ':@: Var1 :=>: f) r a where+  garbitraryk = []++instance {-# INCOHERENT #-} GArbitraryK e ('Kon (~~) ':@: Var1 ':@: 'Kon b :=>: f) r a where+  garbitraryk = []++instance (GArbitraryK e f r a) => GArbitraryK e (M1 _1 _2 f) r a where+  garbitraryk = fmap M1 <$> garbitraryk @e++------------------------------------------------------------------------------++instance (Arbitrary a, ArbitraryEff r r, ArbitraryEffOfType a r r)+      => Arbitrary (Sem r a) where+  arbitrary =+    let terminal = [pure <$> arbitrary]+     in sized $ \n ->+          case n <= 1 of+            True -> oneof terminal+            False -> oneof $+              [ do+                  SomeEffOfType e <- arbitraryActionFromRowOfType @r @r @a+                  pure $ send e+              , do+                  SomeEff e <- arbitraryActionFromRow @r @r+                  k <- liftArbitrary $ scale (`div` 2) arbitrary+                  pure $ send e >>= k+              ] <> terminal++------------------------------------------------------------------------------+-- | @genEff \@e \@r \@a@ gets a generator capable of producing every+-- well-typed GADT constructor of @e (Sem r) a@.+genEff :: forall e r a. (GenericK e, GArbitraryK e (RepK e) r a) => Gen (e (Sem r) a)+genEff = fmap toK $ oneof $ garbitraryk @e @(RepK e) @r+++------------------------------------------------------------------------------ -- | Generate any action for effect @e@. arbitraryAction     :: forall e r@@ -45,4 +140,140 @@     => Gen (SomeEffOfType r a)        -- ^ arbitraryActionFromRowOfType = oneof $ genSomeEffOfType @a @effs @r+++------------------------------------------------------------------------------+-- | Helper function for implementing 'GTypesOf'+type family GTypesOf (f :: LoT Effect -> Type) :: [Type] where+  GTypesOf (M1 _1 _2 f) = GTypesOf f+  GTypesOf (f :+: g) = Append (GTypesOf f) (GTypesOf g)+  GTypesOf (('Kon (~~) ':@: Var1 ':@: 'Kon a) :=>: f) = '[a]+  GTypesOf (('Kon ((~~) a) ':@: Var1) :=>: f) = '[a]+  -- Otherwise, we don't have any constraints on @a@, so we can instantiate it+  -- how we please. Just assume ().+  GTypesOf _1 = '[()]+++------------------------------------------------------------------------------+-- | @'TypesOf' e@ is a list of every type that can be bound via @e@'s actions.+--+-- For example, given:+--+-- @+-- data MyEffect m a where+--   Foo :: MyEffect m Int+--   Blah :: Bool -> MyEffect m String+-- @+--+-- the result of @'TypesOf' MyEffect@ is @'[Int, String]@.+type TypesOf (e :: Effect) = GTypesOf (RepK e)+++------------------------------------------------------------------------------+-- | @'SomeAction' e r@ is some action for effect @e@ in effect row @r@.+data SomeAction e (r :: EffectRow) where+  SomeAction+      :: (Member e r, Eq a, Show a, CoArbitrary a, Show (e (Sem r) a))+      => e (Sem r) a+         -- ^+      -> SomeAction e r+         -- ^++instance Show (SomeAction e r) where+  show (SomeAction ema) = show ema+++------------------------------------------------------------------------------+-- | @'SomeEff' r@ is some action for some effect in the effect row @r@.+data SomeEff (r :: EffectRow) where+  SomeEff+      :: (Member e r, Eq a, Show a, CoArbitrary a, Show (e (Sem r) a))+      => e (Sem r) a+         -- ^+      -> SomeEff r+         -- ^++instance Show (SomeEff r) where+  show (SomeEff sse) = show sse+++------------------------------------------------------------------------------+-- | @'SomeEff' r@ is some action for some effect in the effect row @r@.+data SomeEffOfType (r :: EffectRow) a where+  SomeEffOfType+      :: (Member e r, Eq a, Show a, CoArbitrary a, Show (e (Sem r) a))+      => e (Sem r) a+         -- ^+      -> SomeEffOfType r a+         -- ^++instance Show (SomeEffOfType r a) where+  show (SomeEffOfType sse) = show sse+++------------------------------------------------------------------------------+-- | @'ArbitraryEff' es r@ lets you randomly generate an action in any of+-- the effects @es@.+class ArbitraryEff (es :: EffectRow) (r :: EffectRow) where+  genSomeEff :: [Gen (SomeEff r)]++instance ArbitraryEff '[] r where+  genSomeEff = []++instance+    (ArbitraryEff es r, ArbitraryAction (TypesOf e) e r)+    => ArbitraryEff (e ': es) r+    where+  genSomeEff = fmap (fmap (\(SomeAction e) -> SomeEff e)) (genSomeAction @(TypesOf e) @e @r)+             <> genSomeEff @es @r+++------------------------------------------------------------------------------+-- | @'ArbitraryEffOfType' a es r@ lets you randomly generate an action in any of+-- the effects @es@ that produces type @a@.+class ArbitraryEffOfType (a :: Type) (es :: EffectRow) (r :: EffectRow) where+  genSomeEffOfType :: [Gen (SomeEffOfType r a)]++instance ArbitraryEffOfType a '[] r where+  genSomeEffOfType = []++instance+    ( Eq a+    , Show a+    , Show (e (Sem r) a)+    , ArbitraryEffOfType a es r+    , GenericK e+    , GArbitraryK e (RepK e) r a+    , CoArbitrary a+    , Member e r+    )+    => ArbitraryEffOfType a (e ': es) r+    where+  genSomeEffOfType+    = (fmap (SomeEffOfType @e @r . toK) <$> garbitraryk @e @(RepK e) @r)+    <> genSomeEffOfType @a @es @r+++------------------------------------------------------------------------------+-- | @'ArbitraryAction' as e r@ lets you randomly generate an action+-- producing any type in @as@ from the effect @e@.+class ArbitraryAction (as :: [Type]) (e :: Effect) (r :: EffectRow) where+  genSomeAction :: [Gen (SomeAction e r)]++instance ArbitraryAction '[] e r where+  genSomeAction = []++instance+    ( ArbitraryAction as e r+    , Eq a+    , Show a+    , Member e r+    , Show (e (Sem r) a)+    , GenericK e+    , CoArbitrary a+    , GArbitraryK e (RepK e) r a+    )+    => ArbitraryAction (a : as) e r+    where+  genSomeAction = (fmap SomeAction $ genEff @e @r @a) : genSomeAction @as @e @r 

@@ -1,150 +0,0 @@-module Polysemy.Check.Arbitrary.AnyEff where--import Data.Kind (Type, Constraint)-import GHC.Exts (type (~~))-import Generics.Kind-import Polysemy-import Polysemy.Internal-import {-# SOURCE #-} Polysemy.Check.Arbitrary.Generic-import Test.QuickCheck------------------------------------------------------------------------------------ | Helper function for implementing 'GTypesOf'-type family GTypesOf (f :: LoT Effect -> Type) :: [Type] where-  GTypesOf (M1 _1 _2 f) = GTypesOf f-  GTypesOf (f :+: g) = Append (GTypesOf f) (GTypesOf g)-  GTypesOf (('Kon (~~) ':@: Var1 ':@: 'Kon a) :=>: f) = '[a]-  GTypesOf (('Kon ((~~) a) ':@: Var1) :=>: f) = '[a]-  -- Otherwise, we don't have any constraints on @a@, so we can instantiate it-  -- how we please. Just assume ().-  GTypesOf _1 = '[()]------------------------------------------------------------------------------------ | @'TypesOf' e@ is a list of every type that can be bound via @e@'s actions.------ For example, given:------ @--- data MyEffect m a where---   Foo :: MyEffect m Int---   Blah :: Bool -> MyEffect m String--- @------ the result of @'TypesOf' MyEffect@ is @'[Int, String]@.-type TypesOf (e :: Effect) = GTypesOf (RepK e)------------------------------------------------------------------------------------ | A type family that expands to a 'GArbitraryK' constaint for every type in--- the first list.-type family ArbitraryForAll (e :: Effect) (as :: [Type]) (r :: EffectRow) :: Constraint where-  ArbitraryForAll e '[] f = ()-  ArbitraryForAll e (a ': as) r =-    (Eq a, Show a, GArbitraryK e (RepK e) r a, ArbitraryForAll e as r)------------------------------------------------------------------------------------ | @'SomeAction' e r@ is some action for effect @e@ in effect row @r@.-data SomeAction e (r :: EffectRow) where-  SomeAction-      :: (Member e r, Eq a, Show a, CoArbitrary a, Show (e (Sem r) a))-      => e (Sem r) a-         -- ^-      -> SomeAction e r-         -- ^--instance Show (SomeAction e r) where-  show (SomeAction ema) = show ema--instance Show (SomeEff r) where-  show (SomeEff sse) = show sse------------------------------------------------------------------------------------ | @'SomeEff' r@ is some action for some effect in the effect row @r@.-data SomeEff (r :: EffectRow) where-  SomeEff-      :: (Member e r, Eq a, Show a, CoArbitrary a, Show (e (Sem r) a))-      => e (Sem r) a-         -- ^-      -> SomeEff r-         -- ^----------------------------------------------------------------------------------- | @'SomeEff' r@ is some action for some effect in the effect row @r@.-data SomeEffOfType (r :: EffectRow) a where-  SomeEffOfType-      :: (Member e r, Eq a, Show a, CoArbitrary a, Show (e (Sem r) a))-      => e (Sem r) a-         -- ^-      -> SomeEffOfType r a-         -- ^------------------------------------------------------------------------------------ | @'ArbitraryEff' es r@ lets you randomly generate an action in any of--- the effects @es@.-class ArbitraryEff (es :: EffectRow) (r :: EffectRow) where-  genSomeEff :: [Gen (SomeEff r)]--instance ArbitraryEff '[] r where-  genSomeEff = []--instance-    (ArbitraryEff es r, ArbitraryAction (TypesOf e) e r)-    => ArbitraryEff (e ': es) r-    where-  genSomeEff = fmap (fmap (\(SomeAction e) -> SomeEff e)) (genSomeAction @(TypesOf e) @e @r)-             <> genSomeEff @es @r----------------------------------------------------------------------------------- | @'ArbitraryEffOfType' a es r@ lets you randomly generate an action in any of--- the effects @es@ that produces type @a@.-class ArbitraryEffOfType (a :: Type) (es :: EffectRow) (r :: EffectRow) where-  genSomeEffOfType :: [Gen (SomeEffOfType r a)]--instance ArbitraryEffOfType a '[] r where-  genSomeEffOfType = []--instance-    ( Eq a-    , Show a-    , Show (e (Sem r) a)-    , ArbitraryEffOfType a es r-    , GenericK e-    , GArbitraryK e (RepK e) r a-    , CoArbitrary a-    , Member e r-    )-    => ArbitraryEffOfType a (e ': es) r-    where-  genSomeEffOfType-    = fmap SomeEffOfType (genEff @e @r @a)-    : genSomeEffOfType @a @es @r------------------------------------------------------------------------------------ | @'ArbitraryAction' as e r@ lets you randomly generate an action--- producing any type in @as@ from the effect @e@.-class ArbitraryAction (as :: [Type]) (e :: Effect) (r :: EffectRow) where-  genSomeAction :: [Gen (SomeAction e r)]--instance ArbitraryAction '[] e r where-  genSomeAction = []--instance-    ( ArbitraryAction as e r-    , Eq a-    , Show a-    , Member e r-    , Show (e (Sem r) a)-    , GenericK e-    , CoArbitrary a-    , GArbitraryK e (RepK e) r a-    )-    => ArbitraryAction (a : as) e r-    where-  genSomeAction = (fmap SomeAction $ genEff @e @r @a) : genSomeAction @as @e @r-

@@ -1,100 +0,0 @@-module Polysemy.Check.Arbitrary.Generic where--import Control.Applicative (liftA2)-import Data.Kind (Type)-import GHC.Exts (type (~~))-import Generics.Kind hiding (SubstRep)-import Generics.Kind.Unexported-import Polysemy-import Polysemy.Check.Arbitrary.AnyEff-import Polysemy.Internal (send)-import Test.QuickCheck------------------------------------------------------------------------------------ | Data family for the instantiation of existential variables. If you want to--- check properties for an effect @e@ that contains an existential type, the--- synthesized 'Arbitrary' instance will instantiate all of @e@'s existential--- types at @'ExistentialFor' e@.------ @'ExistentialFor' e@ must have instances for every dictionary required by--- @e@, and will likely require an 'Arbitrary' instance.-data family ExistentialFor (e :: Effect)------------------------------------------------------------------------------------ | Given @'GArbitraryK' a ('RepK' e) r a@, this typeclass computes--- generators for every well-typed constructor of @e (Sem r) a@. It is capable--- of building generators for GADTs.-class GArbitraryK (e :: Effect) (f :: LoT Effect -> Type) (r :: EffectRow) (a :: Type)  where-  garbitraryk :: [Gen (f (LoT2 (Sem r) a))]--instance GArbitraryK e U1 r a where-  garbitraryk = pure $ pure U1--instance (GArbitraryK e f r a, GArbitraryK e g r a) => GArbitraryK e (f :*: g) r a where-  garbitraryk = liftA2 (liftA2 (:*:)) (garbitraryk @e) (garbitraryk @e)--instance GArbitraryKTerm (Interpret f (LoT2 (Sem r) a)) => GArbitraryK e (Field f) r a where-  garbitraryk = pure $ fmap Field $ garbitrarykterm @(Interpret f (LoT2 (Sem r) a))--instance-    ( GArbitraryK e (SubstRep f (ExistentialFor e)) r a-    , SubstRep' f (ExistentialFor e) (LoT2 (Sem r) a)-    ) => GArbitraryK e (Exists Type f) r a where-  garbitraryk = fmap (Exists . unsubstRep @_ @_ @_ @(ExistentialFor e)) <$>-    garbitraryk @e @(SubstRep f (ExistentialFor e)) @r @a--instance (GArbitraryK e f r a, GArbitraryK e g r a) => GArbitraryK e (f :+: g) r a where-  garbitraryk = fmap (fmap L1) (garbitraryk @e @f)-             <> fmap (fmap R1) (garbitraryk @e @g)--instance (Interpret c (LoT2 (Sem r) a), GArbitraryK e f r a) => GArbitraryK e (c :=>: f) r a where-  garbitraryk = fmap (fmap SuchThat) (garbitraryk @e @f)--instance {-# OVERLAPPING #-} GArbitraryK e (c1 :=>: (c2 :=>: f)) r a-    => GArbitraryK e ((c1 ':&: c2) :=>: f) r a where-  garbitraryk =-    fmap-      ((\(SuchThat (SuchThat x)) -> SuchThat x)-            :: (c1 :=>: (c2 :=>: f)) x -> ((c1 ':&: c2) :=>: f) x)-        <$> garbitraryk @e--instance {-# OVERLAPPING #-} GArbitraryK e f r a => GArbitraryK e ('Kon ((~~) a) ':@: Var1 :=>: f) r a where-  garbitraryk = fmap SuchThat <$> garbitraryk @e @f--instance {-# OVERLAPPING #-} GArbitraryK e f r a => GArbitraryK e ('Kon (~~) ':@: Var1 ':@: 'Kon a :=>: f) r a where-  garbitraryk = fmap SuchThat <$> garbitraryk @e @f--instance {-# INCOHERENT #-} GArbitraryK e ('Kon ((~~) b) ':@: Var1 :=>: f) r a where-  garbitraryk = []--instance {-# INCOHERENT #-} GArbitraryK e ('Kon (~~) ':@: Var1 ':@: 'Kon b :=>: f) r a where-  garbitraryk = []--instance (GArbitraryK e f r a) => GArbitraryK e (M1 _1 _2 f) r a where-  garbitraryk = fmap M1 <$> garbitraryk @e------------------------------------------------------------------------------------ | @genEff \@e \@r \@a@ gets a generator capable of producing every--- well-typed GADT constructor of @e (Sem r) a@.-genEff :: forall e r a. (GenericK e, GArbitraryK e (RepK e) r a) => Gen (e (Sem r) a)-genEff = fmap toK $ oneof $ garbitraryk @e @(RepK e) @r----class GArbitraryKTerm (t :: Type) where-  garbitrarykterm :: Gen t--instance {-# OVERLAPPING #-} ArbitraryEffOfType a r r => GArbitraryKTerm (Sem r a) where-  garbitrarykterm = do-    SomeEffOfType act <- oneof $ genSomeEffOfType @a @r @r-    pure $ send act--instance {-# OVERLAPPING #-} (CoArbitrary a, GArbitraryKTerm b) => GArbitraryKTerm (a -> b) where-  garbitrarykterm = liftArbitrary garbitrarykterm--instance Arbitrary a => GArbitraryKTerm a where-  garbitrarykterm = arbitrary-

@@ -1,20 +0,0 @@-module Polysemy.Check.Arbitrary.Generic where--import Data.Kind (Type)-import Generics.Kind-import Test.QuickCheck-import Polysemy------------------------------------------------------------------------------------ | Given @'GArbitraryK' a ('RepK' (e m a))@, this typeclass computes--- generators for every well-typed constructor of @e m a@. It is capable of--- building generators for GADTs.-class GArbitraryK (e :: Effect) (f :: LoT Effect -> Type) (r :: EffectRow) (a :: Type)  where-  garbitraryk :: [Gen (f (LoT2 (Sem r) a))]----------------------------------------------------------------------------------- | @genEff \@e \@a \@m@ gets a generator capable of producing every--- well-typed GADT constructor of @e m a@.-genEff :: forall e r a. (GenericK e, GArbitraryK e (RepK e) r a) => Gen (e (Sem r) a)-

@@ -41,14 +41,14 @@  instance Show e => Show (Error e (Sem r) a) where   show (Throw e2) = "Throw " <> show e2-  show (Catch _ _) = "<Catch>"+  show (Catch _ _) = "Catch <m> <k>"  instance Show (Reader e (Sem r) a) where   show Ask = "Ask"-  show (Local _ _) = "<Local>"+  show (Local _ _) = "Local <f> <m>"  instance Show e => Show (Writer e (Sem r) a) where   show (Tell e) = "Tell " <> show e-  show (Listen _) = "<Listen>"-  show (Pass _) = "<Pass>"+  show (Listen _) = "Listen <m>"+  show (Pass _) = "Pass <m>" 

@@ -0,0 +1,64 @@+module CoverageSpec where++import Polysemy.Check+import Polysemy.Error+import Polysemy.Input+import Polysemy.Output+import Polysemy.State+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++data Test m a where+  Test1 :: Test m ()+  Test2 :: Int -> Test m ()+  Test3 :: Test m Int+  Test4 :: Test m Bool++deriving instance Show (Test m a)+deriveGenericK ''Test+++spec :: Spec+spec = do+  prop "arbitraryAction has a uniform probabilty" $ checkCoverage $ do+    e <- arbitraryAction @Test @'[Test]+    checkUniformProbability 4 e++  prop "arbitraryActionOfType has a uniform probability" $ checkCoverage $ do+    e <- arbitraryActionOfType @Test @()+    checkUniformProbability 2 e++  prop "arbitraryActionFromRow has a uniform probability (small row)" $ checkCoverage $ do+    e <- arbitraryActionFromRow @LittleRow @LittleRow+    checkUniformProbability 6 e++  prop "arbitraryActionFromRow has a uniform probability (large row)" $ checkCoverage $ do+    e <- arbitraryActionFromRow @BigRow @BigRow+    checkUniformProbability 10 e++  prop "arbitraryActionFromRowOfType has a uniform probability (Int)" $ checkCoverage $ do+    e <- arbitraryActionFromRowOfType @BigRow @BigRow @Int+    checkUniformProbability 5 e++  prop "arbitraryActionFromRowOfType has a uniform probability (())" $ checkCoverage $ do+    e <- arbitraryActionFromRowOfType @BigRow @BigRow @()+    checkUniformProbability 6 e+++type LittleRow = '[State Int, Test]+type BigRow = '[Error Int, Input Int, Output Int, State Int, Test]+++------------------------------------------------------------------------------+-- | @checkUniformProbability n a@ ensures that @a@ gets generated with+-- probability $\frac{1}{n}$.+checkUniformProbability :: (Applicative f, Show a) => Double -> a -> f Property+checkUniformProbability n e = pure $ cover (100 / n) True (constructor e) True+++------------------------------------------------------------------------------+-- | Get the constructor name (from a derived Show instance)+constructor :: Show a => a -> String+constructor = unwords . take 1 . words . show+