-
Notifications
You must be signed in to change notification settings - Fork 0
/
Event.hs
71 lines (65 loc) · 2.26 KB
/
Event.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE JavaScriptFFI #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Reflex.OpenLayers.Event (on, on_, wrapOLEvent, wrapOLEvent_) where
import GHCJS.Marshal.Pure (PToJSVal(pToJSVal), PFromJSVal(pFromJSVal))
import GHCJS.Foreign.Callback (
OnBlocked(ContinueAsync)
, syncCallback1'
, syncCallback1
, releaseCallback
)
import GHCJS.Foreign.QQ
import GHCJS.Types (JSVal, jsval)
import Reflex.Dom
import Reflex.Host.Class
import Control.Monad.IO.Class (MonadIO(liftIO))
import Data.Dependent.Sum (DSum (..))
on :: (PToJSVal a, PToJSVal b, PFromJSVal e)
=> String -> a -> (e -> IO b) -> IO (IO ())
on eventName ob cb = do
cb' <- syncCallback1' (fmap pToJSVal . cb . pFromJSVal)
let jsCb = jsval cb'
key :: JSVal <- [jsu|$r=`ob.on(`eventName, `jsCb);|]
return ([jsu_|`ob.unByKey(`key);|] >> releaseCallback cb')
on_ :: (PFromJSVal e, PToJSVal a)
=> String -> a -> (e -> IO ()) -> IO (IO ())
on_ eventName ob cb = do
cb' <- syncCallback1 ContinueAsync (cb . pFromJSVal)
let jsCb = jsval cb'
key :: JSVal <- [jsu|$r=`ob.on(`eventName, `jsCb);|]
return ([jsu_|`ob.unByKey(`key);|] >> releaseCallback cb')
wrapOLEvent
:: forall (m :: * -> *) t (h :: * -> *) t1 a e a1.
( MonadReflexCreateTrigger t1 m, HasPostGui t h m
, PFromJSVal e
, PToJSVal a
, EventTrigger t1 ~ EventTrigger t
)
=> String -> a -> (e -> IO a1) -> m (Event t1 a1)
wrapOLEvent eventName ob cb = do
postGui <- askPostGui
runWithActions <- askRunWithActions
newEventWithTrigger $ \trig -> do
unsubscribe <- liftIO $ on_ eventName ob $ \e -> do
v <- cb e
postGui $ runWithActions [trig :=> return v]
return (liftIO unsubscribe)
wrapOLEvent_
:: forall (m :: * -> *) t (h :: * -> *) t1 a a1.
( HasPostGui t h m
, MonadReflexCreateTrigger t1 m
, PToJSVal a
, EventTrigger t1 ~ EventTrigger t
)
=> String -> a -> IO a1 -> m (Event t1 a1)
wrapOLEvent_ eventName ob cb = do
postGui <- askPostGui
runWithActions <- askRunWithActions
newEventWithTrigger $ \trig -> do
unsubscribe <- liftIO $ on_ eventName ob $ \(_::JSVal) -> do
v <- cb
postGui $ runWithActions [trig :=> return v]
return (liftIO unsubscribe)