Binary nondeterminism

ChangeLog.md

@@ -8,6 +8,8 @@
 
 - Removes `fmap'` and `handlePure`, both deprecated in 0.5.0.0 ([#205](https://github.com/fused-effects/fused-effects/pull/205)).
 
+- Redefines `NonDetC` as a Church-encoded binary tree instead of a Church-encoded list ([#197](https://github.com/fused-effects/fused-effects/pull/197)).
+
 # v0.5.0.1
 
 - Adds support for ghc 8.8.1.

src/Control/Effect/Cull.hs

@@ -41,6 +41,7 @@ instance Effect Cull where
 -- | Cull nondeterminism in the argument, returning at most one result.
 --
 --   prop> run (runNonDet (runCull (cull (pure a <|> pure b)))) === [a]
+--   prop> run (runNonDet (runCull (cull (empty  <|> pure a)))) === [a]
 --   prop> run (runNonDet (runCull (cull (pure a <|> pure b) <|> pure c))) === [a, c]
 --   prop> run (runNonDet (runCull (cull (asum (map pure (repeat a)))))) === [a]
 cull :: (Carrier sig m, Member Cull sig) => m a -> m a
@@ -51,18 +52,20 @@ cull m = send (Cull m pure)
 --
 --   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
+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 -> NonDetC $ \ cons nil -> do
-    runNonDetC (runReader cull (runCullC l))
-      (\ a as -> cons a (if cull then nil else as))
-      (runNonDetC (runReader cull (runCullC r)) cons nil)
+  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)

src/Control/Effect/Cut.hs

@@ -102,15 +102,15 @@ instance Monad (CutC m) where
   {-# INLINE (>>=) #-}
 
 instance Fail.MonadFail m => Fail.MonadFail (CutC m) where
-  fail s = CutC (\ _ _ _ -> Fail.fail s)
+  fail s = lift (Fail.fail s)
   {-# 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)
   {-# INLINE mfix #-}
 
 instance MonadIO m => MonadIO (CutC m) where
-  liftIO io = CutC (\ cons nil _ -> liftIO io >>= flip cons nil)
+  liftIO io = lift (liftIO io)
   {-# INLINE liftIO #-}
 
 instance MonadPlus (CutC m)

src/Control/Effect/NonDet.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveAnyClass, DeriveFunctor, DeriveGeneric, DerivingStrategies, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DeriveGeneric, DeriveTraversable, FlexibleInstances, MultiParamTypeClasses, RankNTypes, TypeOperators, UndecidableInstances #-}
 module Control.Effect.NonDet
 ( -- * NonDet effect
   NonDet(..)
@@ -12,81 +12,117 @@ module Control.Effect.NonDet
 , run
 ) where
 
-import Control.Applicative (Alternative(..))
+import Control.Applicative (Alternative(..), liftA2)
 import Control.Effect.Carrier
-import Control.Monad (MonadPlus(..))
+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 GHC.Generics (Generic1)
 
 data NonDet m k
   = Empty
   | Choose (Bool -> m k)
-  deriving stock (Functor, Generic1)
-  deriving anyclass (HFunctor, Effect)
+  deriving (Functor, Generic1)
+
+instance HFunctor NonDet
+instance Effect   NonDet
 
 
 -- | 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 '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, 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'.
 --
 --   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 (fmap . (<|>) . pure) (pure empty)
+runNonDet (NonDetC m) = m (liftA2 (<|>)) (pure . pure) (pure empty)
 
 -- | 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
-  { -- | A higher-order function receiving two parameters: a function to combine each solution with the rest of the solutions, and an action to run when no results are produced.
-    runNonDetC :: forall b . (a -> m b -> m b) -> m b -> m b
+  { -- | A higher-order function receiving three continuations, respectively implementing '<|>', 'pure', and 'empty'.
+    runNonDetC :: forall b . (m b -> m b -> m b) -> (a -> m b) -> m b -> m b
   }
-  deriving stock (Functor)
+  deriving (Functor)
 
+-- $
+--   prop> run (runNonDet (pure a *> pure b)) === Just b
+--   prop> run (runNonDet (pure a <* pure b)) === Just a
 instance Applicative (NonDetC m) where
-  pure a = NonDetC (\ cons -> cons a)
+  pure a = NonDetC (\ _ leaf _ -> leaf a)
   {-# INLINE pure #-}
-  NonDetC f <*> NonDetC a = NonDetC $ \ cons ->
-    f (\ f' -> a (cons . f'))
+  NonDetC f <*> NonDetC a = NonDetC $ \ fork leaf nil ->
+    f fork (\ f' -> a fork (leaf . f') nil) nil
   {-# 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)
 instance Alternative (NonDetC m) where
-  empty = NonDetC (\ _ nil -> nil)
+  empty = NonDetC (\ _ _ nil -> nil)
   {-# INLINE empty #-}
-  NonDetC l <|> NonDetC r = NonDetC $ \ cons -> l cons . r cons
+  NonDetC l <|> NonDetC r = NonDetC $ \ fork leaf nil -> fork (l fork leaf nil) (r fork leaf nil)
   {-# INLINE (<|>) #-}
 
 instance Monad (NonDetC m) where
-  NonDetC a >>= f = NonDetC $ \ cons ->
-    a (\ a' -> runNonDetC (f a') cons)
+  NonDetC a >>= f = NonDetC $ \ fork leaf nil ->
+    a fork (\ a' -> runNonDetC (f a') fork leaf nil) nil
   {-# INLINE (>>=) #-}
 
 instance Fail.MonadFail m => Fail.MonadFail (NonDetC m) where
-  fail s = NonDetC (\ _ _ -> Fail.fail s)
+  fail s = lift (Fail.fail s)
   {-# INLINE fail #-}
 
 instance MonadFix m => MonadFix (NonDetC m) where
-  mfix f = NonDetC (\ cons nil -> mfix (\ a -> runNonDetC (f (head a)) (fmap . (:)) (pure [])) >>= foldr cons nil)
+  mfix f = NonDetC $ \ fork leaf nil ->
+    mfix (\ a -> runNonDetC (f (fromJust (fold (<|>) Just Nothing a)))
+      (liftA2 Fork)
+      (pure . Leaf)
+      (pure Nil))
+    >>= fold fork leaf nil
   {-# INLINE mfix #-}
 
 instance MonadIO m => MonadIO (NonDetC m) where
-  liftIO io = NonDetC (\ cons nil -> liftIO io >>= flip cons nil)
+  liftIO io = lift (liftIO io)
   {-# INLINE liftIO #-}
 
 instance MonadPlus (NonDetC m)
 
 instance MonadTrans NonDetC where
-  lift m = NonDetC (\ cons nil -> m >>= flip cons nil)
+  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 $ \ cons nil -> eff (handle [()] (fmap concat . traverse runNonDet) other) >>= foldr cons nil
+  eff (R other)      = NonDetC $ \ fork leaf nil -> eff (handle (Leaf ()) (fmap join . traverse runNonDet) other) >>= fold fork leaf nil
   {-# INLINE eff #-}
 
 
+data BinaryTree a = Nil | Leaf a | Fork (BinaryTree a) (BinaryTree a)
+  deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
+
+instance Applicative BinaryTree where
+  pure = Leaf
+  f <*> a = fold Fork (<$> a) Nil f
+
+instance Alternative BinaryTree where
+  empty = Nil
+  (<|>) = Fork
+
+instance Monad BinaryTree where
+  a >>= f = fold Fork f Nil a
+
+
+fold :: (b -> b -> b) -> (a -> b) -> b -> BinaryTree a -> b
+fold fork leaf nil = go where
+  go Nil        = nil
+  go (Leaf a)   = leaf a
+  go (Fork a b) = fork (go a) (go b)
+
+
 -- $setup
 -- >>> :seti -XFlexibleContexts
 -- >>> import Test.QuickCheck