FoldCofreeEvent.hs

-- the basic idea, without mentioning "comonad":

data RecEvent t a = RecEvent
  { rec_current :: a
  , rec_next :: R.Event t (RecEvent t a)
  }

foldRecEvent :: R.Reflex t => RecEvent t a -> R.PushM t (R.Dynamic t a)
foldRecEvent r1@(RecEvent _ e1) = do
  e1' <- R.headE e1
  rec flattenedD <- R.holdDyn r1 $ flattenedE
      let flattenedE =
            R.leftmost [e1', R.switch $ R.current $ flattenedD <&> rec_next]
  pure $ rec_current <$> flattenedD


-- but RecEvent is just a trivial free comonad.
-- so instead without a custom datatype:

foldCofreeEvent
  :: (R.Reflex t, R.MonadHold t m, MonadFix m)
  => Cofree (R.Event t) a
  -> m (R.Dynamic t a)
foldCofreeEvent cf1@(_:<e1) = do
  e1' <- R.headE e1
  rec flattenedD <- R.holdDyn cf1 flattenedE
      let flattenedE =
            R.leftmost [e1', R.switch $ R.current $ unwrap <$> flattenedD]
  pure $ extract <$> flattenedD


-- Now we can use that function to write interpreters
-- for free _monads_:
-- the name is.. completely random.
-- Should probably call it .. "interpretFreeMonadInNetwork" or something?

xemira
  :: forall t m f output
   . (R.Reflex t, R.MonadHold t m, MonadFix m)
  => Free f output
  -> (forall a . f a -> R.Event t () -> (output, R.Event t a))
  -> m (R.Dynamic t output)
xemira script f = foldCofreeEvent (mkCofree R.never script)
 where
  mkCofree :: R.Event t () -> Free f output -> Cofree (R.Event t) output
  mkCofree _initE (Pure x) = x :< R.never
  mkCofree initE (Free g) =
    let (d, e) = f g initE
        innerE = flip R.pushAlways e $ \script' -> do
          e' <- R.headE e
          pure $ mkCofree (void e') script'
    in  d :< innerE

-- or with a monadic context in each step:

xemiraM
  :: forall t m f output
   . (R.Reflex t, R.MonadHold t m, MonadFix m)
  => Free f output
  -> (  forall a m'
      . (R.MonadHold t m', MonadFix m')
     => f a
     -> R.Event t ()
     -> m' (output, R.Event t a)
     )
  -> m (R.Dynamic t output)
xemiraM script f = foldCofreeEvent =<< mkCofree R.never script
 where
  mkCofree
    :: (R.MonadHold t m', MonadFix m')
    => R.Event t ()
    -> Free f output
    -> m' (Cofree (R.Event t) output)
  mkCofree _initE (Pure x) = pure $ x :< R.never
  mkCofree initE  (Free g) = do
    (d, e) <- f g initE
    let innerE = flip R.pushAlways e $ \script' -> do
          e' <- R.headE e
          mkCofree (void e') script'
    pure $ d :< innerE