-----------------------------------------------------------------------------
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Subscription.Window
-- Copyright   :  (C) 2016-2025 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
----------------------------------------------------------------------------
module Miso.Subscription.Window
  ( -- *** Subscription
    windowSub
  , windowCoordsSub
  , windowPointerMoveSub
  , windowSubWithOptions
  ) where
-----------------------------------------------------------------------------
import Control.Monad
import Language.Javascript.JSaddle
import Data.Aeson.Types (parseEither)
-----------------------------------------------------------------------------
import Miso.Event
import Miso.Effect
import qualified Miso.FFI.Internal as FFI
import Miso.String
-----------------------------------------------------------------------------
-- | Captures window coordinates changes as they occur and writes them to
-- an event sink
windowCoordsSub :: ((Int, Int) -> action) -> Sub action
windowCoordsSub :: forall action. ((Int, Int) -> action) -> Sub action
windowCoordsSub (Int, Int) -> action
f = \Sink action
write -> do
  Sink action
write Sink action -> ((Int, Int) -> action) -> (Int, Int) -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> action
f ((Int, Int) -> JSM ()) -> JSM (Int, Int) -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (,) (Int -> Int -> (Int, Int)) -> JSM Int -> JSM (Int -> (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSM Int
FFI.windowInnerHeight JSM (Int -> (Int, Int)) -> JSM Int -> JSM (Int, Int)
forall a b. JSM (a -> b) -> JSM a -> JSM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSM Int
FFI.windowInnerWidth
  MisoString -> (JSVal -> JSM ()) -> JSM ()
FFI.windowAddEventListener MisoString
"resize" ((JSVal -> JSM ()) -> JSM ()) -> (JSVal -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$
    \JSVal
windowEvent -> do
      target <- JSString -> Object -> JSM JSVal
getProp JSString
"target" (JSVal -> Object
Object JSVal
windowEvent)
      Just w <- fromJSVal =<< getProp "innerWidth" (Object target)
      Just h <- fromJSVal =<< getProp "innerHeight" (Object target)
      write $ f (h, w)
-----------------------------------------------------------------------------
-- | @windowSub eventName decoder toAction@ provides a subscription
-- to listen to window level events.
windowSub :: MisoString -> Decoder r -> (r -> action) -> Sub action
windowSub :: forall r action.
MisoString -> Decoder r -> (r -> action) -> Sub action
windowSub = Options -> MisoString -> Decoder r -> (r -> action) -> Sub action
forall r action.
Options -> MisoString -> Decoder r -> (r -> action) -> Sub action
windowSubWithOptions Options
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 :: forall r action.
Options -> MisoString -> Decoder r -> (r -> action) -> Sub action
windowSubWithOptions Options{Bool
preventDefault :: Bool
stopPropagation :: Bool
stopPropagation :: Options -> Bool
preventDefault :: Options -> Bool
..} MisoString
eventName Decoder{DecodeTarget
Value -> Parser r
decoder :: Value -> Parser r
decodeAt :: DecodeTarget
decodeAt :: forall a. Decoder a -> DecodeTarget
decoder :: forall a. Decoder a -> Value -> Parser a
..} r -> action
toAction = \Sink action
write ->
  MisoString -> (JSVal -> JSM ()) -> JSM ()
FFI.windowAddEventListener MisoString
eventName ((JSVal -> JSM ()) -> JSM ()) -> (JSVal -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \JSVal
e -> do
      decodeAtVal <- DecodeTarget -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal DecodeTarget
decodeAt
      Just v <- fromJSVal =<< FFI.eventJSON decodeAtVal e
      case parseEither decoder v of
        Left String
s -> String -> JSM ()
forall a. HasCallStack => String -> a
error (String -> JSM ()) -> String -> JSM ()
forall a b. (a -> b) -> a -> b
$ String
"Parse error on " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> MisoString -> String
unpack MisoString
eventName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s
        Right r
r -> do
          Bool -> JSM () -> JSM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
stopPropagation (JSVal -> JSM ()
FFI.eventStopPropagation JSVal
e)
          Bool -> JSM () -> JSM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
preventDefault (JSVal -> JSM ()
FFI.eventPreventDefault JSVal
e)
          Sink action
write (r -> action
toAction r
r)
-----------------------------------------------------------------------------
-- | @window.addEventListener ("pointermove", (event) => handle(event))@
-- A 'Sub' to handle @PointerEvent@s on window
windowPointerMoveSub :: (PointerEvent -> action) -> Sub action
windowPointerMoveSub :: forall action. (PointerEvent -> action) -> Sub action
windowPointerMoveSub = MisoString
-> Decoder PointerEvent -> (PointerEvent -> action) -> Sub action
forall r action.
MisoString -> Decoder r -> (r -> action) -> Sub action
windowSub MisoString
"pointermove" Decoder PointerEvent
pointerDecoder