Inject/Project find effects nested on the left

ChangeLog.md

@@ -10,6 +10,8 @@
 
 - Defines a new `Has` constraint synonym, conveniently combining `Carrier` and `Member` constraints and used for all effect constructors. ([#217](https://github.com/fused-effects/fused-effects/pull/217))
 
+- Allows effects to be defined and handled as sums of other effects, while still using the constructors for the component effects. This has been used to redefine `NonDet` as a sum of `Empty` and `Choose`. ([#199](https://github.com/fused-effects/fused-effects/pull/199), [#219](https://github.com/fused-effects/fused-effects/pull/219))
+
 ## 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)).
@@ -20,8 +22,6 @@
 
 - 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)).
-
 - 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)).

src/Control/Carrier/Cull/Church.hs

@@ -50,11 +50,11 @@ instance MonadTrans CullC where
   lift = CullC . lift . lift
   {-# INLINE lift #-}
 
-instance (Carrier sig m, Effect sig) => Carrier (Cull :+: Empty :+: Choose :+: sig) (CullC m) where
+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 (R (L (Choose k)))) = k True <|> k False
-  eff (R (R (R other)))      = CullC (eff (R (R (R (handleCoercible other)))))
+  eff (R (L (L Empty)))      = empty
+  eff (R (L (R (Choose k)))) = k True <|> k False
+  eff (R (R other))          = CullC (eff (R (R (handleCoercible other))))
   {-# INLINE eff #-}
 
 

src/Control/Carrier/Cut/Church.hs

@@ -76,12 +76,12 @@ instance MonadTrans CutC where
   lift m = CutC (\ cons nil _ -> m >>= flip cons nil)
   {-# INLINE lift #-}
 
-instance (Carrier sig m, Effect sig) => Carrier (Cut :+: Empty :+: Choose :+: sig) (CutC m) where
+instance (Carrier sig m, Effect sig) => Carrier (Cut :+: NonDet :+: 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 (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
+  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
   {-# INLINE eff #-}
 
 

src/Control/Carrier/NonDet/Church.hs

@@ -84,10 +84,10 @@ instance MonadTrans NonDetC where
   lift m = NonDetC (\ _ leaf _ -> m >>= leaf)
   {-# INLINE lift #-}
 
-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
+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
   {-# INLINE eff #-}
 
 

src/Control/Effect/NonDet.hs

@@ -1,7 +1,9 @@
+{-# LANGUAGE TypeOperators #-}
 module Control.Effect.NonDet
 ( -- * NonDet effects
   module Control.Effect.Choose
 , module Control.Effect.Empty
+, NonDet
 , oneOf
 , foldMapA
   -- * Re-exports
@@ -12,10 +14,13 @@ module Control.Effect.NonDet
 import Control.Applicative (Alternative(..))
 import Control.Effect.Choose hiding ((<|>), many, some)
 import Control.Effect.Empty hiding (empty, guard)
+import Control.Effect.Sum
 import Control.Monad (guard)
 import Data.Coerce
 import Data.Monoid (Alt(..))
 
+type NonDet = Empty :+: Choose
+
 -- | Nondeterministically choose an element from a 'Foldable' collection.
 -- This can be used to emulate the style of nondeterminism associated with
 -- programming in the list monad:

src/Control/Effect/Sum.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ConstraintKinds, DeriveGeneric, DeriveTraversable, FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators #-}
+{-# LANGUAGE ConstraintKinds, DeriveGeneric, DeriveTraversable, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
 module Control.Effect.Sum
 ( (:+:)(..)
 , Member
@@ -26,26 +26,48 @@ type Member sub sup = (Inject sub sup, Project sub sup)
 class Inject (sub :: (* -> *) -> (* -> *)) sup where
   inj :: sub m a -> sup m a
 
-instance Inject sub sub where
+instance Inject t t where
   inj = id
 
-instance {-# OVERLAPPABLE #-} Inject sub (sub :+: sup) where
-  inj = L . inj
-
-instance {-# OVERLAPPABLE #-} Inject sub sup => Inject sub (sub' :+: sup) where
+instance {-# OVERLAPPABLE #-}
+         Inject t (l1 :+: l2 :+: r)
+      => Inject t ((l1 :+: l2) :+: r) where
+  inj = reassoc . inj where
+    reassoc (L l)     = L (L l)
+    reassoc (R (L l)) = L (R l)
+    reassoc (R (R r)) = R r
+
+instance {-# OVERLAPPABLE #-}
+         Inject l (l :+: r) where
+  inj = L
+
+instance {-# OVERLAPPABLE #-}
+         Inject l r
+      => Inject l (l' :+: r) where
   inj = R . inj
 
 
 class Project (sub :: (* -> *) -> (* -> *)) sup where
   prj :: sup m a -> Maybe (sub m a)
 
-instance Project sub sub where
+instance Project t t where
   prj = Just
 
-instance {-# OVERLAPPABLE #-} Project sub (sub :+: sup) where
+instance {-# OVERLAPPABLE #-}
+         Project t (l1 :+: l2 :+: r)
+      => Project t ((l1 :+: l2) :+: r) where
+  prj = prj . reassoc where
+    reassoc (L (L l)) = L l
+    reassoc (L (R l)) = R (L l)
+    reassoc (R r)     = R (R r)
+
+instance {-# OVERLAPPABLE #-}
+         Project l (l :+: r) where
   prj (L f) = Just f
   prj _     = Nothing
 
-instance {-# OVERLAPPABLE #-} Project sub sup => Project sub (sub' :+: sup) where
+instance {-# OVERLAPPABLE #-}
+         Project l r
+      => Project l (l' :+: r) where
   prj (R g) = prj g
   prj _     = Nothing