Split NonDet into Empty & Choose effects

ChangeLog.md

@@ -14,6 +14,8 @@
 
 - Redefines `NonDetC` as a Church-encoded binary tree instead of a Church-encoded list ([#197](https://github.com/fused-effects/fused-effects/pull/197)).
 
+- Removes the `NonDet` effect, replacing it with the combination of the new `Choose` and `Empty` effects ([#199](https://github.com/fused-effects/fused-effects/pull/199)).
+
 # v0.5.0.1
 
 - Adds support for ghc 8.8.1.

benchmark/NonDet/NQueens.hs

@@ -36,15 +36,15 @@ isSafeIn (i,j) qs = null (diags (i,j) `intersect` underThreat)
     qs' = zip [1..length qs] qs
     underThreat = qs' >>= diags
 
-addOne :: (Member NonDet sig, Carrier sig m, Alternative m) => Int -> Board -> m Board
+addOne :: (Carrier sig m, Alternative m) => Int -> Board -> m Board
 addOne n curr = do
   let i = length curr + 1
   let choose = asum . fmap pure
   j <- choose [1..n]
   guard ((i, j) `isSafeIn` curr)
   pure (curr ++ [j])
 
-queens :: (Member NonDet sig, Carrier sig m, Alternative m) => Int -> m Board
+queens :: (Carrier sig m, Alternative m) => Int -> m Board
 queens n = foldl' (>>=) (pure empty) (replicate n (addOne n))
 
 runQueens :: Int -> [Board]
@@ -56,4 +56,3 @@ benchmark = bgroup "N-queens problem"
   , bench "8"  $ whnf runQueens 8
   , bench "16" $ whnf runQueens 16
   ]
-

src/Control/Effect.hs

@@ -11,7 +11,7 @@ import Control.Effect.Error     as X (Error, ErrorC)
 import Control.Effect.Fail      as X (Fail, FailC)
 import Control.Effect.Fresh     as X (Fresh, FreshC)
 import Control.Effect.Lift      as X (Lift, LiftC, runM)
-import Control.Effect.NonDet    as X (NonDet, NonDetC)
+import Control.Effect.NonDet    as X (NonDetC)
 import Control.Effect.Pure      as X (Pure, PureC, run)
 import Control.Effect.Reader    as X (Reader, ReaderC)
 import Control.Effect.Resource  as X (Resource, ResourceC)

src/Control/Effect/Cull.hs

@@ -15,6 +15,8 @@ module Control.Effect.Cull
 ) where
 
 import Control.Effect.Carrier
+import Control.Effect.Choose
+import Control.Effect.Empty
 import Control.Effect.NonDet
 import Control.Effect.Reader
 import Control.Monad (MonadPlus(..))
@@ -24,7 +26,7 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Prelude hiding (fail)
 
--- | 'Cull' effects are used with 'NonDet' to provide control over branching.
+-- | 'Cull' effects are used with 'Choose' to provide control over branching.
 data Cull m k
   = forall a . Cull (m a) (a -> m k)
 
@@ -74,15 +76,15 @@ instance MonadTrans CullC where
   lift = CullC . lift . lift
   {-# INLINE lift #-}
 
-instance (Carrier sig m, Effect sig) => Carrier (Cull :+: NonDet :+: sig) (CullC m) where
-  eff (L (Cull m k))     = CullC (local (const True) (runCullC m)) >>= k
-  eff (R (L Empty))      = empty
-  eff (R (L (Choose k))) = k True <|> k False
-  eff (R (R other))      = CullC (eff (R (R (handleCoercible other))))
+instance (Carrier sig m, Effect sig) => Carrier (Cull :+: Empty :+: Choose :+: sig) (CullC m) where
+  eff (L (Cull m k))         = CullC (local (const True) (runCullC m)) >>= k
+  eff (R (L Empty))          = empty
+  eff (R (R (L (Choose k)))) = k True <|> k False
+  eff (R (R (R other)))      = CullC (eff (R (R (R (handleCoercible other)))))
   {-# INLINE eff #-}
 
 
--- | Run a 'NonDet' effect, returning the first successful result in an 'Alternative' functor.
+-- | Run 'Choose' & 'Empty' effects, returning the first successful result in an 'Alternative' functor.
 --
 --   Unlike 'runNonDet', this will terminate immediately upon finding a solution.
 --
@@ -94,8 +96,8 @@ runNonDetOnce = runNonDet . runCull . cull . runOnceC
 newtype OnceC m a = OnceC { runOnceC :: CullC (NonDetC m) a }
   deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus)
 
-instance (Carrier sig m, Effect sig) => Carrier (NonDet :+: sig) (OnceC m) where
-  eff = OnceC . eff . R . R . handleCoercible
+instance (Carrier sig m, Effect sig) => Carrier (Empty :+: Choose :+: sig) (OnceC m) where
+  eff = OnceC . eff . R . R . R . handleCoercible
   {-# INLINE eff #-}
 
 

src/Control/Effect/Cut.hs

@@ -15,15 +15,17 @@ module Control.Effect.Cut
 , run
 ) where
 
+import Control.Applicative (Alternative(..))
 import Control.Effect.Carrier
-import Control.Effect.NonDet
+import Control.Effect.Choose
+import Control.Effect.Empty
 import Control.Monad (MonadPlus(..))
 import qualified Control.Monad.Fail as Fail
 import Control.Monad.Fix
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 
--- | 'Cut' effects are used with 'NonDet' to provide control over backtracking.
+-- | 'Cut' effects are used with 'Choose' to provide control over backtracking.
 data Cut m k
   = Cutfail
   | forall a . Call (m a) (a -> m k)
@@ -67,7 +69,7 @@ cut = pure () <|> cutfail
 {-# INLINE cut #-}
 
 
--- | Run a 'Cut' effect within an underlying 'Alternative' instance (typically another 'Carrier' for a 'NonDet' effect).
+-- | Run a 'Cut' effect within an underlying 'Alternative' instance (typically another 'Carrier' for 'Choose' & 'Empty' effects).
 --
 --   prop> run (runNonDetOnce (runCut (pure a))) === Just a
 runCut :: Alternative m => CutC m a -> m a
@@ -119,17 +121,18 @@ instance MonadTrans CutC where
   lift m = CutC (\ cons nil _ -> m >>= flip cons nil)
   {-# INLINE lift #-}
 
-instance (Carrier sig m, Effect sig) => Carrier (Cut :+: NonDet :+: sig) (CutC m) where
+instance (Carrier sig m, Effect sig) => Carrier (Cut :+: Empty :+: Choose :+: sig) (CutC m) where
   eff (L Cutfail)    = CutC $ \ _    _   fail -> fail
   eff (L (Call m k)) = CutC $ \ cons nil fail -> runCutC m (\ a as -> runCutC (k a) cons as fail) nil nil
-  eff (R (L Empty))      = empty
-  eff (R (L (Choose k))) = k True <|> k False
-  eff (R (R other)) = CutC $ \ cons nil _ -> eff (handle [()] (fmap concat . traverse runCutAll) other) >>= foldr cons nil
+  eff (R (L Empty))          = empty
+  eff (R (R (L (Choose k)))) = k True <|> k False
+  eff (R (R (R other)))      = CutC $ \ cons nil _ -> eff (handle [()] (fmap concat . traverse runCutAll) other) >>= foldr cons nil
   {-# INLINE eff #-}
 
 
 -- $setup
 -- >>> :seti -XFlexibleContexts
 -- >>> import Test.QuickCheck
 -- >>> import Control.Effect.Cull
+-- >>> import Control.Effect.NonDet
 -- >>> import Control.Effect.Pure

src/Control/Effect/Empty.hs

@@ -53,6 +53,8 @@ instance Applicative m => Applicative (EmptyC m) where
   EmptyC f <*> EmptyC a = EmptyC (liftA2 (<*>) f a)
   {-# INLINE (<*>) #-}
 
+-- $
+--   prop> run (runEmpty empty) === Nothing
 instance Applicative m => Alternative (EmptyC m) where
   empty = EmptyC (pure Nothing)
   {-# INLINE empty #-}

src/Control/Effect/NonDet.hs

@@ -1,37 +1,28 @@
-{-# LANGUAGE DeriveGeneric, DeriveTraversable, FlexibleInstances, MultiParamTypeClasses, RankNTypes, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DeriveTraversable, FlexibleInstances, MultiParamTypeClasses, RankNTypes, TypeOperators, UndecidableInstances #-}
 module Control.Effect.NonDet
-( -- * NonDet effect
-  NonDet(..)
+( -- * Choose effect
+  module Control.Effect.Choose
+  -- * Empty effect
+, module Control.Effect.Empty
   -- * NonDet carrier
 , runNonDet
 , NonDetC(..)
 , oneOf
   -- * Re-exports
 , Alternative(..)
-, Carrier
-, Member
-, run
 ) where
 
 import Control.Applicative (Alternative(..), liftA2)
 import Control.Effect.Carrier
+import Control.Effect.Choose hiding (many, some)
+import Control.Effect.Empty
 import Control.Monad (MonadPlus(..), join)
 import qualified Control.Monad.Fail as Fail
 import Control.Monad.Fix
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Data.Maybe (fromJust)
 import Data.Monoid
-import GHC.Generics (Generic1)
-
-data NonDet m k
-  = Empty
-  | Choose (Bool -> m k)
-  deriving (Functor, Generic1)
-
-instance HFunctor NonDet
-instance Effect   NonDet
-
 
 -- | Run a 'NonDet' effect, collecting all branches’ results into an 'Alternative' functor.
 --
@@ -110,10 +101,10 @@ instance MonadTrans NonDetC where
   lift m = NonDetC (\ _ leaf _ -> m >>= leaf)
   {-# INLINE lift #-}
 
-instance (Carrier sig m, Effect sig) => Carrier (NonDet :+: sig) (NonDetC m) where
-  eff (L Empty)      = empty
-  eff (L (Choose k)) = k True <|> k False
-  eff (R other)      = NonDetC $ \ fork leaf nil -> eff (handle (Leaf ()) (fmap join . traverse runNonDet) other) >>= fold fork leaf nil
+instance (Carrier sig m, Effect sig) => Carrier (Empty :+: Choose :+: sig) (NonDetC m) where
+  eff (L Empty)          = empty
+  eff (R (L (Choose k))) = k True <|> k False
+  eff (R (R other))      = NonDetC $ \ fork leaf nil -> eff (handle (Leaf ()) (fmap join . traverse runNonDet) other) >>= fold fork leaf nil
   {-# INLINE eff #-}