Bearriver: ArrowLoop yampa and bearriver differences

[walseb]

Hi! I have been porting a game I'm working on in yampa to bearriver to see if dynamic collection performance is better and have this problem where rec blocks gives me <<loop>> errors. For example this rec pattern is fairly common in yampa (EDIT: although this example doesn't make much sense, usually the input to iPre 1 should be foo so that it forms a complete loop, but I simplified it here to 1):

{-# LANGUAGE Arrows #-}

module Main
  ( main,
  )
where

import FRP.Yampa

main = reactimate (return NoEvent) (\ _ -> return (0.1, Nothing)) (\_ b -> putStrLn (show b) >> pure False) sf

-- count from 1 to infinity
sf = proc _ -> do
  rec
    foo <- accumHoldBy (+) (1 :: Float) -< Event bar
    bar <- iPre 1 -< 1
  returnA -< foo

and runs fine in yampa but crashes with <<loop>> in bearriver. This is the error I get when I run it in bearriver:

cabal run --enable-profiling --ghc-options="-fprof-auto" all -- +RTS -xc
Up to date
*** Exception (reporting due to +RTS -xc): (THUNK_STATIC), stack trace: 
  Data.MonadicStreamFunction.Instances.ArrowLoop.loop.\,
  called from Data.MonadicStreamFunction.Instances.ArrowLoop.loop,
  called from Main.sf,
  called from Data.MonadicStreamFunction.InternalCore.unMSF,
  called from Control.Monad.Trans.MSF.Reader.runReaderS.\,
  called from Data.MonadicStreamFunction.InternalCore.morphGS.\,
  called from Data.MonadicStreamFunction.InternalCore.morphGS,
  called from Control.Monad.Trans.MSF.Reader.runReaderS,
  called from FRP.BearRiver.reactimate.sfIO,
  called from FRP.BearRiver.reactimate,
  called from Main.main
*** Exception (reporting due to +RTS -xc): (THUNK_STATIC), stack trace: 
  Data.MonadicStreamFunction.Instances.ArrowLoop.loop.\,
  called from Data.MonadicStreamFunction.Instances.ArrowLoop.loop,
  called from Main.sf,
  called from Data.MonadicStreamFunction.InternalCore.unMSF,
  called from Control.Monad.Trans.MSF.Reader.runReaderS.\,
  called from Data.MonadicStreamFunction.InternalCore.morphGS.\,
  called from Data.MonadicStreamFunction.InternalCore.morphGS,
  called from Control.Monad.Trans.MSF.Reader.runReaderS,
  called from FRP.BearRiver.reactimate.sfIO,
  called from FRP.BearRiver.reactimate,
  called from Main.main
RecCrashExample: <<loop>>

Maybe this has something to do with dunai running at time 1 while yampa runs at time 0? Thanks for any help!

[turion]

I'm a bit confused with this example because it's not actually recursive, right? The definition of bar does not use foo. I'm wondering whether the desugaring of recursive arrow notation is doing something weird here. Can you try and rebuild without arrow notation and directly with combinators? I guess an equivalent SF could be something like this:

loop
  $ arr (\((), bar) -> (Event bar, 1))
  >>> (accumHoldBy (+) (1 :: Float) *** iPre 1)

If that still crashes, we'll have to look at loop. If not, we can try to rebuild the SF from first and arr (as the desugarer does). If that doesn't reproduce the crash, then desugaring is doing something strange.

[walseb]

I'm a bit confused with this example because it's not actually recursive, right?

Yeah sorry for the confusion, I used to have it recursive but it crashed even when I replaced the recursive call with 1, so even if the code doesn't make much sense I thought I would just do that instead to simplify the example

Can you try and rebuild without arrow notation and directly with combinators?

Thanks! That example works (after I changed arr (\((), bar) to arr (\(_, bar)). Infact I just now tried moving around the stuff in the rec block so that it's in the correct order (at which point a rec block would be pointless) and now it works, so it probably has to do with the desugaring:

This crashes:

sf = proc _ -> do
  rec
    foo <- accumHoldBy (+) (1 :: Float) -< Event bar
    bar <- iPre 1 -< 1
  returnA -< foo

This works:

sf = proc _ -> do
  rec
    bar <- iPre 1 -< 1
    foo <- accumHoldBy (+) (1 :: Float) -< Event bar
  returnA -< foo

Oh and I'm not sure how the rec desugarer works, maybe there is some way to let me see what arrow operators it generates before it compiles it?

[turion]

I'm a bit confused with this example because it's not actually recursive, right?

Yeah sorry for the confusion, I used to have it recursive but it crashed even when I replaced the recursive call with 1, so even if the code doesn't make much sense I thought I would just do that instead to simplify the example

That's actually great, because it shows us that the bug is not in your code.

Thanks! That example works (after I changed arr (\((), bar) to arr (\(_, bar)).

Great. Search goes on :)

Infact I just now tried moving around the stuff in the rec block so that it's in the correct order (at which point a rec block would be pointless) and now it works, so it probably has to do with the desugaring:

This crashes:

sf = proc _ -> do
  rec
    foo <- accumHoldBy (+) (1 :: Float) -< Event bar
    bar <- iPre 1 -< 1
  returnA -< foo

This works:

sf = proc _ -> do
  rec
    bar <- iPre 1 -< 1
    foo <- accumHoldBy (+) (1 :: Float) -< Event bar
  returnA -< foo

Weird :/ The vague reason I can think of is that in the first version, the bar travels along the loop, but in the second case it doesn't.

Oh and I'm not sure how the rec desugarer works,

I'm not entirely sure how it works, but my guess would be something like this:

sf = loop
  $ arr Event >>> accumHoldBy (+) (1 :: Float)
  >>> arr (\foo -> (1, foo)) >>> first (iPre 1)
  >>> arr (\(bar, foo) -> (foo, bar))

Whereas your second version is more like this:

sf = iPre 1 >>> arr Event >>> accumHoldBy (+) (1 :: Float)

I'm not sure the desugarer is clever enough, but in the second example, no loop is necessary, even though in the first one it technically is. (Another way to look at it is that in the first example, any side effects from accumHoldBy would be executed before those of iPre, even though those particular functions happen not to have side effects.)

maybe there is some way to let me see what arrow operators it generates before it compiles it?

Oooofff. Not so easy. You could fork dunai and add calls to Debug.Trace.trace in all calls to the relevant operators. Then run your example again.

Another way would be to build yourself a little free arrow (like here: https://gist.github.com/turion/c775d388771fcf95f86dc52cefed8898) and add a Loop constructor. Then you can inspect the result. Let me know if you want to try and need help.

[walseb]

I had to modify your examples slightly to make them compile. This ran fine:

sf :: MSF (ClockInfo Identity) (Event Float) Float
sf = loop
  $ arr (\(a,b) -> Event b) >>> accumHoldBy (+) (1 :: Float)
  >>> arr (\foo -> (1, foo)) >>> first (iPre 1)
  >>> arr (\(bar, foo) -> (foo, bar))

This also ran fine but just kept repeating 2 instead of counting up, probably because reactimate only fed it zeroes?

sf = iPre (Event 1) >>> accumHoldBy (+) (1 :: Float)

[turion]

I had to modify your examples slightly to make them compile. This ran fine:

sf :: MSF (ClockInfo Identity) (Event Float) Float
sf = loop
  $ arr (\(a,b) -> Event b) >>> accumHoldBy (+) (1 :: Float)
  >>> arr (\foo -> (1, foo)) >>> first (iPre 1)
  >>> arr (\(bar, foo) -> (foo, bar))

Strange. Why do you have Event Float as an input type? () should work as input.

I guess I've not desugared correctly then. Any success in any of the two ideas to find out what the result of the desugaring is?

This also ran fine but just kept repeating 2 instead of counting up, probably because reactimate only fed it zeroes?

sf = iPre (Event 1) >>> accumHoldBy (+) (1 :: Float)

Weird. Why does it even work? The example is actually missing something, I forgot:

sf = arr (const 1) >>> iPre 1 >>> arr Event >>> accumHoldBy (+) (1 :: Float)

That might fix the issue with stopping the count.

[walseb]

Strange. Why do you have Event Float as an input type? () should work as input.

Oh yeah, that's because I had the initial symbol set to Nothing: reactimate (return Nothing) ..., and when I change it to unit: reactimate (return ()) ... it works as you say

I guess I've not desugared correctly then. Any success in any of the two ideas to find out what the result of the desugaring is?

I haven't tried it yet but I will tomorrow. Although your free arrow stuff is way over my head

That might fix the issue with stopping the count.

Yeah it works now!

[walseb]

So I went in and put trace in all basic arrow operators (arrow, choice and loop), but one problem is that >>> and <<< isn't part of any typeclass so those are emitted. Function calls are also hard to use trace on since you don't know whether it's a higher level function calling it or if it's actually being called directly. And there are also just so many possible functions it could be calling that I just included a few and only feedback got called:

arr arr arr first arr arr arr arr arr *** first arr arr first arr arr arr arr first loop arr arr arr feedback arr

Maybe that gives you a hint? To me it's meaningless.

[turion]

It sounds like a pirate ship is sailing on bearriver :laughing:

>>> and <<< are part of the category type class. <<< is an alias for . which is simply sequential composition.

The most important part is figuring out where the loop goes, or rather what goes in the loop. But I agree that it's hard to figure this out if we don't know which sf these functions are referring to.

Let's try a free arrow approach. It's actually not so hard, you should be able to implement it. Here is a start:

data FreeSF m a b where
  Id :: FreeSF m a a
  Arr :: (a -> b) -> FreeSF m a b
  ArrM :: (a -> m b) -> FreeSF m a b
  Seq :: FreeSF m a b -> FreeSF m b c -> FreeSF m a c
  First :: FreeSF m a b -> FreeSF m (a, c) (b, c)
  Par :: FreeSF m a b -> FreeSF m c d -> FreeSF m (a, c) (b, d)
  Loop :: FreeSF m (a, c) (b, c) -> FreeSF m a b
  Feedback :: c -> FreeSF m (a, c) (b, c) -> FreeSF m a b

The idea here is that every capability (such as an API or a type class) that we want to support corresponds to some constructors of a GADT. This GADT now satisfies all sorts of type classes purely syntactically:

arrM :: (a -> m b) -> FreeSF m a b

instance Category FreeSF m where
  id = Id
  (.) = flip Seq

I'll leave Arrow and ArrowLoop to you, it's not very hard.

The main advantage of this free approach is that we can inspect a value structurally:

inspect :: FreeSF m a b -> String
inspect Id = "Id"
inspect Arr = "Arr"
inspect (Seq fsf1 fsf2) f "(Seq " ++ inspect fsf1 ++ " " ++ inspect fsf2 ++ ")"
...

main = putStrLn $ inspect $ arr (const 23) >>> arrM print

Note that this is not a Show instance because we can't peek into the inards of e.g. ArrM.

It's also possible to interpret our DSL into monadic stream functions, that's maybe useful as a sanity check:

interpret :: Monad m => FreeSF m a b -> MSF m a b
interpret Id = id
interpret (Arr f) = arr f
...

So my suggestion would be:

1. Get the free sfs from above to run
2. Reimplement iPre and accumHoldBy in terms of feedback for FreeSF
3. Take your example and write it as a FreeSF
4. Interpret it to see whether the error is still there
5. Inspect it and post the result here
6. Try to rebuild the example purely from combinators, based on the result of that inspection

[walseb]

>>> and <<< are part of the category type class. <<< is an alias for . which is simply sequential composition.

Yeah they make use of the Category type class, but they aren't actually part of it, which means I can't just edit the MSF Category instance and insert a trace. I could edit . in the MSF Category but then I wouldn't know if <<< or >>> was used because I can't override flip easily

Thanks for the instructions! This is what I got (after stealing most of your inspect function):

(Seq Arr
(Seq Arr
(Seq
(Seq Arr
(Seq
(First
(Loop
(Seq Arr
(Seq
(Seq
(Seq Arr
(Seq
(First
(Seq Arr
(Feedback Arr))) Arr))
(Seq Arr
(Seq
(First
(Seq Arr
(Feedback Arr))) Arr))) Arr)))) Arr))
(Seq Arr
(Seq Arr Arr)))))

So the problem is that

inspect (Arr a) = "Arr"

can't print the name of the function a I tried this:

inspect (Arr a) = "Arr" ++ (unsafeCoerce a)

in hopes that unsafeCoerce on functions would return the function name or something, but I just got a segfault. Maybe reflection can be used to get the function names? Or maybe this is enough to reconstruct it?

I also tried adding accumHoldBy and iPre into the GADT and implemented them like this:

inspect IPRe = "IPRe"
inspect AccumHoldBy = "AccumHoldBy"

and got these results:

(Seq Arr
(Seq Arr
(Seq
(Seq Arr
(Seq
(First
(Loop
(Seq Arr
(Seq
(Seq
(Seq Arr
(Seq
(First
(Seq Arr IPRe)) Arr))
(Seq Arr
(Seq
(First
(Seq Arr AccumHoldBy)) Arr))) Arr)))) Arr))
(Seq Arr
(Seq Arr Arr)))))

But as you can see there are still lots of arrs without functions

[turion]

and <<< are part of the category type class. <<< is an alias for . which is simply sequential composition.

Yeah they make use of the Category type class, but they aren't actually part of it, which means I can't just edit the MSF Category instance and insert a trace. I could edit . in the MSF Category but then I wouldn't know if <<< or >>> was used because I can't override flip easily

That would be fine still, because they both behave the same. Also, I believe the desugarer will only ever call one variant.

Thanks for the instructions!

Awesome you got it to work!

This is what I got (after stealing most of your inspect function):

(Seq Arr
(Seq Arr
(Seq
(Seq Arr
(Seq
(First
(Loop
(Seq Arr
(Seq
(Seq
(Seq Arr
(Seq
(First
(Seq Arr
(Feedback Arr))) Arr))
(Seq Arr
(Seq
(First
(Seq Arr
(Feedback Arr))) Arr))) Arr)))) Arr))
(Seq Arr
(Seq Arr Arr)))))

So the problem is that

inspect (Arr a) = "Arr"

can't print the name of the function a I tried this:

inspect (Arr a) = "Arr" ++ (unsafeCoerce a)

in hopes that unsafeCoerce on functions would return the function name or something, but I just got a segfault. Maybe reflection can be used to get the function names? Or maybe this is enough to reconstruct it?

I also tried adding accumHoldBy and iPre into the GADT and implemented them like this:

inspect IPRe = "IPRe"
inspect AccumHoldBy = "AccumHoldBy"

and got these results:

(Seq Arr
(Seq Arr
(Seq
(Seq Arr
(Seq
(First
(Loop
(Seq Arr
(Seq
(Seq
(Seq Arr
(Seq
(First
(Seq Arr IPRe)) Arr))
(Seq Arr
(Seq
(First
(Seq Arr AccumHoldBy)) Arr))) Arr)))) Arr))
(Seq Arr
(Seq Arr Arr)))))

But as you can see there are still lots of arrs without functions

Inserting iPre and accumHoldBy as constructors is a good call. Two other functions we'd expect to pop up are const $ Event bar and const 1. All the other functions are bookkeeping functions like your arr (\(bar, foo) -> (foo, bar)). Except that the desugarer is not as economical and introduces a lot of them.

I guess one could take this whole expression and insert holes in all the Arrs : (Seq (Arr _) (Seq (Arr _) ... and then hope that GHC can figure the types of most holes out, and then insert the appropriate bookkeeping functions. A huge type crossword puzzle.

Template Haskell?

One trick you could try is the quotation from Template Haskell (https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#template-haskell). I think it roughly works like this. Put your arrow in a file MyArrow.hs, and then create a Main.hs like this:

{-# LANGUAGE TemplateHaskell #-}

import MyArrow

main = do
  exp <- [| sf |]
  print exp

That should give you a very, very detailed syntax tree of your expression. Maybe it's possible to recover the unsugared version from that.

GHC Core

Yet another way to analyse your program is to inspect the generated GHC Core code. GHC generates binaries by first desugaring & annotating Haskell source into its Core language, and then compiles that into Assembly, interpreted byte code or LLVM. I believe Arrow proc notation is desugared in Core already.

https://stackoverflow.com/questions/10693638/how-to-dump-ghc-simplifier-output-in-human-readable-form https://github.com/bgamari/ghc-dump

[walseb]

I'm not familiar with TH but it seems like your TH example is failing because main has to return IO but the banana brackets are in the Q monad. And I haven't been able to find out how to escape the Q monad.

I tried making ghc output core on both the bearriver and the free arrow implementation using cabal build ... and cabal build -O2 ... with unreadable results. But then I tried using GHCi instead and got a lot better results (because GHCi skips lots of optimizations and just interprets the code?). This is the bearriver implementation when ran through ghci with the correct flags:

-- RHS size: {terms: 143, types: 425, coercions: 0, joins: 0/3}
sf :: SF () (Event Float)
[GblId]
sf
  = break<5>()
    let {
      ds :: forall b c. (b -> c) -> MSF (ClockInfo Identity) b c
      [LclId]
      ds = arr @ (MSF (ClockInfo Identity)) $dArrow } in
    let {
      ds1
        :: forall a b c.
           MSF (ClockInfo Identity) a b
           -> MSF (ClockInfo Identity) b c -> MSF (ClockInfo Identity) a c
      [LclId]
      ds1 = >>> @ (MSF (ClockInfo Identity)) $dArrow } in
    let {
      ds2
        :: forall b c d.
           MSF (ClockInfo Identity) b c
           -> MSF (ClockInfo Identity) (b, d) (c, d)
      [LclId]
      ds2 = first @ (MSF (ClockInfo Identity)) $dArrow } in
    ds1
      @ ()
      @ ((), ())
      @ (Event Float)
      (ds @ () @ ((), ()) (\ _ [Occ=Dead] -> ((), ())))
      (ds1
         @ ((), ())
         @ ()
         @ (Event Float)
         (ds
            @ ((), ())
            @ ()
            (\ (ds3 :: ((), ())) -> case ds3 of { (ds5, ds6) -> ds5 }))
         (ds1
            @ ()
            @ (Event Float)
            @ (Event Float)
            (ds1
               @ ()
               @ ((), ())
               @ (Event Float)
               (ds
                  @ () @ ((), ()) (\ (ds3 :: ()) -> case ds3 of { () -> ((), ()) }))
               (ds1
                  @ ((), ())
                  @ (Event Float, ())
                  @ (Event Float)
                  (ds2
                     @ ()
                     @ (Event Float)
                     @ ()
                     (loop
                        @ (MSF (ClockInfo Identity))
                        $dArrowLoop
                        @ ()
                        @ Float
                        @ (Event Float)
                        (ds1
                           @ ((), Float)
                           @ Float
                           @ (Event Float, Float)
                           (ds
                              @ ((), Float)
                              @ Float
                              (\ (ds3 :: ((), Float)) ->
                                 case ds3 of { (ds5, ds6) -> case ds5 of { () -> ds6 } }))
                           (ds1
                              @ Float
                              @ (Float, Event Float)
                              @ (Event Float, Float)
                              (ds1
                                 @ Float
                                 @ (Event Float)
                                 @ (Float, Event Float)
                                 (ds1
                                    @ Float
                                    @ ((Float, ()), ())
                                    @ (Event Float)
                                    (ds
                                       @ Float
                                       @ ((Float, ()), ())
                                       (\ (ds3 :: Float) -> ((ds3, ()), ())))
                                    (ds1
                                       @ ((Float, ()), ())
                                       @ (Event Float, ())
                                       @ (Event Float)
                                       (ds2
                                          @ (Float, ())
                                          @ (Event Float)
                                          @ ()
                                          (ds1
                                             @ (Float, ())
                                             @ (Event Float)
                                             @ (Event Float)
                                             (ds
                                                @ (Float, ())
                                                @ (Event Float)
                                                (\ (ds3 :: (Float, ())) ->
                                                   case ds3 of { (ds5, ds6) ->
                                                   break<2>(ds5) Event @ Float ds5
                                                   }))
                                             (break<1>()
                                              iPre
                                                @ (ClockInfo Identity)
                                                @ (Event Float)
                                                $dMonad
                                                (break<0>() Event @ Float (F# 1.0#)))))
                                       (ds
                                          @ (Event Float, ())
                                          @ (Event Float)
                                          (\ (ds3 :: (Event Float, ())) ->
                                             case ds3 of { (foo, ds5) ->
                                             case ds5 of { () -> foo }
                                             }))))
                                 (ds1
                                    @ (Event Float)
                                    @ (((), ()), Event Float)
                                    @ (Float, Event Float)
                                    (ds
                                       @ (Event Float)
                                       @ (((), ()), Event Float)
                                       (\ (ds3 :: Event Float) -> (((), ()), ds3)))
                                    (ds1
                                       @ (((), ()), Event Float)
                                       @ (Float, Event Float)
                                       @ (Float, Event Float)
                                       (ds2
                                          @ ((), ())
                                          @ Float
                                          @ (Event Float)
                                          (ds1
                                             @ ((), ())
                                             @ (Event Float)
                                             @ Float
                                             (ds
                                                @ ((), ())
                                                @ (Event Float)
                                                (\ (ds3 :: ((), ())) ->
                                                   case ds3 of { (ds5, ds6) ->
                                                   case ds5 of { () ->
                                                   break<4>() Event @ Float (F# 1.0#)
                                                   }
                                                   }))
                                             (break<3>()
                                              accumHoldBy
                                                @ Identity
                                                @ Float
                                                @ Float
                                                $fMonadIdentity
                                                (+ @ Float $fNumFloat)
                                                (F# 1.0#))))
                                       (ds
                                          @ (Float, Event Float)
                                          @ (Float, Event Float)
                                          (\ (ds3 :: (Float, Event Float)) -> ds3)))))
                              (ds
                                 @ (Float, Event Float)
                                 @ (Event Float, Float)
                                 (\ (ds3 :: (Float, Event Float)) ->
                                    case ds3 of { (bar, foo) -> (foo, bar) }))))))
                  (ds
                     @ (Event Float, ())
                     @ (Event Float)
                     (\ (ds3 :: (Event Float, ())) ->
                        case ds3 of { (ds5, ds6) -> case ds6 of { () -> ds5 } }))))
            (ds1
               @ (Event Float)
               @ (Event Float, ())
               @ (Event Float)
               (ds
                  @ (Event Float)
                  @ (Event Float, ())
                  (\ (ds3 :: Event Float) -> (ds3, ())))
               (ds1
                  @ (Event Float, ())
                  @ (Event Float)
                  @ (Event Float)
                  (ds
                     @ (Event Float, ())
                     @ (Event Float)
                     (\ (ds3 :: (Event Float, ())) ->
                        case ds3 of { (ds5, ds6) -> ds5 }))
                  (returnA @ (MSF (ClockInfo Identity)) @ (Event Float) $dArrow)))))

And this is what I got when I ran the free arrow implementation through GHCi

-- RHS size: {terms: 141, types: 343, coercions: 0, joins: 0/3}
sf :: FreeSF Identity () Float
[GblId]
sf
  = break<14>()
    let {
      ds :: forall b c. (b -> c) -> FreeSF Identity b c
      [LclId]
      ds = arr @ (FreeSF Identity) $dArrow } in
    let {
      ds1
        :: forall a b c.
           FreeSF Identity a b -> FreeSF Identity b c -> FreeSF Identity a c
      [LclId]
      ds1 = >>> @ (FreeSF Identity) $dArrow } in
    let {
      ds2
        :: forall b c d.
           FreeSF Identity b c -> FreeSF Identity (b, d) (c, d)
      [LclId]
      ds2 = first @ (FreeSF Identity) $dArrow } in
    ds1
      @ ()
      @ ((), ())
      @ Float
      (ds @ () @ ((), ()) (\ _ [Occ=Dead] -> ((), ())))
      (ds1
         @ ((), ())
         @ ()
         @ Float
         (ds
            @ ((), ())
            @ ()
            (\ (ds3 :: ((), ())) -> case ds3 of { (ds5, ds6) -> ds5 }))
         (ds1
            @ ()
            @ Float
            @ Float
            (ds1
               @ ()
               @ ((), ())
               @ Float
               (ds
                  @ () @ ((), ()) (\ (ds3 :: ()) -> case ds3 of { () -> ((), ()) }))
               (ds1
                  @ ((), ())
                  @ (Float, ())
                  @ Float
                  (ds2
                     @ ()
                     @ Float
                     @ ()
                     (loop
                        @ (FreeSF Identity)
                        $dArrowLoop
                        @ ()
                        @ Float
                        @ Float
                        (ds1
                           @ ((), Float)
                           @ Float
                           @ (Float, Float)
                           (ds
                              @ ((), Float)
                              @ Float
                              (\ (ds3 :: ((), Float)) ->
                                 case ds3 of { (ds5, ds6) -> case ds5 of { () -> ds6 } }))
                           (ds1
                              @ Float
                              @ (Float, Float)
                              @ (Float, Float)
                              (ds1
                                 @ Float
                                 @ Float
                                 @ (Float, Float)
                                 (ds1
                                    @ Float
                                    @ ((Float, ()), ())
                                    @ Float
                                    (ds
                                       @ Float
                                       @ ((Float, ()), ())
                                       (\ (ds3 :: Float) -> ((ds3, ()), ())))
                                    (ds1
                                       @ ((Float, ()), ())
                                       @ (Float, ())
                                       @ Float
                                       (ds2
                                          @ (Float, ())
                                          @ Float
                                          @ ()
                                          (ds1
                                             @ (Float, ())
                                             @ (Event Float)
                                             @ Float
                                             (ds
                                                @ (Float, ())
                                                @ (Event Float)
                                                (\ (ds3 :: (Float, ())) ->
                                                   case ds3 of { (ds5, ds6) ->
                                                   break<12>(ds5) Event @ Float ds5
                                                   }))
                                             (break<11>()
                                              accumHoldBy
                                                @ Identity
                                                @ Float
                                                @ Float
                                                $fMonadIdentity
                                                (+ @ Float $fNumFloat)
                                                (F# 1.0#))))
                                       (ds
                                          @ (Float, ())
                                          @ Float
                                          (\ (ds3 :: (Float, ())) ->
                                             case ds3 of { (foo, ds5) ->
                                             case ds5 of { () -> foo }
                                             }))))
                                 (ds1
                                    @ Float
                                    @ (((), ()), Float)
                                    @ (Float, Float)
                                    (ds
                                       @ Float
                                       @ (((), ()), Float)
                                       (\ (ds3 :: Float) -> (((), ()), ds3)))
                                    (ds1
                                       @ (((), ()), Float)
                                       @ (Float, Float)
                                       @ (Float, Float)
                                       (ds2
                                          @ ((), ())
                                          @ Float
                                          @ Float
                                          (ds1
                                             @ ((), ())
                                             @ Float
                                             @ Float
                                             (ds
                                                @ ((), ())
                                                @ Float
                                                (\ (ds3 :: ((), ())) ->
                                                   case ds3 of { (ds5, ds6) ->
                                                   case ds5 of { () -> F# 1.0# }
                                                   }))
                                             (break<13>()
                                              iPre @ Identity @ Float $fMonadIdentity (F# 1.0#))))
                                       (ds
                                          @ (Float, Float)
                                          @ (Float, Float)
                                          (\ (ds3 :: (Float, Float)) -> ds3)))))
                              (ds
                                 @ (Float, Float)
                                 @ (Float, Float)
                                 (\ (ds3 :: (Float, Float)) ->
                                    case ds3 of { (bar, foo) -> (foo, bar) }))))))
                  (ds
                     @ (Float, ())
                     @ Float
                     (\ (ds3 :: (Float, ())) ->
                        case ds3 of { (ds5, ds6) -> case ds6 of { () -> ds5 } }))))
            (ds1
               @ Float
               @ (Float, ())
               @ Float
               (ds @ Float @ (Float, ()) (\ (ds3 :: Float) -> (ds3, ())))
               (ds1
                  @ (Float, ())
                  @ Float
                  @ Float
                  (ds
                     @ (Float, ())
                     @ Float
                     (\ (ds3 :: (Float, ())) -> case ds3 of { (ds5, ds6) -> ds5 }))
                  (returnA @ (FreeSF Identity) @ Float $dArrow)))))

And this is the same free arrow implementation except I replaced iPre and accumHoldBy with constructors:

-- RHS size: {terms: 133, types: 407, coercions: 0, joins: 0/3}
sf :: FreeSF Identity () (Event Float)
[GblId]
sf
  = break<1>()
    let {
      ds :: forall b c. (b -> c) -> FreeSF Identity b c
      [LclId]
      ds = arr @ (FreeSF Identity) $dArrow } in
    let {
      ds1
        :: forall a b c.
           FreeSF Identity a b -> FreeSF Identity b c -> FreeSF Identity a c
      [LclId]
      ds1 = >>> @ (FreeSF Identity) $dArrow } in
    let {
      ds2
        :: forall b c d.
           FreeSF Identity b c -> FreeSF Identity (b, d) (c, d)
      [LclId]
      ds2 = first @ (FreeSF Identity) $dArrow } in
    ds1
      @ ()
      @ ((), ())
      @ (Event Float)
      (ds @ () @ ((), ()) (\ _ [Occ=Dead] -> ((), ())))
      (ds1
         @ ((), ())
         @ ()
         @ (Event Float)
         (ds
            @ ((), ())
            @ ()
            (\ (ds3 :: ((), ())) -> case ds3 of { (ds5, ds6) -> ds5 }))
         (ds1
            @ ()
            @ (Event Float)
            @ (Event Float)
            (ds1
               @ ()
               @ ((), ())
               @ (Event Float)
               (ds
                  @ () @ ((), ()) (\ (ds3 :: ()) -> case ds3 of { () -> ((), ()) }))
               (ds1
                  @ ((), ())
                  @ (Event Float, ())
                  @ (Event Float)
                  (ds2
                     @ ()
                     @ (Event Float)
                     @ ()
                     (loop
                        @ (FreeSF Identity)
                        $dArrowLoop
                        @ ()
                        @ Float
                        @ (Event Float)
                        (ds1
                           @ ((), Float)
                           @ Float
                           @ (Event Float, Float)
                           (ds
                              @ ((), Float)
                              @ Float
                              (\ (ds3 :: ((), Float)) ->
                                 case ds3 of { (ds5, ds6) -> case ds5 of { () -> ds6 } }))
                           (ds1
                              @ Float
                              @ (Float, Event Float)
                              @ (Event Float, Float)
                              (ds1
                                 @ Float
                                 @ (Event Float)
                                 @ (Float, Event Float)
                                 (ds1
                                    @ Float
                                    @ ((Float, ()), ())
                                    @ (Event Float)
                                    (ds
                                       @ Float
                                       @ ((Float, ()), ())
                                       (\ (ds3 :: Float) -> ((ds3, ()), ())))
                                    (ds1
                                       @ ((Float, ()), ())
                                       @ (Event Float, ())
                                       @ (Event Float)
                                       (ds2
                                          @ (Float, ())
                                          @ (Event Float)
                                          @ ()
                                          (ds1
                                             @ (Float, ())
                                             @ (Event Float)
                                             @ (Event Float)
                                             (ds
                                                @ (Float, ())
                                                @ (Event Float)
                                                (\ (ds3 :: (Float, ())) ->
                                                   case ds3 of { (ds5, ds6) ->
                                                   break<0>(ds5) Event @ Float ds5
                                                   }))
                                             ($WAccumHoldBy @ Identity @ (Event Float))))
                                       (ds
                                          @ (Event Float, ())
                                          @ (Event Float)
                                          (\ (ds3 :: (Event Float, ())) ->
                                             case ds3 of { (foo, ds5) ->
                                             case ds5 of { () -> foo }
                                             }))))
                                 (ds1
                                    @ (Event Float)
                                    @ (((), ()), Event Float)
                                    @ (Float, Event Float)
                                    (ds
                                       @ (Event Float)
                                       @ (((), ()), Event Float)
                                       (\ (ds3 :: Event Float) -> (((), ()), ds3)))
                                    (ds1
                                       @ (((), ()), Event Float)
                                       @ (Float, Event Float)
                                       @ (Float, Event Float)
                                       (ds2
                                          @ ((), ())
                                          @ Float
                                          @ (Event Float)
                                          (ds1
                                             @ ((), ())
                                             @ Float
                                             @ Float
                                             (ds
                                                @ ((), ())
                                                @ Float
                                                (\ (ds3 :: ((), ())) ->
                                                   case ds3 of { (ds5, ds6) ->
                                                   case ds5 of { () -> F# 1.0# }
                                                   }))
                                             ($WIPre @ Identity @ Float)))
                                       (ds
                                          @ (Float, Event Float)
                                          @ (Float, Event Float)
                                          (\ (ds3 :: (Float, Event Float)) -> ds3)))))
                              (ds
                                 @ (Float, Event Float)
                                 @ (Event Float, Float)
                                 (\ (ds3 :: (Float, Event Float)) ->
                                    case ds3 of { (bar, foo) -> (foo, bar) }))))))
                  (ds
                     @ (Event Float, ())
                     @ (Event Float)
                     (\ (ds3 :: (Event Float, ())) ->
                        case ds3 of { (ds5, ds6) -> case ds6 of { () -> ds5 } }))))
            (ds1
               @ (Event Float)
               @ (Event Float, ())
               @ (Event Float)
               (ds
                  @ (Event Float)
                  @ (Event Float, ())
                  (\ (ds3 :: Event Float) -> (ds3, ())))
               (ds1
                  @ (Event Float, ())
                  @ (Event Float)
                  @ (Event Float)
                  (ds
                     @ (Event Float, ())
                     @ (Event Float)
                     (\ (ds3 :: (Event Float, ())) ->
                        case ds3 of { (ds5, ds6) -> ds5 }))
                  (returnA @ (FreeSF Identity) @ (Event Float) $dArrow)))))

To me this isn't very readable, but then I remembered that there were a few external arrow preprocessors floating around. I first tried arrow-pp and got this result:

sf :: SF () (Event Float)
sf
  = (((loop
         ((arr (\ (_, bar) -> Event bar)) >>>
            (iPre (Event 1)) >>>
              (arr (\ foo -> ((), foo))) >>>
                ((first
                    ((arr (\ () -> (Event 1))) >>> (accumHoldBy (+) (1 :: Float))))
                   >>> (arr (\ (bar, foo) -> (foo, bar))))))
        >>> (arr (\ foo -> foo)))
       >>> returnA)

Which runs fine in bearriver somehow. So there must be some difference between the included ghc preprocessor and this one that's causing it. I would be happy just using this one instead of the included one if it wasn't for the fact that this one doesn't support banana brackets, which I'm not using yet but am looking into. So next I tried a very old arrow pre-processor: arrowp https://hackage.haskell.org/package/arrowp . Problem is everytime I try to compile arrowp I get this error: cabal: The program 'happy' is required but it could not be found I have tried installing it through nix and cabal install but I just keep getting this error. So I'm not sure where to go from here, any ideas?

[turion]

Ah I forgot. You need to use runQ in order to escape the monad in Template Haskell.

It's very interesting that arrow-pp gives a desugaring that works! That probably means that the builtin desugarer actually has a bug.

So I'm not sure where to go from here, any ideas?

In principle you should be able to take the Core code emitted from your sf, and plug that in a separate file, and compile it. Probably remove break<1>(), I don't know what that is. But the rest looks like it should compile as valid Haskell. Hopefully it will exhibit the bug! And if it does, simplify it, make it smaller step by step until the bug goes away. Then we'll see what the problem is.

[turion]

I forgot you would need to remove [LclId] and similar annotations as well.

Some ideas for simplification:

• Remove the type applications @ (Event Float)
• Simplify the case expressions with a single case: (\ (ds3 :: (Event Float, ())) -> case ds3 of { (ds5, ds6) -> ds5 })) becomes (\(ds5, ds6) -> ds5)

[walseb]

Okay so I managed to get the core down to this:

sf :: SF () Float
sf = constant () >>>
     (loop $ (arr (Event . snd) >>> accumHoldBy (+) (1 :: Float)) >>>
             arr (, ()) >>>
             second (constant 1 >>> iPre 1)) >>>
     returnA

Which also crashes with <<loop>> in bearriver, but runs fine in Yampa! So it's probably not a de-sugaring problem The issue here seems to be the parens at line 3, because if I remove them like this:

sf :: SF () Float
sf = constant () >>>
     (loop $ arr (Event . snd) >>>
             accumHoldBy (+) (1 :: Float) >>>
             arr (, ()) >>>
             second (constant 1 >>> iPre 1)) >>>
     returnA

it runs fine in bearriver and yampa. To me this doesn't make sense because I don't think precedence makes any difference with >>>. Maybe you see what the problem is here?

[turion]

Wow, great progress!

Which also crashes with <> in bearriver, but runs fine in Yampa!

That's very curious. If it loops in bearriver but runs fine in Yampa then maybe the issue is with MonadFix, which is used for the loop implementation.

The issue here seems to be the parens at line 3, because if I remove them like this:

Ok, that's really wild. That means that associativity of >>> is not preserved under loop, and that's a serious issue.

Looking at https://hackage.haskell.org/package/base-4.14.0.0/docs/Control-Arrow.html#v:-62--62--62- we see that >>> is declared as infixr 1, so f >>> g >>> h is by definition f >>> (g >>> h). But by a type class law of Category, this should be the same as (f >>> g) >>> h. But apparently it isn't, at least not up to evaluation order.

See, the Category of MSFs is strict in its output value. I think that could have to do with the problems with loop.

If you still have steam, how about the following:

1. Clone dunai
2. Build your example with the cloned library
3. In the definition of loop, make the c variable lazy by using the lazy function.
4. Test your example.

Maybe that fixes it. (But I'm not sure.)

[walseb]

Hmm using lazy on c didn't work. I will keep looking

[walseb]

So I now have more time to look into this issue. Today I was messing around and turns out if you make the MSF category composition output lazy (like you sort of suggested) it works fine. So the fix is just removing the seq here:

instance Monad m => Category (MSF m) where
  id = go
    where go = MSF $ \a -> return (a, go)
  sf2 . sf1 = MSF $ \a -> do
    (b, sf1') <- unMSF sf1 a
    (c, sf2') <- unMSF sf2 b
    let sf' = sf2' . sf1'
    c `seq` return (c, sf')

But I haven't been able to make it lazy inside the arrow loop instance without that change. Just to demonstrate the futility I made this monstrosity which still resulted in a <<loop>>.

instance MonadFix m => ArrowLoop (MSF m) where
  loop :: MSF m (b, d) (c, d) -> MSF m b c
  loop sf = MSF $ \a -> do
              rec ((b,c), sf') <- lazy $ unMSF (lazy sf) (lazy a, lazy c)
              return (lazy b, lazy (loop (lazy sf')))

Do you know where I could add a lazy and maybe fix this? I was thinking of adding a bunch of lazy to the MonadFix MSF instance declaration but I can't find it. Is it being autogenerated somewhere?

[walseb]

I finally figured it out! Turns out this is a feature not a bug. It all became clear to me when I came across this post by ivan https://discourse.haskell.org/t/dunai-bearriver-frp-new-version-and-hacktoberfest/909/5 So the original code I posted is using a pretty standard yampa pattern and relies on the value at time zero being undefined. This explains why removing the seq in MSF composition solved this problem, as it avoids forcing evaluating the SF at time zero. The solution to this problem is simply to make it a bit more verbose by defining the value at time zero, so that would mean taking my original example:

sf = proc _ -> do
  rec
    foo <- accumHoldBy (+) (1 :: Float) -< Event bar
    bar <- iPre 1 -< 1
  returnA -< foo

and turning it into:

sf = proc _ -> do
  rec
    foo <- iPre 1 <<< accumHoldBy (+) (1 :: Float) -< Event bar
    bar <- iPre 1 -< 1
  returnA -< foo

It's a bit more verbose but I think it's more predictable since you now wont have to deal with undefined being thrown in case something tries to evaluate a SF at time zero that isn't defined at time zero. Many thanks for all the help @turion!

[turion]

Great :)