module Haste.Events.Core (
Event (..), MonadEvent (..),
HandlerInfo,
unregisterHandler, onEvent, preventDefault
) where
import Haste.Prim
import Haste.DOM.Core
import Haste.Foreign
import Control.Monad.IO.Class
import Data.IORef
import System.IO.Unsafe
class MonadIO m => MonadEvent m where
mkHandler :: (a -> m ()) -> m (a -> IO ())
instance MonadEvent IO where
mkHandler = return
class Event evt where
type EventData evt
eventName :: evt -> JSString
eventData :: evt -> JSAny -> IO (EventData evt)
data HandlerInfo = HandlerInfo {
handlerEvent :: JSString,
handlerElem :: Elem,
handlerFun :: JSAny
}
unregisterHandler :: HandlerInfo -> IO ()
unregisterHandler (HandlerInfo ev el f) = unregEvt el ev f
evtRef :: IORef (Maybe JSAny)
evtRef = unsafePerformIO $ newIORef Nothing
setEvtRef :: JSAny -> IO ()
setEvtRef = writeIORef evtRef . Just
preventDefault :: IO ()
preventDefault = readIORef evtRef >>= go
where
go :: Maybe JSAny -> IO ()
go = ffi "(function(e){if(e){e.preventDefault();}})"
onEvent :: (MonadEvent m, IsElem el, Event evt)
=> el
-> evt
-> (EventData evt -> m ())
-> m HandlerInfo
onEvent el evt f = do
f' <- mkHandler $ \o -> prepareEvent o >>= f
hdl <- liftIO $ setEvt e name f'
return $ HandlerInfo {
handlerEvent = name,
handlerElem = e,
handlerFun = hdl
}
where
name = eventName evt
e = elemOf el
prepareEvent o = liftIO $ do
setEvtRef o
eventData evt o
setEvt :: Elem -> JSString -> (JSAny -> IO ()) -> IO JSAny
setEvt = ffi "(function(e,name,f){e.addEventListener(name,f,false);\
\return [f];})"
unregEvt :: Elem -> JSString -> JSAny -> IO ()
unregEvt = ffi "(function(e,name,f){e.removeEventListener(name,f[0]);})"