Simplified eliminators

ChangeLog.md

@@ -28,6 +28,12 @@
 
 - Removes the re-export of `Member` from all carrier modules, re-exporting `Has` in its place. `Has` constraints should generally be used instead, and specialist cases can import `Control.Effect.Sum` for `Member`. ([#217](https://github.com/fused-effects/fused-effects/pull/217))
 
+- Redesigns & renames the handlers for church-encoded nondeterminism carriers to standardize naming and usage patterns. ([#207](https://github.com/fused-effects/fused-effects/pull/207))
+  - The primary handlers (`runChoose`, `runNonDet`, `runCut`, `runCull`) take multiple continuations.
+  - Handlers which return an `Alternative` are suffixed with `A`, e.g. `runNonDetA`.
+  - Handlers which return a `Monoid` are suffixed with `M`, e.g. `runNonDetM`.
+  - Handlers which return a `Semigroup` are suffixed with `S`, e.g. `runChooseS`.
+
 # v0.5.0.1
 
 - Adds support for ghc 8.8.1.

src/Control/Carrier/Choose/Church.hs

@@ -4,6 +4,7 @@ module Control.Carrier.Choose.Church
   module Control.Effect.Choose
   -- * Choose carrier
 , runChoose
+, runChooseS
 , ChooseC(..)
   -- * Re-exports
 , Carrier
@@ -25,6 +26,9 @@ import Prelude hiding (fail)
 runChoose :: (m b -> m b -> m b) -> (a -> m b) -> ChooseC m a -> m b
 runChoose fork leaf m = runChooseC m fork leaf
 
+runChooseS :: (Applicative m, Semigroup b) => (a -> m b) -> ChooseC m a -> m b
+runChooseS leaf = runChoose (liftA2 (<>)) leaf
+
 -- | A carrier for 'Choose' effects based on Ralf Hinze’s design described in [Deriving Backtracking Monad Transformers](https://www.cs.ox.ac.uk/ralf.hinze/publications/#P12).
 newtype ChooseC m a = ChooseC
   { -- | A higher-order function receiving two continuations, respectively implementing choice and 'pure'.
@@ -50,7 +54,9 @@ instance Fail.MonadFail m => Fail.MonadFail (ChooseC m) where
 
 instance MonadFix m => MonadFix (ChooseC m) where
   mfix f = ChooseC $ \ fork leaf ->
-    mfix (runChoose (liftA2 Fork) (pure . Leaf)
+    mfix (runChoose
+      (liftA2 Fork)
+      (pure . Leaf)
       . f . fromJust . fold (Alt.<|>) Just)
     >>= fold fork leaf
   {-# INLINE mfix #-}

src/Control/Carrier/Cull/Church.hs

@@ -6,13 +6,16 @@ module Control.Carrier.Cull.Church
 , module Control.Effect.NonDet
   -- * Cull carrier
 , runCull
+, runCullA
+, runCullM
 , CullC(..)
   -- * Re-exports
 , Carrier
 , Has
 , run
 ) where
 
+import Control.Applicative (liftA2)
 import Control.Carrier
 import Control.Carrier.NonDet.Church
 import Control.Carrier.Reader
@@ -24,11 +27,17 @@ import Control.Monad.Fix
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 
--- | Run a 'Cull' effect. Branches outside of any 'cull' block will not be pruned.
+-- | Run a 'Cull' effect with the supplied continuations for '<|>', 'pure', and 'empty'. Branches outside of any 'cull' block will not be pruned.
 --
---   prop> run (runNonDet (runCull (pure a <|> pure b))) === [a, b]
-runCull :: Alternative m => CullC m a -> m a
-runCull (CullC m) = runNonDetC (runReader False m) (<|>) pure empty
+--   prop> run (runCull (liftA2 (<|>)) (pure . pure) (pure empty) (pure a <|> pure b)) === [a, b]
+runCull :: (m b -> m b -> m b) -> (a -> m b) -> m b -> CullC m a -> m b
+runCull fork leaf nil = runNonDet fork leaf nil . runReader False . runCullC
+
+runCullA :: (Alternative f, Applicative m) => CullC m a -> m (f a)
+runCullA = runCull (liftA2 (<|>)) (pure . pure) (pure empty)
+
+runCullM :: (Applicative m, Monoid b) => (a -> b) -> CullC m a -> m b
+runCullM leaf = runCull (liftA2 (<>)) (pure . leaf) (pure mempty)
 
 newtype CullC m a = CullC { runCullC :: ReaderC Bool (NonDetC m) a }
   deriving (Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO)
@@ -61,5 +70,3 @@ instance (Carrier sig m, Effect sig) => Carrier (Cull :+: NonDet :+: sig) (CullC
 -- $setup
 -- >>> :seti -XFlexibleContexts
 -- >>> import Test.QuickCheck
--- >>> import Control.Carrier.NonDet.Church
--- >>> import Control.Carrier.Pure

src/Control/Carrier/Cut/Church.hs

@@ -6,9 +6,10 @@ module Control.Carrier.Cut.Church
 , module Control.Effect.NonDet
   -- * Cut carrier
 , runCut
-, runCutAll
+, runCutA
+, runCutM
 , CutC(..)
--- * Re-exports
+  -- * Re-exports
 , Carrier
 , Has
 , run
@@ -24,15 +25,18 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Prelude hiding (fail)
 
--- | Run a 'Cut' effect within an underlying 'Alternative' instance (typically another 'Carrier' for 'Choose' & 'Empty' effects).
+-- | Run a 'Cut' effect with the supplied continuations for 'pure'/'<|>', 'empty', and 'cutfail'.
 --
---   prop> run (runNonDet (runCut (pure a))) === Just a
-runCut :: Alternative m => CutC m a -> m a
-runCut m = runCutC m ((<|>) . pure) empty empty
+--   prop> run (runCut (fmap . (:)) (pure []) (pure []) (pure a)) === [a]
+runCut :: (a -> m b -> m b) -> m b -> m b -> CutC m a -> m b
+runCut cons nil fail m = runCutC m cons nil fail
 
 -- | Run a 'Cut' effect, returning all its results in an 'Alternative' collection.
-runCutAll :: (Alternative f, Applicative m) => CutC m a -> m (f a)
-runCutAll (CutC m) = m (fmap . (<|>) . pure) (pure empty) (pure empty)
+runCutA :: (Alternative f, Applicative m) => CutC m a -> m (f a)
+runCutA = runCut (fmap . (<|>) . pure) (pure empty) (pure empty)
+
+runCutM :: (Applicative m, Monoid b) => (a -> b) -> CutC m a -> m b
+runCutM leaf = runCut (fmap . (<>) . leaf) (pure mempty) (pure mempty)
 
 newtype CutC m a = CutC
   { -- | A higher-order function receiving three parameters: a function to combine each solution with the rest of the solutions, an action to run when no results are produced (e.g. on 'empty'), and an action to run when no results are produced and backtrcking should not be attempted (e.g. on 'cutfail').
@@ -63,7 +67,12 @@ instance Fail.MonadFail m => Fail.MonadFail (CutC m) where
   {-# INLINE fail #-}
 
 instance MonadFix m => MonadFix (CutC m) where
-  mfix f = CutC (\ cons nil _ -> mfix (\ a -> runCutC (f (head a)) (fmap . (:)) (pure []) (pure [])) >>= foldr cons nil)
+  mfix f = CutC (\ cons nil _ ->
+    mfix (runCut
+      (fmap . (:))
+      (pure [])
+      (pure [])
+      . f . head) >>= foldr cons nil)
   {-# INLINE mfix #-}
 
 instance MonadIO m => MonadIO (CutC m) where
@@ -81,12 +90,11 @@ instance (Carrier sig m, Effect sig) => Carrier (Cut :+: NonDet :+: sig) (CutC m
   eff (L (Call m k)) = CutC $ \ cons nil fail -> runCutC m (\ a as -> runCutC (k a) cons as fail) nil nil
   eff (R (L (L Empty)))      = empty
   eff (R (L (R (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 (R other))          = CutC $ \ cons nil _ -> eff (handle [()] (fmap concat . traverse runCutA) other) >>= foldr cons nil
   {-# INLINE eff #-}
 
 
 -- $setup
 -- >>> :seti -XFlexibleContexts
 -- >>> import Test.QuickCheck
 -- >>> import Control.Carrier.NonDet.Church
--- >>> import Control.Carrier.Pure

src/Control/Carrier/NonDet/Church.hs

@@ -4,6 +4,8 @@ module Control.Carrier.NonDet.Church
   module Control.Effect.NonDet
   -- * NonDet carrier
 , runNonDet
+, runNonDetA
+, runNonDetM
 , NonDetC(..)
   -- * Re-exports
 , Carrier
@@ -21,14 +23,20 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Data.Maybe (fromJust)
 
+runNonDet :: (m b -> m b -> m b) -> (a -> m b) -> m b -> NonDetC m a -> m b
+runNonDet fork leaf nil (NonDetC m) = m fork leaf nil
+
 -- | Run a 'NonDet' effect, collecting all branches’ results into an 'Alternative' functor.
 --
---   Using @[]@ as the 'Alternative' functor will produce all results, while 'Maybe' will return only the first. However, unlike 'Control.Effect.Cull.runNonDetOnce', this will still enumerate the entire search space before returning, meaning that it will diverge for infinite search spaces, even when using 'Maybe'.
+--   Using @[]@ as the 'Alternative' functor will produce all results, while 'Maybe' will return only the first. However, unless used with 'Control.Effect.Cull.cull', this will still enumerate the entire search space before returning, meaning that it will diverge for infinite search spaces, even when using 'Maybe'.
 --
---   prop> run (runNonDet (pure a)) === [a]
---   prop> run (runNonDet (pure a)) === Just a
-runNonDet :: (Alternative f, Applicative m) => NonDetC m a -> m (f a)
-runNonDet (NonDetC m) = m (liftA2 (<|>)) (pure . pure) (pure empty)
+--   prop> run (runNonDetA (pure a)) === [a]
+--   prop> run (runNonDetA (pure a)) === Just a
+runNonDetA :: (Alternative f, Applicative m) => NonDetC m a -> m (f a)
+runNonDetA = runNonDet (liftA2 (<|>)) (pure . pure) (pure empty)
+
+runNonDetM :: (Applicative m, Monoid b) => (a -> b) -> NonDetC m a -> m b
+runNonDetM leaf = runNonDet (liftA2 (<>)) (pure . leaf) (pure mempty)
 
 -- | A carrier for 'NonDet' effects based on Ralf Hinze’s design described in [Deriving Backtracking Monad Transformers](https://www.cs.ox.ac.uk/ralf.hinze/publications/#P12).
 newtype NonDetC m a = NonDetC
@@ -38,8 +46,8 @@ newtype NonDetC m a = NonDetC
   deriving (Functor)
 
 -- $
---   prop> run (runNonDet (pure a *> pure b)) === Just b
---   prop> run (runNonDet (pure a <* pure b)) === Just a
+--   prop> run (runNonDetA (pure a *> pure b)) === Just b
+--   prop> run (runNonDetA (pure a <* pure b)) === Just a
 instance Applicative (NonDetC m) where
   pure a = NonDetC (\ _ leaf _ -> leaf a)
   {-# INLINE pure #-}
@@ -48,8 +56,8 @@ instance Applicative (NonDetC m) where
   {-# INLINE (<*>) #-}
 
 -- $
---   prop> run (runNonDet (pure a <|> (pure b <|> pure c))) === Fork (Leaf a) (Fork (Leaf b) (Leaf c))
---   prop> run (runNonDet ((pure a <|> pure b) <|> pure c)) === Fork (Fork (Leaf a) (Leaf b)) (Leaf c)
+--   prop> run (runNonDetA (pure a <|> (pure b <|> pure c))) === Fork (Leaf a) (Fork (Leaf b) (Leaf c))
+--   prop> run (runNonDetA ((pure a <|> pure b) <|> pure c)) === Fork (Fork (Leaf a) (Leaf b)) (Leaf c)
 instance Alternative (NonDetC m) where
   empty = NonDetC (\ _ _ nil -> nil)
   {-# INLINE empty #-}
@@ -58,7 +66,7 @@ instance Alternative (NonDetC m) where
 
 instance Monad (NonDetC m) where
   NonDetC a >>= f = NonDetC $ \ fork leaf nil ->
-    a fork (\ a' -> runNonDetC (f a') fork leaf nil) nil
+    a fork (runNonDet fork leaf nil . f) nil
   {-# INLINE (>>=) #-}
 
 instance Fail.MonadFail m => Fail.MonadFail (NonDetC m) where
@@ -67,10 +75,11 @@ instance Fail.MonadFail m => Fail.MonadFail (NonDetC m) where
 
 instance MonadFix m => MonadFix (NonDetC m) where
   mfix f = NonDetC $ \ fork leaf nil ->
-    mfix (\ a -> runNonDetC (f (fromJust (fold (<|>) Just Nothing a)))
+    mfix (runNonDet
       (liftA2 Fork)
       (pure . Leaf)
-      (pure Nil))
+      (pure Nil)
+      . f . fromJust . fold (<|>) Just Nothing)
     >>= fold fork leaf nil
   {-# INLINE mfix #-}
 
@@ -87,7 +96,7 @@ instance MonadTrans NonDetC where
 instance (Carrier sig m, Effect sig) => Carrier (NonDet :+: sig) (NonDetC m) where
   eff (L (L Empty))      = empty
   eff (L (R (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
+  eff (R other)          = NonDetC $ \ fork leaf nil -> eff (handle (Leaf ()) (fmap join . traverse runNonDetA) other) >>= fold fork leaf nil
   {-# INLINE eff #-}
 
 

src/Control/Carrier/Trace/Ignoring.hs

@@ -5,7 +5,7 @@ module Control.Carrier.Trace.Ignoring
   -- * Trace carrier
 , runTrace
 , TraceC(..)
--- * Re-exports
+  -- * Re-exports
 , Carrier
 , Has
 , run

src/Control/Carrier/Trace/Printing.hs

@@ -5,7 +5,7 @@ module Control.Carrier.Trace.Printing
   -- * Trace carrier
 , runTrace
 , TraceC(..)
--- * Re-exports
+  -- * Re-exports
 , Carrier
 , Has
 , run

src/Control/Carrier/Trace/Returning.hs

@@ -5,7 +5,7 @@ module Control.Carrier.Trace.Returning
   -- * Trace carrier
 , runTrace
 , TraceC(..)
--- * Re-exports
+  -- * Re-exports
 , Carrier
 , Has
 , run

src/Control/Effect/Cull.hs

@@ -36,5 +36,4 @@ cull m = send (Cull m pure)
 -- >>> import Test.QuickCheck
 -- >>> import Control.Carrier.Cull.Church
 -- >>> import Control.Carrier.NonDet.Church
--- >>> import Control.Carrier.Pure
 -- >>> import Data.Foldable (asum)

src/Control/Effect/Cut.hs

@@ -59,4 +59,3 @@ cut = pure () <|> cutfail
 -- >>> import Test.QuickCheck
 -- >>> import Control.Carrier.Cut.Church
 -- >>> import Control.Carrier.NonDet.Church
--- >>> import Control.Carrier.Pure

src/Control/Effect/Fresh.hs

@@ -39,6 +39,5 @@ resetFresh m = send (Reset m pure)
 -- >>> :seti -XFlexibleContexts
 -- >>> import Test.QuickCheck
 -- >>> import Control.Carrier.Fresh.Strict
--- >>> import Control.Carrier.Pure
 -- >>> import Control.Monad (replicateM)
 -- >>> import Data.List (nub)

src/Control/Effect/State.hs

@@ -62,5 +62,4 @@ modifyLazy f = get >>= put . f
 -- $setup
 -- >>> :seti -XFlexibleContexts
 -- >>> import Test.QuickCheck
--- >>> import Control.Carrier.Pure
 -- >>> import Control.Carrier.State.Strict

test/Control/Effect/NonDet/Spec.hs

@@ -11,13 +11,13 @@ spec :: Spec
 spec = do
   describe "interactions" $ do
     it "collects results of effects run before it" $
-      run (runNonDet (runState 'a' (pure 'z' <|> put 'b' *> get <|> get))) `shouldBe` [('a', 'z'), ('b', 'b'), ('a', 'a')]
+      run (runNonDetA (runState 'a' (pure 'z' <|> put 'b' *> get <|> get))) `shouldBe` [('a', 'z'), ('b', 'b'), ('a', 'a')]
 
     it "collapses results of effects run after it" $
-      run (runState 'a' (runNonDet (pure 'z' <|> put 'b' *> get <|> get))) `shouldBe` ('b', "zbb")
+      run (runState 'a' (runNonDetA (pure 'z' <|> put 'b' *> get <|> get))) `shouldBe` ('b', "zbb")
 
     it "collects results from higher-order effects run before it" $
-      run (runNonDet (runError ((pure 'z' <|> throwError 'a') `catchError` pure))) `shouldBe` [Right 'z', Right 'a' :: Either Char Char]
+      run (runNonDetA (runError ((pure 'z' <|> throwError 'a') `catchError` pure))) `shouldBe` [Right 'z', Right 'a' :: Either Char Char]
 
     it "collapses results of higher-order effects run after it" $
-      run (runError (runNonDet ((pure 'z' <|> throwError 'a') `catchError` pure))) `shouldBe` (Right "a" :: Either Char String)
+      run (runError (runNonDetA ((pure 'z' <|> throwError 'a') `catchError` pure))) `shouldBe` (Right "a" :: Either Char String)