{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Subscription.Window
-- Copyright   :  (C) 2016-2018 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
----------------------------------------------------------------------------
module Miso.Subscription.Window where

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

import GHCJS.Marshal
import JavaScript.Object
import JavaScript.Object.Internal

import Miso.Effect (Sub)
import Miso.Event
import Miso.FFI
import Miso.String

import Data.Aeson.Types (parseEither)

-- | Captures window coordinates changes as they occur and writes them to
-- an event sink
windowCoordsSub :: ((Int, Int) -> action) -> Sub action
windowCoordsSub :: ((Int, Int) -> action) -> Sub action
windowCoordsSub (Int, Int) -> action
f = \Sink action
sink -> do
  IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> ((Int, Int) -> IO ()) -> (Int, Int) -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sink action
sink Sink action -> ((Int, Int) -> action) -> (Int, Int) -> IO ()
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
windowInnerHeight JSM (Int -> (Int, Int)) -> JSM Int -> JSM (Int, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSM Int
windowInnerWidth
  MisoString -> (JSVal -> JSM ()) -> JSM ()
windowAddEventListener MisoString
"resize" ((JSVal -> JSM ()) -> JSM ()) -> (JSVal -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$
    \JSVal
windowEvent -> do
      JSVal
target <- JSString -> Object -> JSM JSVal
getProp JSString
"target" (JSVal -> Object
Object JSVal
windowEvent)
      Just Int
w <- JSVal -> JSM (Maybe Int)
forall a. FromJSVal a => JSVal -> JSM (Maybe a)
fromJSVal (JSVal -> JSM (Maybe Int)) -> JSM JSVal -> JSM (Maybe Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSString -> Object -> JSM JSVal
getProp JSString
"innerWidth" (JSVal -> Object
Object JSVal
target)
      Just Int
h <- JSVal -> JSM (Maybe Int)
forall a. FromJSVal a => JSVal -> JSM (Maybe a)
fromJSVal (JSVal -> JSM (Maybe Int)) -> JSM JSVal -> JSM (Maybe Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSString -> Object -> JSM JSVal
getProp JSString
"innerHeight" (JSVal -> Object
Object JSVal
target)
      IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> Sink action -> action -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sink action
sink (action -> JSM ()) -> action -> JSM ()
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> action
f (Int
h, Int
w)

-- | @windowSub eventName decoder toAction@ is a subscription which parallels the
-- attribute handler `on`, providing a subscription to listen to window level events.
windowSub :: MisoString -> Decoder r -> (r -> action) -> Sub action
windowSub :: 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@ is a subscription which parallels the
-- attribute handler `on`, providing a subscription to listen to window level events.
windowSubWithOptions :: Options -> MisoString -> Decoder r -> (r -> action) -> Sub action
windowSubWithOptions :: Options -> MisoString -> Decoder r -> (r -> action) -> Sub action
windowSubWithOptions Options{Bool
stopPropagation :: Options -> Bool
preventDefault :: Options -> Bool
stopPropagation :: Bool
preventDefault :: Bool
..} MisoString
eventName Decoder{DecodeTarget
Value -> Parser r
decodeAt :: forall a. Decoder a -> DecodeTarget
decoder :: forall a. Decoder a -> Value -> Parser a
decodeAt :: DecodeTarget
decoder :: Value -> Parser r
..} r -> action
toAction = \Sink action
sink -> do
  MisoString -> (JSVal -> JSM ()) -> JSM ()
windowAddEventListener MisoString
eventName ((JSVal -> JSM ()) -> JSM ()) -> (JSVal -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$
    \JSVal
e -> do
      JSVal
decodeAtVal <- DecodeTarget -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal DecodeTarget
decodeAt
      Just Value
v <- JSVal -> JSM (Maybe Value)
forall a. FromJSVal a => JSVal -> JSM (Maybe a)
fromJSVal (JSVal -> JSM (Maybe Value)) -> JSM JSVal -> JSM (Maybe Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal -> JSVal -> JSM JSVal
objectToJSON JSVal
decodeAtVal JSVal
e
      case (Value -> Parser r) -> Value -> Either String r
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser r
decoder Value
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 (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ JSVal -> JSM ()
eventStopPropagation JSVal
e
          Bool -> JSM () -> JSM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
preventDefault (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ JSVal -> JSM ()
eventPreventDefault JSVal
e
          IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Sink action
sink (r -> action
toAction r
r))