Turning requestAnimationFrame into an Event t ()

Question

Using Reflex-DOM, I'd like to make an Event t () that fires when the browser is ready to paint the next frame, i.e. when requestAnimationFrame fires. I tried it like this:

{-# LANGUAGE RecursiveDo, TypeFamilies #-}

import Reflex.Dom
import Reflex.Host.Class

import GHCJS.DOM (currentWindow)
import GHCJS.DOM.Window as Window
import GHCJS.DOM.Types (RequestAnimationFrameCallback(..))
import GHCJS.Foreign.Callback

import Control.Monad
import Control.Monad.IO.Class

refresh win = do
    (event, ref) <- newEventWithTriggerRef
    postGui <- askPostGui
    rec cb <- liftIO $ asyncCallback1 $ \_timestamp -> do
            scheduleNext
            putStrLn "about to fire the event"
            postGui $ void $ fireEventRef ref ()
            putStrLn "event fired"
        let scheduleNext = Window.requestAnimationFrame win $ Just $ RequestAnimationFrameCallback cb
        liftIO scheduleNext
    return event

My test app is the following:

main :: IO ()
main = mainWidget $ do
    Just win <- liftIO currentWindow
    tick <- refresh win
    display =<< count tick

However, the count doesn't increase. On the browser's JS console, however, I do see both about to fire the event and event fired printed repeatedly.

Answer 1

I've tried http://hackage.haskell.org/package/jsaddle-0.9.7.1/docs/Language-Javascript-JSaddle-Run.html#v:nextAnimationFrame, but failed miserably with a memory leaking infinite loop.

The following works quite nicely:

base-4.13.0.0, jsaddle-0.9.7.1, jsaddle-dom-0.9.4.1, reflex-0.8.0.0, reflex-dom-0.6.1.0

{-# LANGUAGE MonoLocalBinds      #-}
{-# LANGUAGE PackageImports      #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Reflex.Missing.AniFrame where

import qualified "base" Control.Monad.IO.Class as Monad (liftIO)
import qualified "jsaddle" Language.Javascript.JSaddle as JS (JSCallAsFunction,fun,function)
import qualified "jsaddle-dom" GHCJS.DOM as DOM (currentWindowUnchecked)
import qualified "jsaddle-dom" GHCJS.DOM.Types as DOM (liftJSM,fromJSValUnchecked,Callback(..),RequestAnimationFrameCallback(..))
import qualified "jsaddle-dom" GHCJS.DOM.Window as DOM (requestAnimationFrame_)
import qualified "reflex" Reflex as Reflex
import qualified "reflex-dom" Reflex.Dom as RDOM

type MilliSeconds = Double -- since start of program when in webkit2gtk3

requestAnimationFrameEvents :: forall t m . (RDOM.MonadWidget t m) => m (Reflex.Event t MilliSeconds)
requestAnimationFrameEvents = do
        (te,f) <- Reflex.newTriggerEvent
        let f' :: JS.JSCallAsFunction
            f' = JS.fun $ \meth this (param:_) -> do
                (t::Double) <- DOM.liftJSM $ DOM.fromJSValUnchecked param
                Monad.liftIO $ f t
        ff' <- DOM.liftJSM $ DOM.RequestAnimationFrameCallback . DOM.Callback <$> JS.function f'
        win <- DOM.liftJSM DOM.currentWindowUnchecked
        let register = DOM.requestAnimationFrame_ win ff' >> RDOM.blank
        DOM.liftJSM register
        --accumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (f a)
        te' <- Reflex.accumMaybe (\past now -> if now/=past then Just now else Nothing) 0 te
        Reflex.performEvent_ $ (\_ -> DOM.liftJSM register) <$> te'
        return te'