handlesM?

[michaelt]

This mechanical transport of Gabriel's implementation of handlesM seems to work. It uses the EndoM monoid inside Control.Foldl It doesn't touch what's inside DriveT so I guess it must make sense?

 type Handler m a b =
   forall x . (b -> Const (Dual (EndoM (DriveT m) x)) b) ->
                 a -> Const (Dual (EndoM (DriveT m) x)) a

handle :: Handler m a b -> Fold b m r -> Fold a m r
handle k (Fold done step begin) = 
  Fold done
       (\a b -> (appEndoM . getDual . getConst) 
                (k (Const . Dual . EndoM . flip step) b) 
                a)
       begin
{-# INLINE handle #-}

So then, using the fold over a stream that I defined, I can write, say

>>> let f = handle (to readMaybe . _Just . filtered (<10)) Fold.sum 
>>>  foldD_ (Core.take 4 f) S.stdinLn :: IO Int
5<Enter>
5<Enter>
1000000000000<Enter>
1000000000<Enter>
10

to sum the numbers less than 10 that arise from the valid parses of the first four lines of standard input.

[effectfully]

I'll add this as soon as I have time to grasp this Handler thing. Thanks for opening the issue.

[effectfully]

If we remove the newtypes obfuscation and flip the order of arguments, it's just

handles :: Monad m
        => (forall acc. (acc -> a -> DriveT m acc) -> acc -> b -> DriveT m acc)
        -> Fold a m c -> Fold b m c
handles k (Fold g f a) = Fold g (k f) a

So handles simply transforms a stepping function.

The problem with your definition however is that the Applicative instance of Const m requires m to be a Monoid, which uses the dummy monad instance of DriveT m (should I just remove it?), which doesn't stop computation on Stop. Here is a solution (modulo INLINE pragmas):

newtype TraceT m a = TraceT { getTraceT :: a -> m a }

instance MonoMonad m => Monoid (TraceT m a) where
  mempty = TraceT mpure
  TraceT f `mappend` TraceT g = TraceT (f >#> g)

type Pattern m acc = Const (TraceT (DriveT m) acc)
type Handler b m a = forall acc. (a -> Pattern m acc a) -> b -> Pattern m acc b

handles :: Monad m => Handler b m a -> Fold a m c -> Fold b m c
handles k (Fold g f a) = Fold g f' a where
  f' = flip $ getTraceT . getConst . k (Const . TraceT . flip f)

Implemented in 6f0f571. Not closing right now as it needs more testing.

@michaelt, do you use your "hand-crafted" foldD_ or wrote a fold over Stream that is compatible with impurely? If the latter, could you show the code? If the former, writing such fold will be the next thing I try.

[michaelt]

Ah, I should have reflected that the Applicative instance is crucially involved. I guess you could just define something like Pattern directly as

 newtype Pattern m acc x = Pattern {getPattern :: acc -> DriveT m acc}

and write the Functor and Applicative instances.

I wrote the obvious functions to correspond to impurely though I suspect something is wrong with at least the first of them

prefold :: Monad m =>
  (forall x y. f x -> (x -> m y) -> m y) -> (acc -> a -> f acc) -> f acc -> (acc -> m b) 
  -> Stream (Of a) m r -> m (Of b r)
prefold phi step begin done  = S.foldM (\acc a -> phi (step acc a) return) (phi begin return) done
{-#INLINE prefold #-}

prefold_ :: Monad m =>
   (forall x y. f x -> (x -> m y) -> m y) -> (acc -> a -> f acc) -> f acc -> (acc -> m b) 
   -> Stream (Of a) m r  -> m b
prefold_ phi step begin done  = S.foldM_ (\acc a -> phi (step acc a) return) (phi begin return) done
{-#INLINE prefold_ #-}

but the short circuiting is probably tricking me. This is probably something different, but see e.g.

>>>  impurely prefold (Core.take 4 Fold.sum) $ S.each [1..10]
*** Exception: prefolds.take: something went wrong
CallStack (from HasCallStack):
   error, called at src/Core.hs:151:35 in prefolds-0.1.0.0-CPL0rOuqaIG8VomfC2ZCmh:Core

The direct foldD and foldD_ are in here http://sprunge.us/VOQg Pardon the stupid names.

 >>>  foldD (Core.take 4 Fold.sum) $ S.each [1..10]
10 :> ()
>>>  foldD_ (Core.take 4 Fold.sum) $ S.each [1..10]
10

It is systematic in the streaming library that functions ending _ eliminate the final return value of the stream they apply to, and thus may short circuit. In general though the library is precisely trying to keep things from short-circuiting in order to retain the final return value of a stream. Otherwise the function cannot be a natural transformation and huge classes of manipulations fail. I'm not sure I can get something that agrees with impurely and has the effect of this bit of foldD

  Step (a :> rest) -> do
    e <- getDriveT (step x0 a)
    case e of 
      Stop x -> do
        r <- S.effects str 
        b <- done x
        return $! b :> r
      More x -> loop rest x  

here I explicitly drain the rest of the stream with effects in order to preserve the character of the whole as a natural transformation. I'm not sure how to trigger this draining without having my hands on the Stop constructor.

[effectfully]

you could just define something like Pattern directly

Done.

I wrote the obvious functions to correspond to impurely though I suspect something is wrong with at least the first of them

Yes, you could define foldD_ in terms of s.foldM, but you'd need the same trick with coercing DriveT to ExceptT as with plain Foldable:

execM :: (Monad m, Foldable t) => Fold a m b -> t a -> m b
execM f = runExceptT . Lib.foldM (driveToExceptT .* flip feed) f >=> runFold . runEither

This is because the only way to escape left monadic folding early is via the monad you're folding in.

That phi is designed to be always outermost, because it decides whether to continue the computation or stop it immediately, so there is no point in putting phi inside an accumulator, because an accumulator doesn't affect control flow — only the monad it's wrapped in affects.

The "hand-crafted" foldD_ can be rewritten as

foldD_ :: Monad m => Fold a m b -> Stream (Of a) m () -> m b
foldD_ (Fold done step begin) str = driveTM done (loop str) begin where
  loop stream !x0 = case stream of
    Return r         -> done x0 
    Effect m         -> m >>= \s -> loop s x0
    Step (a :> rest) -> driveTM done (loop str) (step x0 a)

This is the same definition as yours, but here we use the driveTM combinator

driveTM :: Monad m => (a -> m b) -> (a -> m b) -> DriveT m a -> m b

which receives two continuations: the first is to be run on Stop and the second is to be run on More. But in both the cases driveTM receives done as a "Stop-continuation" and this is what impurely abstracts (I changed the order of arguments to match the order of arguments in Fold, since we can't define impurely such that it receives a continuation with the same signature as Control.Foldl.impurely expects):

impurely :: Monad m
         => (forall acc. (DriveT m acc -> (acc -> m b) -> m b) ->
               (acc -> m b) -> (acc -> a -> DriveT m acc) -> DriveT m acc -> c)
         -> Fold a m b -> c
impurely h (Fold g f a) = h (flip $ driveTM g) g f a

So we can define prefold_ as

prefold_ :: Monad m => (f acc -> (acc -> m b) -> m b) ->
            (acc -> m b) -> (acc -> a -> f acc) -> f acc -> Stream (Of a) m () -> m b
prefold_ (>>~) final step acc xs = acc >>~ flip go xs where
  go !a (Return ())      = final a
  go  a (Effect m)       = m >>= go a
  go  a (Step (x :> xs)) = step a x >>~ flip go xs

prefold is similar, but phi it receives is just driveTM generalized from DriveT m to f:

prefold :: Monad m => (forall b. (acc -> m b) -> (acc -> m b) -> f acc -> m b) ->
            (acc -> m b) -> (acc -> a -> f acc) -> f acc -> Stream (Of a) m r -> m (Of b r)
prefold phi final step acc xs = goOrEffects xs acc where
  goOrEffects xs = phi (\a -> flip (:>) <$> S.effects xs <*> final a) (flip go xs)

  go !a (Return r)       = (:> r) <$> final a
  go  a (Effect m)       = m >>= go a
  go  a (Step (x :> xs)) = goOrEffects xs acc

As expected, impurely that handles it is

impurelyRest :: Monad m
             => (forall acc. (forall b. (acc -> m b) -> (acc -> m b) -> DriveT m acc -> m b) ->
                   (acc -> m b) -> (acc -> a -> DriveT m acc) -> DriveT m acc -> c)
             -> Fold a m b -> c
impurelyRest h (Fold g f a) = h driveTM g f a

A full snippet.

*** Exception: prefolds.take: something went wrong

I changed this silly error, now it says:

*** Exception: prefolds.take: a saturated fold consumed an element. If you didn't define any functions that explicitly deal with DriveT, then please report this as a bug. If you did define such functions, then it's likely that one of them doesn't stop on Stop.

return $! b :> r

But why ($!)? b :> r is already in WHNF.