-
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
Eliminate binary trees #286
Conversation
This reverts commit 08b8dba.
@@ -34,7 +33,7 @@ import Prelude hiding (head, tail) | |||
runChoose :: (m b -> m b -> m b) -> (a -> m b) -> ChooseC m a -> m b | |||
runChoose fork leaf (ChooseC runChooseC) = runChooseC fork leaf | |||
|
|||
-- | Run a 'Choose' effect, passing results to the supplied function, and merging branches together using 'S.<>'. | |||
-- | Run a 'Choose' effect, mapping results into a 'S.Semigroup'. |
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.
I’ve opted to standardize the wording around the run*M
/run*S
handlers a little.
@@ -83,26 +82,5 @@ instance MonadTrans ChooseC where | |||
|
|||
instance (Algebra sig m, Effect sig) => Algebra (Choose :+: sig) (ChooseC m) where | |||
eff (L (Choose k)) = ChooseC $ \ fork leaf -> fork (runChoose fork leaf (k True)) (runChoose fork leaf (k False)) | |||
eff (R other) = ChooseC $ \ fork leaf -> eff (handle (Leaf ()) (fmap join . traverse (runChoose (liftA2 Fork) (pure . Leaf))) other) >>= fold fork leaf | |||
eff (R other) = ChooseC $ \ fork leaf -> eff (handle (pure ()) (runChoose (liftA2 (<|>)) (runChoose (liftA2 (<|>)) (pure . pure))) other) >>= runChoose fork leaf |
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.
As per #292, this uses ChooseC m
as its own initial state functor.
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 #-} |
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.
As a result of the above, we no longer need to encode binary trees as data!
@@ -109,33 +108,5 @@ instance MonadTrans NonDetC where | |||
instance (Algebra sig m, Effect sig) => Algebra (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 runNonDetA) other) >>= fold fork leaf nil | |||
eff (R other) = NonDetC $ \ fork leaf nil -> eff (handle (pure ()) (runNonDet (liftA2 (<|>)) runNonDetA (pure empty)) other) >>= runNonDet fork leaf nil |
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.
It turns out there are (at least) two wrong ways and two right ways to do this.
Wrong:
- using
pure . join
as the handler - using
fmap join . runNonDetA
as the handler
These are both wrong in that they screw up higher-order effects like Catch
in NonDetC (ErrorC e PureC)
—but not ErrorC e (NonDetC PureC)
, curiously enough.
Right:
- using
NonDetC PureC
- this, which is significantly less code than
NonDetC PureC
entailed
[ testCase "cutfail operates through higher-order effects" $ | ||
(runCutA @[] (local (id @()) cutfail <|> pure 'a')) () | ||
@?= | ||
(runCutA @[] (cutfail <|> pure 'a')) () |
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.
I added this as a regression test.
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.
One teeny tiny thing, but this is great!
This PR: