Separate carrier and effect modules

ChangeLog.md

@@ -4,6 +4,8 @@
 
 - Adds a `oneOf` function to `Control.Effect.NonDet` to provide an idiom for the common case of nondeterministically selecting from a container. ([#201](https://github.com/fused-effects/fused-effects/pull/201))
 
+- Adds a `foldMapA` function to `Control.Effect.NonDet` mapping containers into nondeterministic computations using a supplied function. ([#204](https://github.com/fused-effects/fused-effects/pull/204))
+
 ## Backwards-incompatible changes
 
 - Improves the performance of `runInterpret` using reflection, changing its signature slightly ([#193](https://github.com/fused-effects/fused-effects/pull/193), h/t [@ocharles](https://github.com/ocharles)).
@@ -16,6 +18,10 @@
 
 - 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)).
 
+- Removes the `OnceC` carrier for `Cull` effects, replacing it with the composition of `CullC` on some other `Alternative` carrier, e.g. `NonDetC` ([#204](https://github.com/fused-effects/fused-effects/pull/204)).
+
+- Moves all the carriers into their own modules in the `Control.Carrier` namespace. Several have also been renamed, e.g. the various `Trace` carriers are all named `TraceC` within their separate modules, and should be imported qualified if disambiguation is required. This simplifies naming schemes, and ensures that the choice of e.g. strict or lazy carrier is always made consciously and expliclty, instead of defaulting to whichever is exported by the effect module ([#204](https://github.com/fused-effects/fused-effects/pull/204)).
+
 # v0.5.0.1
 
 - Adds support for ghc 8.8.1.

benchmark/Bench.hs

@@ -3,10 +3,10 @@ module Main
 ( main
 ) where
 
-import Control.Effect.Carrier
-import Control.Effect.Interpret
-import Control.Effect.Writer
-import Control.Effect.State
+import Control.Carrier
+import Control.Carrier.Interpret
+import Control.Carrier.State.Strict
+import Control.Carrier.Writer.Strict
 import Control.Monad (ap, replicateM_)
 import Data.Functor.Identity
 import Data.Monoid (Sum(..))

benchmark/NonDet/NQueens.hs

@@ -8,9 +8,7 @@
 module NonDet.NQueens (runQueens, benchmark) where
 
 import Control.Applicative
-import Control.Effect
-import Control.Effect.NonDet
-import Control.Monad
+import Control.Carrier.NonDet.Church
 import Data.Foldable
 import Data.List
 import Gauge hiding (benchmark)

examples/Parser.hs

@@ -3,10 +3,10 @@ module Parser
 ( spec
 ) where
 
-import Control.Effect.Carrier
-import Control.Effect.Cut
-import Control.Effect.NonDet
-import Control.Effect.State
+import Control.Carrier
+import Control.Carrier.Cut.Church
+import Control.Carrier.NonDet.Church
+import Control.Carrier.State.Strict
 import Control.Monad (replicateM)
 import Data.Char
 import Data.List (intercalate)

examples/ReinterpretLog.hs

@@ -33,10 +33,10 @@ module ReinterpretLog
   , runApplication
   ) where
 
-import Control.Effect.Carrier
-import Control.Effect.Lift
-import Control.Effect.Reader
-import Control.Effect.Writer
+import Control.Carrier
+import Control.Carrier.Lift
+import Control.Carrier.Reader
+import Control.Carrier.Writer.Strict
 import Control.Monad.IO.Class (MonadIO(..))
 import Data.Function          ((&))
 import Data.Kind              (Type)

examples/Teletype.hs

@@ -7,9 +7,9 @@ module Teletype
 
 import Prelude hiding (read)
 
-import Control.Effect.Carrier
-import Control.Effect.State
-import Control.Effect.Writer
+import Control.Carrier
+import Control.Carrier.State.Strict
+import Control.Carrier.Writer.Strict
 import Control.Monad.IO.Class
 import GHC.Generics (Generic1)
 import Test.Hspec

fused-effects.cabal

@@ -31,27 +31,46 @@ common common
 
 library
   import:              common
-  exposed-modules:     Control.Effect
-                     , Control.Effect.Carrier
+  exposed-modules:     Control.Carrier
+                     , Control.Carrier.Choose.Church
+                     , Control.Carrier.Class
+                     , Control.Carrier.Cull.Church
+                     , Control.Carrier.Cut.Church
+                     , Control.Carrier.Empty.Maybe
+                     , Control.Carrier.Error.Either
+                     , Control.Carrier.Fail.Either
+                     , Control.Carrier.Fresh.Strict
+                     , Control.Carrier.Interpose
+                     , Control.Carrier.Interpret
+                     , Control.Carrier.Lift
+                     , Control.Carrier.NonDet.Church
+                     , Control.Carrier.Pure
+                     , Control.Carrier.Reader
+                     , Control.Carrier.Resource
+                     , Control.Carrier.Resumable.Either
+                     , Control.Carrier.Resumable.Resume
+                     , Control.Carrier.State.Lazy
+                     , Control.Carrier.State.Strict
+                     , Control.Carrier.Trace.Ignoring
+                     , Control.Carrier.Trace.Printing
+                     , Control.Carrier.Trace.Returning
+                     , Control.Carrier.Writer.Strict
+                     , Control.Effect
                      , Control.Effect.Choose
+                     , Control.Effect.Class
                      , Control.Effect.Cull
                      , Control.Effect.Cut
                      , Control.Effect.Empty
                      , Control.Effect.Error
                      , Control.Effect.Fail
                      , Control.Effect.Fresh
-                     , Control.Effect.Interpose
-                     , Control.Effect.Interpret
                      , Control.Effect.Lift
                      , Control.Effect.NonDet
                      , Control.Effect.Pure
                      , Control.Effect.Reader
                      , Control.Effect.Resource
                      , Control.Effect.Resumable
                      , Control.Effect.State
-                     , Control.Effect.State.Internal
-                     , Control.Effect.State.Lazy
-                     , Control.Effect.State.Strict
                      , Control.Effect.Sum
                      , Control.Effect.Trace
                      , Control.Effect.Writer

src/Control/Carrier.hs

@@ -0,0 +1,12 @@
+module Control.Carrier
+( -- * Re-exports
+  module Control.Carrier.Class
+, module Control.Effect.Class
+, module Control.Effect.Sum
+, run
+) where
+
+import Control.Carrier.Class
+import Control.Carrier.Pure
+import Control.Effect.Class
+import Control.Effect.Sum

src/Control/Carrier/Choose/Church.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE DeriveTraversable, FlexibleInstances, MultiParamTypeClasses, RankNTypes, TypeOperators, UndecidableInstances #-}
+module Control.Carrier.Choose.Church
+( -- * Choose effect
+  module Control.Effect.Choose
+  -- * Choose carrier
+, runChoose
+, ChooseC(..)
+  -- * Re-exports
+, Carrier
+, Member
+, run
+) where
+
+import Control.Applicative as Alt ((<|>), liftA2)
+import Control.Carrier
+import Control.Effect.Choose
+import Control.Monad (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 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
+
+-- | 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'.
+    runChooseC :: forall b . (m b -> m b -> m b) -> (a -> m b) -> m b
+  }
+  deriving (Functor)
+
+instance Applicative (ChooseC m) where
+  pure a = ChooseC (\ _ leaf -> leaf a)
+  {-# INLINE pure #-}
+  ChooseC f <*> ChooseC a = ChooseC $ \ fork leaf ->
+    f fork (\ f' -> a fork (leaf . f'))
+  {-# INLINE (<*>) #-}
+
+instance Monad (ChooseC m) where
+  ChooseC a >>= f = ChooseC $ \ fork leaf ->
+    a fork (runChoose fork leaf . f)
+  {-# INLINE (>>=) #-}
+
+instance Fail.MonadFail m => Fail.MonadFail (ChooseC m) where
+  fail s = lift (Fail.fail s)
+  {-# INLINE fail #-}
+
+instance MonadFix m => MonadFix (ChooseC m) where
+  mfix f = ChooseC $ \ fork leaf ->
+    mfix (runChoose (liftA2 Fork) (pure . Leaf)
+      . f . fromJust . fold (Alt.<|>) Just)
+    >>= fold fork leaf
+  {-# INLINE mfix #-}
+
+instance MonadIO m => MonadIO (ChooseC m) where
+  liftIO io = lift (liftIO io)
+  {-# INLINE liftIO #-}
+
+instance MonadTrans ChooseC where
+  lift m = ChooseC (\ _ leaf -> m >>= leaf)
+  {-# INLINE lift #-}
+
+instance (Carrier sig m, Effect sig) => Carrier (Choose :+: sig) (ChooseC m) where
+  eff (L (Choose k)) = ChooseC $ \ fork leaf -> fork (runChooseC (k True) fork leaf) (runChooseC (k False) fork leaf)
+  eff (R other)      = ChooseC $ \ fork leaf -> eff (handle (Leaf ()) (fmap join . traverse (runChoose (liftA2 Fork) (pure . Leaf))) other) >>= fold fork leaf
+  {-# INLINE eff #-}
+
+
+data BinaryTree a = Leaf a | Fork (BinaryTree a) (BinaryTree a)
+  deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
+
+instance Applicative BinaryTree where
+  pure = Leaf
+  {-# INLINE pure #-}
+  f <*> a = fold Fork (<$> a) f
+  {-# INLINE (<*>) #-}
+
+instance Monad BinaryTree where
+  a >>= f = fold Fork f a
+  {-# INLINE (>>=) #-}
+
+
+fold :: (b -> b -> b) -> (a -> b) -> BinaryTree a -> b
+fold fork leaf = go where
+  go (Leaf a)   = leaf a
+  go (Fork a b) = fork (go a) (go b)
+{-# INLINE fold #-}

src/Control/Carrier/Class.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE FunctionalDependencies #-}
+module Control.Carrier.Class
+( Carrier(..)
+) where
+
+import Control.Effect.Class
+
+-- | The class of carriers (results) for algebras (effect handlers) over signatures (effects), whose actions are given by the 'eff' method.
+class (HFunctor sig, Monad m) => Carrier sig m | m -> sig where
+  -- | Construct a value in the carrier for an effect signature (typically a sum of a handled effect and any remaining effects).
+  eff :: sig m a -> m a

src/Control/Carrier/Cull/Church.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
+module Control.Carrier.Cull.Church
+( -- * Cull effect
+  module Control.Effect.Cull
+  -- * NonDet effects
+, module Control.Effect.NonDet
+  -- * Cull carrier
+, runCull
+, CullC(..)
+  -- * Re-exports
+, Carrier
+, Member
+, run
+) where
+
+import Control.Carrier
+import Control.Carrier.NonDet.Church
+import Control.Carrier.Reader
+import Control.Effect.Cull
+import Control.Effect.NonDet
+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
+
+-- | Run a 'Cull' effect. 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
+
+newtype CullC m a = CullC { runCullC :: ReaderC Bool (NonDetC m) a }
+  deriving (Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO)
+
+instance Alternative (CullC m) where
+  empty = CullC empty
+  {-# INLINE empty #-}
+  l <|> r = CullC $ ReaderC $ \ cull ->
+    if cull then
+      NonDetC $ \ fork leaf nil ->
+        runNonDetC (runReader cull (runCullC l)) fork leaf (runNonDetC (runReader cull (runCullC r)) fork leaf nil)
+    else
+      runReader cull (runCullC l) <|> runReader cull (runCullC r)
+  {-# INLINE (<|>) #-}
+
+instance MonadPlus (CullC m)
+
+instance MonadTrans CullC where
+  lift = CullC . lift . lift
+  {-# INLINE lift #-}
+
+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 #-}
+
+
+-- $setup
+-- >>> :seti -XFlexibleContexts
+-- >>> import Test.QuickCheck
+-- >>> import Control.Carrier.NonDet.Church
+-- >>> import Control.Carrier.Pure