module Haste.Callback (
GenericCallback (..), toCallback,
setCallback, setCallback', JSFun (..), mkCallback, Event (..),
setTimeout, setTimeout', Callback (..), onEvent, onEvent',
jsSetCB, jsSetTimeout, evtName
) where
import Haste.Prim
import Haste.DOM
import Haste.Concurrent.Monad
import Data.String
import Control.Monad.IO.Class
newtype JSFun a = JSFun (Ptr a)
#ifdef __HASTE__
foreign import ccall jsSetCB :: Elem -> JSString -> JSFun a -> IO Bool
foreign import ccall jsSetTimeout :: Int -> JSFun a -> IO ()
#else
jsSetCB :: Elem -> JSString -> JSFun a -> IO Bool
jsSetCB = error "Tried to use jsSetCB on server side!"
jsSetTimeout :: Int -> JSFun a -> IO ()
jsSetTimeout = error "Tried to use jsSetTimeout on server side!"
#endif
toCallback :: (Monad m, GenericCallback a m) => a -> m (CB a)
toCallback f = do
iofy <- mkIOfier f
return $ mkcb iofy f
class GenericCallback a m where
type CB a
mkcb :: (m () -> IO ()) -> a -> CB a
mkIOfier :: a -> m (m () -> IO ())
instance GenericCallback (IO ()) IO where
type CB (IO ()) = IO ()
mkcb toIO m = toIO m
mkIOfier _ = return id
instance GenericCallback b m => GenericCallback (a -> b) m where
type CB (a -> b) = a -> CB b
mkcb toIO f = \x -> mkcb toIO (f x)
mkIOfier f = mkIOfier (f undefined)
mkCallback :: a -> JSFun a
mkCallback = JSFun . toPtr
class Callback a where
constCallback :: IO () -> a
instance Callback (IO ()) where
constCallback = id
instance Callback (a -> IO ()) where
constCallback = const
data Event m a where
OnLoad :: Event m (m ())
OnUnload :: Event m (m ())
OnChange :: Event m (m ())
OnFocus :: Event m (m ())
OnBlur :: Event m (m ())
OnMouseMove :: Event m ((Int, Int) -> m ())
OnMouseOver :: Event m ((Int, Int) -> m ())
OnMouseOut :: Event m (m ())
OnClick :: Event m (Int -> (Int, Int) -> m ())
OnDblClick :: Event m (Int -> (Int, Int) -> m ())
OnMouseDown :: Event m (Int -> (Int, Int) -> m ())
OnMouseUp :: Event m (Int -> (Int, Int) -> m ())
OnKeyPress :: Event m (Int -> m ())
OnKeyUp :: Event m (Int -> m ())
OnKeyDown :: Event m (Int -> m ())
OnSubmit :: Event m (m ())
OnWheel :: Event m ((Int, Int) -> (Double, Double, Double) -> m ())
asEvtTypeOf :: Event m a -> a -> a
asEvtTypeOf _ = id
instance Eq (Event m a) where
a == b = evtName a == (evtName b :: String)
instance Ord (Event m a) where
compare a b = compare (evtName a) (evtName b :: String)
evtName :: IsString s => Event m a -> s
evtName evt =
case evt of
OnLoad -> "load"
OnUnload -> "unload"
OnClick -> "click"
OnDblClick -> "dblclick"
OnMouseDown -> "mousedown"
OnMouseUp -> "mouseup"
OnMouseMove -> "mousemove"
OnMouseOver -> "mouseover"
OnMouseOut -> "mouseout"
OnKeyPress -> "keypress"
OnKeyUp -> "keyup"
OnKeyDown -> "keydown"
OnChange -> "change"
OnFocus -> "focus"
OnBlur -> "blur"
OnSubmit -> "submit"
OnWheel -> "wheel"
onEvent :: MonadIO m => Elem -> Event IO a -> a -> m Bool
onEvent = setCallback
onEvent' :: (ToConcurrent a, MonadIO m) => Elem -> Event CIO a -> Async a -> m Bool
onEvent' = setCallback'
setCallback :: MonadIO m => Elem -> Event IO a -> a -> m Bool
setCallback e evt f =
liftIO $ jsSetCB e (evtName evt) (mkCallback $! f)
setCallback' :: (ToConcurrent a, MonadIO m)
=> Elem
-> Event CIO a
-> Async a
-> m Bool
setCallback' e evt f =
liftIO $ jsSetCB e (evtName evt) (mkCallback $! f')
where
f' = asEvtTypeOf evt (async f)
setTimeout :: MonadIO m => Int -> IO () -> m ()
setTimeout delay cb =
liftIO $ jsSetTimeout delay (mkCallback $! cb)
setTimeout' :: MonadIO m => Int -> CIO () -> m ()
setTimeout' delay cb =
liftIO $ jsSetTimeout delay (mkCallback $! concurrent cb)