-
Notifications
You must be signed in to change notification settings - Fork 53
New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Simplified eliminators #207
Changes from 25 commits
7dd07f2
698af02
38d5980
f72f38e
9224618
0c30389
04d8fe4
59bacd0
6bc690d
0ee6b47
a2498ed
0a2555a
a9caa3a
ae2fa69
341219f
f335bdd
178f0c6
2765bb7
60662ef
5e75954
f85e8ff
5b48b88
4350fd7
c2970ee
2be2a3f
b75cb1f
0fe1fe3
2e3452b
8507f6e
a2473f0
187a871
b1e4d83
ce3a9b5
File filter
Filter by extension
Conversations
Jump to
Diff view
Diff view
There are no files selected for viewing
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -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 | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. We could supply
By contrast, there’s no reason to supply |
||
|
||
-- | 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) | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Can we use something more descriptive than There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. This is being replaced in #233 anyway, so I’mma leave it as-is. |
||
>>= fold fork leaf | ||
{-# INLINE mfix #-} | ||
|
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -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 | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. This is much more flexible than the previous handlers employed (which required the use of another carrier for nondeterminism). We no longer provide a handler interpreting into an underlying |
||
|
||
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 |
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -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 | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. This was by no means the point of this PR, but it’s certainly a nice side benefit that we can use the eliminators point-free. |
||
{-# 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 #-} | ||
|
||
|
||
|
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -5,7 +5,7 @@ module Control.Carrier.Trace.Returning | |
-- * Trace carrier | ||
, runTrace | ||
, TraceC(..) | ||
-- * Re-exports | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. conform! |
||
-- * Re-exports | ||
, Carrier | ||
, Has | ||
, run | ||
|
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -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 | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. This is re-exported by |
||
-- >>> import Data.Foldable (asum) |
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Loving this.