{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Shpadoinkle.Html.Event where
import Control.Monad (msum, void)
import Data.Text
import GHCJS.DOM.Types hiding (Text)
import Language.Javascript.JSaddle hiding (JSM, liftJSM, toJSString)
import Shpadoinkle
import Shpadoinkle.Html.TH
import Shpadoinkle.Keyboard
mkWithFormVal :: (JSVal -> JSM v) -> Text -> JSString -> (v -> Continuation m a) -> (Text, Prop m a)
mkWithFormVal valTo evt from f = listenRaw evt $ \(RawNode n) _ ->
return . f =<< liftJSM (valTo =<< unsafeGetProp from =<< valToObject n)
onInputC :: (Text -> Continuation m a) -> (Text, Prop m a)
onInputC = mkWithFormVal valToText "input" "value"
onInput :: (Text -> a) -> (Text, Prop m a)
onInput f = onInputC (constUpdate . f)
onInputM :: Monad m => (Text -> m (a -> a)) -> (Text, Prop m a)
onInputM f = onInputC (impur . f)
onInputM_ :: Monad m => (Text -> m ()) -> (Text, Prop m a)
onInputM_ f = onInputC (causes . f)
onOptionC :: (Text -> Continuation m a) -> (Text, Prop m a)
onOptionC = mkWithFormVal valToText "change" "value"
onOption :: (Text -> a) -> (Text, Prop m a)
onOption f = onOptionC (constUpdate . f)
onOptionM :: Monad m => (Text -> m (a -> a)) -> (Text, Prop m a)
onOptionM f = onOptionC (impur . f)
onOptionM_ :: Monad m => (Text -> m ()) -> (Text, Prop m a)
onOptionM_ f = onOptionC (causes . f)
mkOnKey :: Text -> (KeyCode -> Continuation m a) -> (Text, Prop m a)
mkOnKey t f = listenRaw t $ \_ (RawEvent e) ->
return . f =<< liftJSM (fmap round $ valToNumber =<< unsafeGetProp "keyCode" =<< valToObject e)
onKeyupC, onKeydownC, onKeypressC :: (KeyCode -> Continuation m a) -> (Text, Prop m a)
onKeyupC = mkOnKey "keyup"
onKeydownC = mkOnKey "keydown"
onKeypressC = mkOnKey "keypress"
onKeyup, onKeydown, onKeypress :: (KeyCode -> a) -> (Text, Prop m a)
onKeyup f = onKeyupC (constUpdate . f)
onKeydown f = onKeydownC (constUpdate . f)
onKeypress f = onKeypressC (constUpdate . f)
onKeyupM, onKeydownM, onKeypressM :: Monad m => (KeyCode -> m (a -> a)) -> (Text, Prop m a)
onKeyupM f = onKeyupC (impur . f)
onKeydownM f = onKeydownC (impur . f)
onKeypressM f = onKeypressC (impur . f)
onKeyupM_, onKeydownM_, onKeypressM_ :: Monad m => (KeyCode -> m ()) -> (Text, Prop m a)
onKeyupM_ f = onKeyupC (causes . f)
onKeydownM_ f = onKeydownC (causes . f)
onKeypressM_ f = onKeypressC (causes . f)
onCheckC :: (Bool -> Continuation m a) -> (Text, Prop m a)
onCheckC = mkWithFormVal valToBool "change" "checked"
onCheck :: (Bool -> a) -> (Text, Prop m a)
onCheck f = onCheckC (constUpdate . f)
onCheckM :: Monad m => (Bool -> m (a -> a)) -> (Text, Prop m a)
onCheckM f = onCheckC (impur . f)
onCheckM_ :: Monad m => (Bool -> m ()) -> (Text, Prop m a)
onCheckM_ f = onCheckC (causes . f)
preventDefault :: RawEvent -> JSM ()
preventDefault e = void $ valToObject e # ("preventDefault" :: String) $ ([] :: [()])
onSubmitC :: Continuation m a -> (Text, Prop m a)
onSubmitC m = listenRaw "submit" $ \_ e -> preventDefault e >> return m
onSubmit :: a -> (Text, Prop m a)
onSubmit = onSubmitC . constUpdate
onSubmitM :: Monad m => m (a -> a) -> (Text, Prop m a)
onSubmitM = onSubmitC . impur
onSubmitM_ :: Monad m => m () -> (Text, Prop m a)
onSubmitM_ = onSubmitC . causes
mkGlobalKey :: Text -> (KeyCode -> JSM ()) -> JSM ()
mkGlobalKey n t = do
d <- makeObject =<< jsg ("window" :: Text)
f <- toJSVal . fun $ \_ _ -> \case
e:_ -> t =<<
fmap round (valToNumber =<< unsafeGetProp "keyCode" =<< valToObject e)
_ -> return ()
unsafeSetProp (toJSString $ "on" <> n) f d
globalKeyDown, globalKeyUp, globalKeyPress :: (KeyCode -> JSM ()) -> JSM ()
globalKeyDown = mkGlobalKey "keydown"
globalKeyUp = mkGlobalKey "keyup"
globalKeyPress = mkGlobalKey "keypress"
$(msum <$> mapM mkEventDSL
[ "click"
, "change"
, "contextmenu"
, "dblclick"
, "mousedown"
, "mouseenter"
, "mouseleave"
, "mousemove"
, "mouseover"
, "mouseout"
, "mouseup"
, "beforeunload"
, "error"
, "hashchange"
, "load"
, "pageshow"
, "pagehide"
, "resize"
, "scroll"
, "unload"
, "blur"
, "focus"
, "focusin"
, "focusout"
, "invalid"
, "reset"
, "search"
, "select"
, "drag"
, "dragend"
, "dragenter"
, "dragleave"
, "dragover"
, "dragstart"
, "drop"
, "copy"
, "cut"
, "paste"
, "afterprint"
, "beforeprint"
, "abort"
, "canplay"
, "canplaythrough"
, "durationchange"
, "emptied"
, "ended"
, "loadeddata"
, "loadedmetadata"
, "loadstart"
, "pause"
, "play"
, "playing"
, "progress"
, "ratechange"
, "seeked"
, "seeking"
, "stalled"
, "suspend"
, "timeupdate"
, "volumechange"
, "waiting"
, "animationend"
, "animationiteration"
, "animationstart"
, "message"
, "open"
, "mousewheel"
, "online"
, "offline"
, "popstate"
, "show"
, "storage"
, "toggle"
, "wheel"
, "touchcancel"
, "touchend"
, "touchmove"
, "touchstart" ])