Add resource finalization on Window Sub.

This introduces the `bracket` pattern to `Sub`, specifically on
`window`, this allows resource finalization and works will with
top-level, long running `Sub`, or dynamically-generated `Sub`.

- [x] Introduce `removeEventListener`, windowRemoveEventListener
- [x] Refactor `Subscription.Window`
- [x] Use empty `MVar` to block on processing portion of `Sub`
- [x] Use `bracket` pattern

Author: dmjio

src/Miso/FFI/Internal.hs

@@ -29,10 +29,12 @@ module Miso.FFI.Internal
    , syncPoint
    -- * Events
    , addEventListener
+   , removeEventListener
    , eventPreventDefault
    , eventStopPropagation
    -- * Window
    , windowAddEventListener
+   , windowRemoveEventListener
    , windowInnerHeight
    , windowInnerWidth
    -- * Performance
@@ -191,22 +193,48 @@ addEventListener
   -> (JSVal -> JSM ())
   -- ^ Callback which will be called when the event occurs,
   -- the event will be passed to it as a parameter.
-  -> JSM ()
+  -> JSM Function
 addEventListener self name cb = do
-  _ <- self # "addEventListener" $ (name, asyncFunction handle)
-  pure ()
+  cb_ <- asyncFunction handle
+  void $ self # "addEventListener" $ (name, cb_)
+  pure cb_
     where
       handle _ _ []    = error "addEventListener: no args, impossible"
       handle _ _ (x:_) = cb x
 -----------------------------------------------------------------------------
+-- | Register an event listener on given target.
+removeEventListener
+  :: JSVal
+  -- ^ Event target on which we want to register event listener
+  -> MisoString
+  -- ^ Type of event to listen to (e.g. "click")
+  -> Function
+  -- ^ Callback which will be called when the event occurs,
+  -- the event will be passed to it as a parameter.
+  -> JSM ()
+removeEventListener self name cb =
+  void $ self # "removeEventListener" $ (name, cb)
+-----------------------------------------------------------------------------
+-- | Registers an event listener on window
+windowRemoveEventListener
+  :: MisoString
+  -- ^ Type of event to listen to (e.g. "click")
+  -> Function
+  -- ^ Callback which will be called when the event occurs,
+  -- the event will be passed to it as a parameter.
+  -> JSM ()
+windowRemoveEventListener name cb = do
+  win <- jsg "window"
+  removeEventListener win name cb
+-----------------------------------------------------------------------------
 -- | Registers an event listener on window
 windowAddEventListener
   :: MisoString
   -- ^ Type of event to listen to (e.g. "click")
   -> (JSVal -> JSM ())
   -- ^ Callback which will be called when the event occurs,
   -- the event will be passed to it as a parameter.
-  -> JSM ()
+  -> JSM Function
 windowAddEventListener name cb = do
   win <- jsg "window"
   addEventListener win name cb

src/Miso/Subscription/History.hs

@@ -92,7 +92,7 @@ uriSub = \f sink -> do
   void . FFI.forkJSM . forever $ do
     liftIO (wait chan)
     sink . f =<< getURI
-  FFI.windowAddEventListener (ms "popstate") $ \_ ->
+  void $ FFI.windowAddEventListener (ms "popstate") $ \_ ->
     sink . f =<< getURI
 -----------------------------------------------------------------------------
 pushStateNoModel :: URI -> JSM ()

src/Miso/Subscription/Window.hs

@@ -16,28 +16,26 @@ module Miso.Subscription.Window
   , windowCoordsSub
   , windowPointerMoveSub
   , windowSubWithOptions
+  -- *** Types
+  , Coord
   ) where
 -----------------------------------------------------------------------------
-import Control.Monad
-import Language.Javascript.JSaddle
-import Data.Aeson.Types (parseEither)
+import           Control.Monad.IO.Class (liftIO)
+import           Control.Concurrent.MVar
+import           Control.Monad
+import           Language.Javascript.JSaddle
+import           Data.Aeson.Types (parseEither)
 -----------------------------------------------------------------------------
-import Miso.Event
-import Miso.Effect
+import           Miso.Event
+import           Miso.Effect
 import qualified Miso.FFI.Internal as FFI
-import Miso.String
+import           Miso.String
+import           Miso.Canvas (Coord)
 -----------------------------------------------------------------------------
 -- | Captures window coordinates changes as they occur and writes them to
 -- an event sink
-windowCoordsSub :: ((Int, Int) -> action) -> Sub action
-windowCoordsSub f = \write -> do
-  write . f =<< (,) <$> FFI.windowInnerHeight <*> FFI.windowInnerWidth
-  FFI.windowAddEventListener "resize" $
-    \windowEvent -> do
-      target <- getProp "target" (Object windowEvent)
-      Just w <- fromJSVal =<< getProp "innerWidth" (Object target)
-      Just h <- fromJSVal =<< getProp "innerHeight" (Object target)
-      write $ f (h, w)
+windowCoordsSub :: (Coord -> action) -> Sub action
+windowCoordsSub f = windowPointerMoveSub (f . client)
 -----------------------------------------------------------------------------
 -- | @windowSub eventName decoder toAction@ provides a subscription
 -- to listen to window level events.
@@ -47,18 +45,33 @@ windowSub = windowSubWithOptions defaultOptions
 -- | @windowSubWithOptions options eventName decoder toAction@ provides a
 -- subscription to listen to window level events.
 windowSubWithOptions :: Options -> MisoString -> Decoder r -> (r -> action) -> Sub action
-windowSubWithOptions Options{..} eventName Decoder{..} toAction = \write ->
-  FFI.windowAddEventListener eventName $ \e -> do
-      decodeAtVal <- toJSVal decodeAt
-      Just v <- fromJSVal =<< FFI.eventJSON decodeAtVal e
-      case parseEither decoder v of
-        Left s -> error $ "Parse error on " <> unpack eventName <> ": " <> s
-        Right r -> do
-          when stopPropagation (FFI.eventStopPropagation e)
-          when preventDefault (FFI.eventPreventDefault e)
-          write (toAction r)
+windowSubWithOptions Options{..} eventName Decoder {..} toAction = \sink ->
+  createSub acquire release sink
+    where
+      release =
+        FFI.windowRemoveEventListener eventName
+      acquire sink =
+        FFI.windowAddEventListener eventName $ \e -> do
+          decodeAtVal <- toJSVal decodeAt
+          v <- fromJSValUnchecked =<< FFI.eventJSON decodeAtVal e
+          case parseEither decoder v of
+            Left s ->
+              error $ "windowSubWithOptions: Parse error on " <> unpack eventName <> ": " <> s
+            Right r -> do
+              when stopPropagation (FFI.eventStopPropagation e)
+              when preventDefault (FFI.eventPreventDefault e)
+              sink (toAction r)
 -----------------------------------------------------------------------------
 -- | @window.addEventListener ("pointermove", (event) => handle(event))@
 -- A 'Sub' to handle @PointerEvent@s on window
 windowPointerMoveSub :: (PointerEvent -> action) -> Sub action
 windowPointerMoveSub = windowSub "pointermove" pointerDecoder
+-----------------------------------------------------------------------------
+createSub :: (Sink action -> JSM a) -> (a -> JSM b) -> Sub action
+createSub acquire release = \sink -> do 
+  mvar <- liftIO newEmptyMVar
+  bracket
+    (acquire sink)
+    release
+    (\_ -> liftIO (takeMVar mvar))
+-----------------------------------------------------------------------------