Switch to using FairLogicT in Series and CoSeries

src/Test/SmallCheck/Property.hs

@@ -111,12 +111,16 @@ runProperty depth hook prop =
   flip runReader (Env Forall hook) $
   unProperty prop
 
-atomicProperty :: Series m PropertySuccess -> Series m PropertyFailure -> PropertySeries m
+atomicProperty
+  :: Monad m
+  => Series m PropertySuccess
+  -> Series m PropertyFailure
+  -> PropertySeries m
 atomicProperty s f =
   let prop = PropertySeries s f (pure (Property $ pure prop, []))
   in prop
 
-makeAtomic :: Property m -> Property m
+makeAtomic :: Monad m => Property m -> Property m
 makeAtomic (Property prop) =
   Property $ flip fmap prop $ \ps ->
     atomicProperty (searchExamples ps) (searchCounterExamples ps)
@@ -271,7 +275,7 @@ atMost n m
 ------------------------------
 -- {{{
 
-quantify :: Quantification -> Property m -> Property m
+quantify :: Monad m => Quantification -> Property m -> Property m
 quantify q (Property a) =
   makeAtomic $ Property $ local (\env -> env { quantification = q }) a
 

src/Test/SmallCheck/Series.hs

@@ -231,12 +231,12 @@ data a :-> b = Fun
 
 -- | A simple series specified by a function from depth to the list of
 -- values up to that depth.
-generate :: (Depth -> [a]) -> Series m a
+generate :: Monad m => (Depth -> [a]) -> Series m a
 generate f = do
   d <- getDepth
   msum $ map return $ f d
 
-suchThat :: Series m a -> (a -> Bool) -> Series m a
+suchThat :: Monad m => Series m a -> (a -> Bool) -> Series m a
 suchThat s p = s >>= \x -> if p x then pure x else empty
 
 -- | Return the list of values generated by a 'Series'. Useful for
@@ -270,18 +270,18 @@ uncurry4 :: (a->b->c->d->e) -> ((a,b,c,d)->e)
 uncurry4 f (w,x,y,z) = f w x y z
 
 -- | Run a series with a modified depth
-localDepth :: (Depth -> Depth) -> Series m a -> Series m a
+localDepth :: Monad m => (Depth -> Depth) -> Series m a -> Series m a
 localDepth f (Series a) = Series $ local f a
 
 -- | Run a 'Series' with the depth decreased by 1.
 --
 -- If the current depth is less or equal to 0, the result is 'mzero'.
-decDepth :: Series m a -> Series m a
+decDepth :: Monad m => Series m a -> Series m a
 decDepth a = do
   checkDepth
   localDepth (subtract 1) a
 
-checkDepth :: Series m ()
+checkDepth :: Monad m => Series m ()
 checkDepth = do
   d <- getDepth
   guard $ d > 0
@@ -292,12 +292,12 @@ constM = liftM const
 
 -- | Fix the depth of a series at the current level. The resulting series
 -- will no longer depend on the \"ambient\" depth.
-fixDepth :: Series m a -> Series m (Series m a)
+fixDepth :: Monad m => Series m a -> Series m (Series m a)
 fixDepth s = getDepth >>= \d -> return $ localDepth (const d) s
 
 -- | If the current depth is 0, evaluate the first argument. Otherwise,
 -- evaluate the second argument with decremented depth.
-decDepthChecked :: Series m a -> Series m a -> Series m a
+decDepthChecked :: Monad m => Series m a -> Series m a -> Series m a
 decDepthChecked b r = do
   d <- getDepth
   if d <= 0
@@ -316,7 +316,7 @@ unwind a =
 ------------------------------
 -- {{{
 
-cons0 :: a -> Series m a
+cons0 :: Monad m => a -> Series m a
 cons0 x = decDepth $ pure x
 
 cons1 :: Serial m a => (a->b) -> Series m b
@@ -413,10 +413,10 @@ instance CoSerial m c => GCoSerial m (K1 i c) where
   gCoseries rs = (. unK1) <$> coseries rs
   {-# INLINE gCoseries #-}
 
-instance GSerial m U1 where
+instance Monad m => GSerial m U1 where
   gSeries = pure U1
   {-# INLINE gSeries #-}
-instance GCoSerial m U1 where
+instance Monad m => GCoSerial m U1 where
   gCoseries rs = constM rs
   {-# INLINE gCoseries #-}
 
@@ -442,7 +442,7 @@ instance (Monad m, GCoSerial m a, GCoSerial m b) => GCoSerial m (a :+: b) where
       R1 y -> g y
   {-# INLINE gCoseries #-}
 
-instance GSerial m f => GSerial m (C1 c f) where
+instance (GSerial m f, Monad m) => GSerial m (C1 c f) where
   gSeries = M1 <$> decDepth gSeries
   {-# INLINE gSeries #-}
 -- }}}

src/Test/SmallCheck/Series/Types.hs

@@ -139,7 +139,7 @@ type Depth = Int
 --
 -- It is also desirable that values of smaller depth come before the values
 -- of greater depth.
-newtype Series m a = Series (ReaderT Depth (LogicT m) a)
+newtype Series m a = Series (ReaderT Depth (FairLogicT m) a)
   deriving
     ( Functor
     , Monad
@@ -156,10 +156,10 @@ instance MonadTrans Series where
   lift a = Series $ lift . lift $ a
 
 runSeries :: Depth -> Series m a -> LogicT m a
-runSeries d (Series a) = runReaderT a d
+runSeries d (Series a) = unwrapLogicT $ runReaderT a d
 
 -- | Query the current depth
-getDepth :: Series m Depth
+getDepth :: Monad m => Series m Depth
 getDepth = Series ask
 
 -- }}}
@@ -169,21 +169,21 @@ getDepth = Series ask
 newtype CoSeries m a b = CoSeries
   (StaticArrow (Reader Depth)
   (PartialArrow
-  (StaticArrow (LogicT m) (->))) a b)
+  (StaticArrow (FairLogicT m) (->))) a b)
   deriving (Arrow)
 
-instance Category (CoSeries m) where
+instance Monad m => Category (CoSeries m) where
   id = CoSeries id
   CoSeries a . CoSeries b = CoSeries $ a . b
 
-instance Functor (CoSeries m a) where
+instance Monad m => Functor (CoSeries m a) where
   fmap f a = a >>> arr f
 
-instance Applicative (CoSeries m a) where
+instance Monad m => Applicative (CoSeries m a) where
   pure = unwrapArrow . pure
   f <*> a = unwrapArrow $ WrapArrow f <*> WrapArrow a
 
-nil :: CoSeries m a b
+nil :: Monad m => CoSeries m a b
 nil = CoSeries $
   WrapStatic $ return $ Partial $ WrapMaybe $ WrapStatic $ pure $ const Nothing
 
@@ -193,7 +193,8 @@ toCoSeries (Series s) = CoSeries . WrapStatic $ reader $ \r ->
   in Total $ WrapStatic $ const <$> ls
 
 fromCoSeries
-  :: CoSeries m a b
+  :: Monad m
+  => CoSeries m a b
   -> Series m (Either (Series m (a -> b)) (Series m (a -> Maybe b)))
 fromCoSeries (CoSeries cs) = do
   d <- getDepth
@@ -211,7 +212,7 @@ withDepth mkCs = CoSeries $ WrapStatic $ do
   let CoSeries cs = mkCs d
   unwrapStatic cs
 
-partial :: CoSeries m a (Maybe b) -> CoSeries m a b
+partial :: Monad m => CoSeries m a (Maybe b) -> CoSeries m a b
 partial (CoSeries cs) = CoSeries . WrapStatic . fmap (>>> absorbMaybe) . unwrapStatic $ cs
   where
     absorbMaybe = Partial $ WrapMaybe id