Core.hs

{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts #-}
-- | Basic framework for event handling.
module Haste.Events.Core (
    Event (..), MonadEvent (..), EventSource (..),
    HandlerInfo,
    unregisterHandler, onEvent, preventDefault, stopPropagation
  ) where
import Haste.Prim
import Haste.DOM.Core
import Haste.Prim.Foreign
import Control.Monad.IO.Class
import Data.IORef
import System.IO.Unsafe

-- | Any type whose underlying DOM object can receive events.
class EventSource a where
  eventSource :: a -> JSAny

instance EventSource Elem where
  eventSource (Elem e) = e

-- | Any monad in which we're able to handle events.
class MonadIO m => MonadEvent m where
  mkHandler :: (a -> m ()) -> m (a -> IO ())

instance MonadEvent IO where
  mkHandler = return

-- | Any type that describes an event.
class Event evt where
  -- | The type of data to pass to handlers for this event.
  type EventData evt

  -- | The name of this event, as expected by the DOM.
  eventName :: evt -> JSString

  -- | Construct event data from the event identifier and the JS event object.
  eventData :: evt -> JSAny -> IO (EventData evt)

-- | Information about an event handler.
data HandlerInfo = HandlerInfo {
    -- | Name of the handler's event.
    handlerEvent :: JSString,
    -- | Element the handler is set on.
    handlerElem  :: JSAny,
    -- | Handle to handler function.
    handlerFun   :: JSAny
  }

-- | Unregister an event handler.
unregisterHandler :: MonadIO m => HandlerInfo -> m ()
unregisterHandler (HandlerInfo ev el f) = liftIO $ unregEvt el ev f

-- | Reference to the event currently being handled.
{-# NOINLINE evtRef #-}
evtRef :: IORef (Maybe JSAny)
evtRef = unsafePerformIO $ newIORef Nothing

{-# INLINE setEvtRef #-}
setEvtRef :: JSAny -> IO ()
setEvtRef = writeIORef evtRef . Just

-- | Prevent the event being handled from resolving normally.
--   Does nothing if called outside an event handler.
preventDefault :: MonadIO m => m ()
preventDefault = liftIO $ readIORef evtRef >>= preventDefault'

preventDefault' :: Maybe JSAny -> IO ()
preventDefault' = ffi "(function(e){if(e){e.preventDefault();}})"

-- | Stop the event being handled from propagating.
--   Does nothing if called outside an event handler.
stopPropagation :: MonadIO m => m ()
stopPropagation = liftIO $ readIORef evtRef >>= stopPropagation'

stopPropagation' :: Maybe JSAny -> IO ()
stopPropagation' = ffi "(function(e){if(e){e.stopPropagation();}})"

-- | Set an event handler on a DOM element.
onEvent :: (MonadEvent m, EventSource el, Event evt)
        => el            -- ^ Element to set handler on.
        -> evt           -- ^ Event to handle.
        -> (EventData evt -> m ()) -- ^ Event handler.
        -> m HandlerInfo -- ^ Information about the handler.
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    = eventSource el
    prepareEvent o = liftIO $ do
      setEvtRef o
      eventData evt o

-- | Set an event handler on an element, returning a reference to the handler
--   exactly as seen by @addEventListener@. We can't reuse the reference to
--   the Haskell function as the FFI does some marshalling to functions,
--   meaning that the same function marshalled twice won't be reference equal
--   to each other.
setEvt :: JSAny -> JSString -> (JSAny -> IO ()) -> IO JSAny
setEvt = ffi "(function(e,name,f){e.addEventListener(name,f,false);\
             \return [f];})"

-- | Unregister an event.
--   Note @f[0]@ and corresponding @[f]@ in 'setEvt'; this is a workaround for
--   a bug causing functions being packed into anything to be accidentally
--   called. Remove when properly fixed.
unregEvt :: JSAny -> JSString -> JSAny -> IO ()
unregEvt = ffi "(function(e,name,f){e.removeEventListener(name,f[0]);})"