diff --git a/FRP/Netwire/Input/JavaScript.hs b/FRP/Netwire/Input/JavaScript.hs --- a/FRP/Netwire/Input/JavaScript.hs +++ b/FRP/Netwire/Input/JavaScript.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, - FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} module FRP.Netwire.Input.JavaScript ( JSInputState, @@ -16,113 +15,31 @@ unlockCursor ) where -import qualified Data.IntSet as S import Control.Applicative -import Control.Monad (when) -import Control.Monad.Trans.State -import Control.Wire.Core -import Data.IORef +import Control.Wire import FRP.Netwire.Input hiding (Key, MouseButton) -import FRP.Netwire.Input.JavaScript.Key - -import GHCJS.Foreign hiding (Object) -import GHCJS.Foreign.Callback -import GHCJS.Marshal -import GHCJS.Types -import JavaScript.Object.Internal - -data JSInputState = JSInputState { - keyPressedSet :: S.IntSet, - keyReleasedSet :: S.IntSet, - mbPressedSet :: S.IntSet, - mbReleasedSet :: S.IntSet, - cursorPos :: (Float, Float), - cursorMovement :: (Float, Float), - scrollAmount :: (Double, Double), - hiddenCursor :: Bool, - lockedCursor :: Bool, - newCursorMode :: Maybe CursorMode -} - -data Event = KeyDown Int | KeyUp Int | MouseDown Int | MouseUp Int - | MouseMove (Float, Float) (Float, Float) | Wheel (Int, Int) - | PointerLockChange Bool - -data JSInputControl = JSInputControl (IORef [Event]) (IORef Bool) JSVal - -type JSInput = State JSInputState -type JSInputT m = StateT JSInputState m - --- | Create a 'JSInputControl' from a DOM element. -mkInputControl :: JSVal -> IO (Maybe JSInputControl) -mkInputControl element | isNull element = return Nothing -mkInputControl element = do eventsVar <- newIORef [] - ptrLockVar <- newIORef False - doc <- document - event element eventsVar "keydown" eventKeyDown - event element eventsVar "keyup" eventKeyUp - event element eventsVar "mousedown" eventMouseDown - event element eventsVar "mouseup" eventMouseUp - event element eventsVar "mousemove" $ - eventMouseMove element - event element eventsVar "wheel" eventWheel - event doc eventsVar "pointerlockchange" $ - const (eventPointerLockChange element) - event doc eventsVar "mozpointerlockchange" $ - const (eventPointerLockChange element) - ptrLockPerformer element ptrLockVar "mouseup" - ptrLockPerformer element ptrLockVar "keyup" - return . Just $ - JSInputControl eventsVar ptrLockVar element - - where event element eventsVar name getEvent = - do callback <- asyncCallback1 $ \rawEvent -> - do event <- getEvent $ Object rawEvent - modifyIORef' eventsVar (event :) - addEventListener element name callback - - ptrLockPerformer element ptrLockVar name = - do callback <- asyncCallback1 $ \_ -> do - lock <- atomicModifyIORef' ptrLockVar - (\x -> (False, x)) - when lock $ lockCursorRaw element - addEventListener element name callback - --- | Use this with 'pollJavaScript' the first time. -initialInputState :: JSInputState -initialInputState = JSInputState { - keyPressedSet = S.empty, - keyReleasedSet = S.empty, - mbPressedSet = S.empty, - mbReleasedSet = S.empty, - cursorPos = (0, 0), - cursorMovement = (0, 0), - scrollAmount = (0, 0), - hiddenCursor = False, - lockedCursor = False, - newCursorMode = Nothing - } +import qualified FRP.Netwire.Input --- | Update the 'JSInputState' with the new events. -pollJavaScript :: JSInputState - -> JSInputControl - -> IO JSInputState -pollJavaScript is (JSInputControl eventsVar ptrLockVar element) = - do events <- atomicModifyIORef eventsVar $ \e -> ([], e) +import Control.Monad.Trans.State +import JavaScript.Input - let is' = foldr compEvent - is { scrollAmount = (0, 0) - , cursorMovement = (0, 0) } - events - hidden = hiddenCursor is - locked = lockedCursor is' +instance FRP.Netwire.Input.Key Key +instance FRP.Netwire.Input.MouseButton MouseButton - hidden' <- case newCursorMode is of - Just cm -> changeCursorMode hidden locked cm - element ptrLockVar - _ -> return hidden +instance Monad m => MonadMouse MouseButton (JSInputT m) where + setCursorMode cm = setCursorModeM $ + case cm of + CursorMode'Enabled -> (Just False, Just False) + CursorMode'Hidden -> (Just False, Just True) + _ -> (Just True, Nothing) + mbIsPressed = mbIsPressedM + releaseButton = releaseButtonM + cursor = cursorM + scroll = scrollM - return is' { hiddenCursor = hidden', newCursorMode = Nothing } +instance Monad m => MonadKeyboard Key (JSInputT m) where + keyIsPressed = keyIsPressedM + releaseKey = releaseKeyM -- | In JavaScript, you can lock the pointer only after the user releases a -- mouse button or a key. This means that 'cursorMode' (with 'CursorMode'Reset') @@ -135,145 +52,6 @@ -- useful if you want to know if you're still waiting for the user to lock the -- pointer, and if the user manually unlocked it. cursorLocked :: (Monoid e, Monad m) => Wire s e (JSInputT m) a a -cursorLocked = mkGen_ $ \x -> boolToEither x . lockedCursor <$> get +cursorLocked = mkGen_ $ \x -> boolToEither x <$> lockedCursorM where boolToEither _ False = Left mempty boolToEither x True = Right x - --- | Manually schedule cursor lock. -lockCursor :: JSInputControl -> IO () -lockCursor (JSInputControl _ ptrLockVar _) = writeIORef ptrLockVar True - --- | Manually unlock the cursor. -unlockCursor :: JSInputControl -> IO () -unlockCursor (JSInputControl _ ptrLockVar _) = writeIORef ptrLockVar False - >> unlockCursorRaw - -changeCursorMode :: Bool -> Bool -> CursorMode - -> JSVal -> IORef Bool -> IO Bool -changeCursorMode hidden locked cm element ptrLockVar = - do case (locked, cm == CursorMode'Reset || cm == CursorMode'Disabled) of - (True, False) -> writeIORef ptrLockVar False >> unlockCursorRaw - (False, True) -> writeIORef ptrLockVar True - _ -> return () - - case (hidden, cm == CursorMode'Hidden) of - (True, False) -> showCursor element >> return False - (False, True) -> hideCursor element >> return True - _ -> return hidden - -compEvent :: Event -> JSInputState -> JSInputState -compEvent (KeyDown k) is | S.member k $ keyReleasedSet is = is - | otherwise = is { keyPressedSet = - S.insert k $ keyPressedSet is } -compEvent (KeyUp k) is = - is { keyPressedSet = S.delete k $ keyPressedSet is - , keyReleasedSet = S.delete k $ keyReleasedSet is } -compEvent (MouseDown k) is | S.member k $ mbReleasedSet is = is - | otherwise = is { mbPressedSet = - S.insert k $ mbPressedSet is } -compEvent (MouseUp k) is = - is { mbPressedSet = S.delete k $ mbPressedSet is - , mbReleasedSet = S.delete k $ mbReleasedSet is } -compEvent (MouseMove (cx, cy) (dmx, dmy)) is = - let (mx0, my0) = cursorMovement is - in is { cursorPos = (cx, cy) - , cursorMovement = (mx0 + dmx, my0 + dmy) } -compEvent (Wheel (x, y)) is = - let (dx, dy) = (fromIntegral x, fromIntegral y) - (x0, y0) = scrollAmount is - in is { scrollAmount = (x0 + dx, y0 + dy) } -compEvent (PointerLockChange locked) is = is { lockedCursor = locked } - -instance Monad m => MonadMouse MouseButton (JSInputT m) where - setCursorMode cm = modify $ \is -> is { newCursorMode = Just cm } - mbIsPressed mb = S.member (fromMouseButton mb) . mbPressedSet <$> get - releaseButton mb = modify $ - \is -> is { mbReleasedSet = S.insert (fromMouseButton mb) $ - mbReleasedSet is - , mbPressedSet = S.delete (fromMouseButton mb) $ - mbPressedSet is } - cursor = (<$> get) $ \is -> if lockedCursor is - then cursorMovement is - else cursorPos is - scroll = scrollAmount <$> get - -instance Monad m => MonadKeyboard Key (JSInputT m) where - keyIsPressed k = do kp <- keyPressedSet <$> get - return $ any (flip S.member kp) (fromKey k) - releaseKey k = modify $ - \is -> is { keyReleasedSet = foldr S.insert - (keyReleasedSet is) - (fromKey k) - , keyPressedSet = foldr S.delete - (keyPressedSet is) - (fromKey k) - } - -eventKeyDown :: Object -> IO Event -eventKeyDown ev = KeyDown <$> prop "keyCode" ev - -eventKeyUp :: Object -> IO Event -eventKeyUp ev = KeyUp <$> prop "keyCode" ev - -eventMouseDown :: Object -> IO Event -eventMouseDown ev = MouseDown <$> prop "button" ev - -eventMouseUp :: Object -> IO Event -eventMouseUp ev = MouseUp <$> prop "button" ev - -eventMouseMove :: JSVal -> Object -> IO Event -eventMouseMove elem ev@(Object evVal) = - do width <- fi <$> prop "clientWidth" (Object elem) - height <- fi <$> prop "clientHeight" (Object elem) - clientX <- fi <$> prop "clientX" ev - clientY <- fi <$> prop "clientY" ev - movementX <- fi <$> movementX evVal - movementY <- fi <$> movementY evVal - return $ MouseMove ( clientX * 2 / width - 1 - , clientY * 2 / height - 1) - ( movementX * 2 / width - , movementY * 2 / height ) - where fi = fromIntegral :: Int -> Float - -eventWheel :: Object -> IO Event -eventWheel ev = Wheel <$> ((,) <$> prop "deltaX" ev - <*> prop "deltaY" ev) - -eventPointerLockChange :: JSVal -> IO Event -eventPointerLockChange elem = PointerLockChange <$> isPointerLockElement elem - -prop :: FromJSVal a => JSString -> Object -> IO a -prop s o = unsafeGetProp s o >>= fromJSValUnchecked - -foreign import javascript unsafe "$1.addEventListener($2, $3)" - addEventListener :: JSVal -> JSString -> Callback (JSVal -> IO ()) -> IO () - -foreign import javascript unsafe " if ($1.requestPointerLock)\ - \ $1.requestPointerLock()\ - \ else\ - \ $1.mozRequestPointerLock()" - lockCursorRaw :: JSVal -> IO () - -foreign import javascript unsafe " if (document.exitPointerLock)\ - \ document.exitPointerLock()\ - \ else\ - \ document.mozExitPointerLock()" - unlockCursorRaw :: IO () - -foreign import javascript unsafe "$1.style.cursor = 'none'" - hideCursor :: JSVal -> IO () - -foreign import javascript unsafe "$1.style.cursor = 'auto'" - showCursor :: JSVal -> IO () - -foreign import javascript unsafe " document.pointerLockElement === $1 ||\ - \ document.mozPointerLockElement === $1" - isPointerLockElement :: JSVal -> IO Bool - -foreign import javascript unsafe "$r = document" document :: IO JSVal - -foreign import javascript unsafe "$1.movementX || $1.mozMovementX || 0" - movementX :: JSVal -> IO Int - -foreign import javascript unsafe "$1.movementY || $1.mozMovementY || 0" - movementY :: JSVal -> IO Int diff --git a/FRP/Netwire/Input/JavaScript/Key.hs b/FRP/Netwire/Input/JavaScript/Key.hs deleted file mode 100644 --- a/FRP/Netwire/Input/JavaScript/Key.hs +++ /dev/null @@ -1,131 +0,0 @@ -module FRP.Netwire.Input.JavaScript.Key ( - Key(..), - MouseButton(..), - fromKey, - fromMouseButton -) where - -import qualified FRP.Netwire.Input - - -data Key = KeyA | KeyB | KeyC | KeyD | KeyE | KeyF | KeyG | KeyH | KeyI | KeyJ - | KeyK | KeyL | KeyM | KeyN | KeyO | KeyP | KeyQ | KeyR | KeyS | KeyT - | KeyU | KeyV | KeyW | KeyX | KeyY | KeyZ | Key0 | Key1 | Key2 | Key3 - | Key4 | Key5 | Key6 | Key7 | Key8 | Key9 | KeySpace | KeyEnter - | KeyTab | KeyEsc | KeyBackspace | KeyShift | KeyControl | KeyAlt - | KeyCapsLock | KeyNumLock | KeyArrowLeft | KeyArrowUp | KeyArrowRight - | KeyArrowDown | KeyIns | KeyDel | KeyHome | KeyEnd | KeyPgUp - | KeyPgDown | KeyF1 | KeyF2 | KeyF3 | KeyF4 | KeyF5 | KeyF6 | KeyF7 - | KeyF8 | KeyF9 | KeyF10 | KeyF11 | KeyF12 | KeyPadDel | KeyPadIns - | KeyPadEnd | KeyPadDown | KeyPadPgDown | KeyPadLeft | KeyPadRight - | KeyPadHome | KeyPadUp | KeyPadPgUp | KeyPadAdd | KeyPadSub - | KeyPadMul | KeyPadDiv | KeyPadEnter | KeyPadDot | KeyPad0 | KeyPad1 - | KeyPad2 | KeyPad3 | KeyPad4 | KeyPad5 | KeyPad6 | KeyPad7 | KeyPad8 - | KeyPad9 - deriving (Eq, Show) - -data MouseButton = MouseLeft | MouseMiddle | MouseRight deriving (Eq, Show) - -instance FRP.Netwire.Input.Key Key -instance FRP.Netwire.Input.MouseButton MouseButton - -fromKey :: Key -> [Int] -fromKey KeyA = [65, 97] -fromKey KeyB = [66, 98] -fromKey KeyC = [67, 99] -fromKey KeyD = [100, 68] -fromKey KeyE = [101, 69] -fromKey KeyF = [102, 70] -fromKey KeyG = [103, 71] -fromKey KeyH = [104, 72] -fromKey KeyI = [105, 73] -fromKey KeyJ = [106, 74] -fromKey KeyK = [107, 75] -fromKey KeyL = [108, 76] -fromKey KeyM = [109, 77] -fromKey KeyN = [110, 78] -fromKey KeyO = [111, 79] -fromKey KeyP = [112, 80] -fromKey KeyQ = [113, 81] -fromKey KeyR = [114, 82] -fromKey KeyS = [115, 83] -fromKey KeyT = [116, 84] -fromKey KeyU = [117, 85] -fromKey KeyV = [118, 86] -fromKey KeyW = [119, 87] -fromKey KeyX = [120, 88] -fromKey KeyY = [121, 89] -fromKey KeyZ = [122, 90] -fromKey Key0 = [48] -fromKey Key1 = [49] -fromKey Key2 = [50] -fromKey Key3 = [51] -fromKey Key4 = [52] -fromKey Key5 = [53] -fromKey Key6 = [54] -fromKey Key7 = [55] -fromKey Key8 = [56] -fromKey Key9 = [57] -fromKey KeySpace = [32] -fromKey KeyEnter = [13] -fromKey KeyTab = [9] -fromKey KeyEsc = [27] -fromKey KeyBackspace = [8] -fromKey KeyShift = [16] -fromKey KeyControl = [17] -fromKey KeyAlt = [18] -fromKey KeyCapsLock = [20] -fromKey KeyNumLock = [144] -fromKey KeyArrowLeft = [37] -fromKey KeyArrowUp = [38] -fromKey KeyArrowRight = [39] -fromKey KeyArrowDown = [40] -fromKey KeyIns = [45] -fromKey KeyDel = [46] -fromKey KeyHome = [36] -fromKey KeyEnd = [35] -fromKey KeyPgUp = [33] -fromKey KeyPgDown = [34] -fromKey KeyF1 = [112] -fromKey KeyF2 = [113] -fromKey KeyF3 = [114] -fromKey KeyF4 = [115] -fromKey KeyF5 = [116] -fromKey KeyF6 = [117] -fromKey KeyF7 = [118] -fromKey KeyF8 = [119] -fromKey KeyF9 = [120] -fromKey KeyF10 = [121] -fromKey KeyF11 = [122] -fromKey KeyF12 = [123] -fromKey KeyPadDel = [46] -fromKey KeyPadIns = [45] -fromKey KeyPadEnd = [35] -fromKey KeyPadDown = [40] -fromKey KeyPadPgDown = [34] -fromKey KeyPadLeft = [37] -fromKey KeyPadRight = [39] -fromKey KeyPadHome = [36] -fromKey KeyPadUp = [38] -fromKey KeyPadPgUp = [33] -fromKey KeyPadAdd = [107] -fromKey KeyPadSub = [109] -fromKey KeyPadMul = [106] -fromKey KeyPadDiv = [111] -fromKey KeyPadEnter = [13] -fromKey KeyPadDot = [46] -fromKey KeyPad0 = [48] -fromKey KeyPad1 = [49] -fromKey KeyPad2 = [50] -fromKey KeyPad3 = [51] -fromKey KeyPad4 = [52] -fromKey KeyPad5 = [53] -fromKey KeyPad6 = [54] -fromKey KeyPad7 = [55] -fromKey KeyPad8 = [56] -fromKey KeyPad9 = [57] - -fromMouseButton :: MouseButton -> Int -fromMouseButton MouseLeft = 0 -fromMouseButton MouseMiddle = 1 -fromMouseButton MouseRight = 2 diff --git a/JavaScript/Input.hs b/JavaScript/Input.hs new file mode 100644 --- /dev/null +++ b/JavaScript/Input.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE OverloadedStrings #-} + +module JavaScript.Input ( + JSInputState, + JSInputControl, + JSInput, + JSInputT, + Key(..), + MouseButton(..), + mkInputControl, + initialInputState, + pollJavaScript, + lockCursor, + unlockCursor, + setCursorModeM, + mbIsPressedM, + releaseButtonM, + cursorM, + lockedCursorM, + scrollM, + keyIsPressedM, + releaseKeyM +) where + +import qualified Data.IntSet as S +import Control.Applicative +import Control.Monad (when) +import Control.Monad.Trans.State +import Data.IORef + +import GHCJS.Foreign hiding (Object) +import GHCJS.Foreign.Callback +import GHCJS.Marshal +import GHCJS.Types +import JavaScript.Object.Internal + +import JavaScript.Input.Key + +data JSInputState = JSInputState { + keyPressedSet :: S.IntSet, + keyReleasedSet :: S.IntSet, + mbPressedSet :: S.IntSet, + mbReleasedSet :: S.IntSet, + cursorPos :: (Float, Float), + cursorMovement :: (Float, Float), + scrollAmount :: (Double, Double), + hiddenCursor :: Bool, + lockedCursor :: Bool, + reqHiddenCursor :: Maybe Bool, + reqLockedCursor :: Maybe Bool +} + +data Event = KeyDown Int | KeyUp Int | MouseDown Int | MouseUp Int + | MouseMove (Float, Float) (Float, Float) | Wheel (Int, Int) + | PointerLockChange Bool + +data JSInputControl = JSInputControl (IORef [Event]) (IORef Bool) JSVal + +type JSInput = State JSInputState +type JSInputT m = StateT JSInputState m + +-- | Create a 'JSInputControl' from a DOM element. +mkInputControl :: JSVal -> IO (Maybe JSInputControl) +mkInputControl element | isNull element = return Nothing +mkInputControl element = do eventsVar <- newIORef [] + ptrLockVar <- newIORef False + doc <- document + event element eventsVar "keydown" eventKeyDown + event element eventsVar "keyup" eventKeyUp + event element eventsVar "mousedown" eventMouseDown + event element eventsVar "mouseup" eventMouseUp + event element eventsVar "mousemove" $ + eventMouseMove element + event element eventsVar "wheel" eventWheel + event doc eventsVar "pointerlockchange" $ + const (eventPointerLockChange element) + event doc eventsVar "mozpointerlockchange" $ + const (eventPointerLockChange element) + ptrLockPerformer element ptrLockVar "mouseup" + ptrLockPerformer element ptrLockVar "keyup" + return . Just $ + JSInputControl eventsVar ptrLockVar element + + where event element eventsVar name getEvent = + do callback <- asyncCallback1 $ \rawEvent -> + do event <- getEvent $ Object rawEvent + modifyIORef' eventsVar (event :) + addEventListener element name callback + + ptrLockPerformer element ptrLockVar name = + do callback <- syncCallback1 ContinueAsync $ \_ -> do + lock <- atomicModifyIORef' ptrLockVar + (\x -> (False, x)) + when lock $ lockCursorRaw element + addEventListener element name callback + +-- | Use this with 'pollJavaScript' the first time. +initialInputState :: JSInputState +initialInputState = JSInputState { + keyPressedSet = S.empty, + keyReleasedSet = S.empty, + mbPressedSet = S.empty, + mbReleasedSet = S.empty, + cursorPos = (0, 0), + cursorMovement = (0, 0), + scrollAmount = (0, 0), + hiddenCursor = False, + lockedCursor = False, + reqHiddenCursor = Nothing, + reqLockedCursor = Nothing + } + +-- | Update the 'JSInputState' with the new events. +pollJavaScript :: JSInputState + -> JSInputControl + -> IO JSInputState +pollJavaScript is (JSInputControl eventsVar ptrLockVar element) = + do events <- atomicModifyIORef eventsVar $ \e -> ([], e) + + let is' = foldr compEvent + is { scrollAmount = (0, 0) + , cursorMovement = (0, 0) } + events + + hidden <- case (hiddenCursor is, reqHiddenCursor is') of + (True, Just False) -> showCursor element >> + return False + (False, Just True) -> hideCursor element >> + return False + _ -> return $ hiddenCursor is + + + case (lockedCursor is', reqLockedCursor is') of + (True, Just False) -> writeIORef ptrLockVar False >> + unlockCursorRaw + (False, Just True) -> writeIORef ptrLockVar True + _ -> return () + + return is' { hiddenCursor = hidden + , reqHiddenCursor = Nothing + , reqLockedCursor = Nothing } + +-- | Manually schedule cursor lock. +lockCursor :: JSInputControl -> IO () +lockCursor (JSInputControl _ ptrLockVar _) = writeIORef ptrLockVar True + +-- | Manually unlock the cursor. +unlockCursor :: JSInputControl -> IO () +unlockCursor (JSInputControl _ ptrLockVar _) = writeIORef ptrLockVar False + >> unlockCursorRaw + +setCursorModeM :: Monad m => (Maybe Bool, Maybe Bool) -> JSInputT m () +setCursorModeM (lock, hide) = modify $ \is -> is { reqLockedCursor = lock + , reqHiddenCursor = hide } + +mbIsPressedM :: Monad m => MouseButton -> JSInputT m Bool +mbIsPressedM mb = S.member (fromMouseButton mb) . mbPressedSet <$> get + +releaseButtonM :: Monad m => MouseButton -> JSInputT m () +releaseButtonM mb = modify $ + \is -> is { mbReleasedSet = S.insert (fromMouseButton mb) $ + mbReleasedSet is + , mbPressedSet = S.delete (fromMouseButton mb) $ + mbPressedSet is } + +cursorM :: Monad m => JSInputT m (Float, Float) +cursorM = (<$> get) $ \is -> if lockedCursor is + then cursorMovement is + else cursorPos is + +lockedCursorM :: Monad m => JSInputT m Bool +lockedCursorM = lockedCursor <$> get + +scrollM :: Monad m => JSInputT m (Double, Double) +scrollM = scrollAmount <$> get + +keyIsPressedM :: Monad m => Key -> JSInputT m Bool +keyIsPressedM k = do kp <- keyPressedSet <$> get + return $ any (flip S.member kp) (fromKey k) + +releaseKeyM :: Monad m => Key -> JSInputT m () +releaseKeyM k = modify $ + \is -> is { keyReleasedSet = foldr S.insert + (keyReleasedSet is) + (fromKey k) + , keyPressedSet = foldr S.delete + (keyPressedSet is) + (fromKey k) + } + +compEvent :: Event -> JSInputState -> JSInputState +compEvent (KeyDown k) is | S.member k $ keyReleasedSet is = is + | otherwise = is { keyPressedSet = + S.insert k $ keyPressedSet is } +compEvent (KeyUp k) is = + is { keyPressedSet = S.delete k $ keyPressedSet is + , keyReleasedSet = S.delete k $ keyReleasedSet is } +compEvent (MouseDown k) is | S.member k $ mbReleasedSet is = is + | otherwise = is { mbPressedSet = + S.insert k $ mbPressedSet is } +compEvent (MouseUp k) is = + is { mbPressedSet = S.delete k $ mbPressedSet is + , mbReleasedSet = S.delete k $ mbReleasedSet is } +compEvent (MouseMove (cx, cy) (dmx, dmy)) is = + let (mx0, my0) = cursorMovement is + in is { cursorPos = (cx, cy) + , cursorMovement = (mx0 + dmx, my0 + dmy) } +compEvent (Wheel (x, y)) is = + let (dx, dy) = (fromIntegral x, fromIntegral y) + (x0, y0) = scrollAmount is + in is { scrollAmount = (x0 + dx, y0 + dy) } +compEvent (PointerLockChange locked) is = is { lockedCursor = locked } + +eventKeyDown :: Object -> IO Event +eventKeyDown ev = KeyDown <$> prop "keyCode" ev + +eventKeyUp :: Object -> IO Event +eventKeyUp ev = KeyUp <$> prop "keyCode" ev + +eventMouseDown :: Object -> IO Event +eventMouseDown ev = MouseDown <$> prop "button" ev + +eventMouseUp :: Object -> IO Event +eventMouseUp ev = MouseUp <$> prop "button" ev + +eventMouseMove :: JSVal -> Object -> IO Event +eventMouseMove elem ev@(Object evVal) = + do width <- fi <$> prop "clientWidth" (Object elem) + height <- fi <$> prop "clientHeight" (Object elem) + clientX <- fi <$> prop "clientX" ev + clientY <- fi <$> prop "clientY" ev + movementX <- fi <$> movementX evVal + movementY <- fi <$> movementY evVal + return $ MouseMove ( clientX * 2 / width - 1 + , clientY * 2 / height - 1) + ( movementX * 2 / width + , movementY * 2 / height ) + where fi = fromIntegral :: Int -> Float + +eventWheel :: Object -> IO Event +eventWheel ev = Wheel <$> ((,) <$> prop "deltaX" ev + <*> prop "deltaY" ev) + +eventPointerLockChange :: JSVal -> IO Event +eventPointerLockChange elem = PointerLockChange <$> isPointerLockElement elem + +prop :: FromJSVal a => JSString -> Object -> IO a +prop s o = unsafeGetProp s o >>= fromJSValUnchecked + +foreign import javascript unsafe "$1.addEventListener($2, $3)" + addEventListener :: JSVal -> JSString -> Callback (JSVal -> IO ()) -> IO () + +foreign import javascript unsafe " if ($1.requestPointerLock)\ + \ $1.requestPointerLock()\ + \ else\ + \ $1.mozRequestPointerLock()" + lockCursorRaw :: JSVal -> IO () + +foreign import javascript unsafe " if (document.exitPointerLock)\ + \ document.exitPointerLock()\ + \ else\ + \ document.mozExitPointerLock()" + unlockCursorRaw :: IO () + +foreign import javascript unsafe "$1.style.cursor = 'none'" + hideCursor :: JSVal -> IO () + +foreign import javascript unsafe "$1.style.cursor = 'auto'" + showCursor :: JSVal -> IO () + +foreign import javascript unsafe " document.pointerLockElement === $1 ||\ + \ document.mozPointerLockElement === $1" + isPointerLockElement :: JSVal -> IO Bool + +foreign import javascript unsafe "$r = document" document :: IO JSVal + +foreign import javascript unsafe "$1.movementX || $1.mozMovementX || 0" + movementX :: JSVal -> IO Int + +foreign import javascript unsafe "$1.movementY || $1.mozMovementY || 0" + movementY :: JSVal -> IO Int diff --git a/JavaScript/Input/Key.hs b/JavaScript/Input/Key.hs new file mode 100644 --- /dev/null +++ b/JavaScript/Input/Key.hs @@ -0,0 +1,125 @@ +module JavaScript.Input.Key ( + Key(..), + MouseButton(..), + fromKey, + fromMouseButton +) where + +data Key = KeyA | KeyB | KeyC | KeyD | KeyE | KeyF | KeyG | KeyH | KeyI | KeyJ + | KeyK | KeyL | KeyM | KeyN | KeyO | KeyP | KeyQ | KeyR | KeyS | KeyT + | KeyU | KeyV | KeyW | KeyX | KeyY | KeyZ | Key0 | Key1 | Key2 | Key3 + | Key4 | Key5 | Key6 | Key7 | Key8 | Key9 | KeySpace | KeyEnter + | KeyTab | KeyEsc | KeyBackspace | KeyShift | KeyControl | KeyAlt + | KeyCapsLock | KeyNumLock | KeyArrowLeft | KeyArrowUp | KeyArrowRight + | KeyArrowDown | KeyIns | KeyDel | KeyHome | KeyEnd | KeyPgUp + | KeyPgDown | KeyF1 | KeyF2 | KeyF3 | KeyF4 | KeyF5 | KeyF6 | KeyF7 + | KeyF8 | KeyF9 | KeyF10 | KeyF11 | KeyF12 | KeyPadDel | KeyPadIns + | KeyPadEnd | KeyPadDown | KeyPadPgDown | KeyPadLeft | KeyPadRight + | KeyPadHome | KeyPadUp | KeyPadPgUp | KeyPadAdd | KeyPadSub + | KeyPadMul | KeyPadDiv | KeyPadEnter | KeyPadDot | KeyPad0 | KeyPad1 + | KeyPad2 | KeyPad3 | KeyPad4 | KeyPad5 | KeyPad6 | KeyPad7 | KeyPad8 + | KeyPad9 + deriving (Eq, Show) + +data MouseButton = MouseLeft | MouseMiddle | MouseRight deriving (Eq, Show) + +fromKey :: Key -> [Int] +fromKey KeyA = [65, 97] +fromKey KeyB = [66, 98] +fromKey KeyC = [67, 99] +fromKey KeyD = [100, 68] +fromKey KeyE = [101, 69] +fromKey KeyF = [102, 70] +fromKey KeyG = [103, 71] +fromKey KeyH = [104, 72] +fromKey KeyI = [105, 73] +fromKey KeyJ = [106, 74] +fromKey KeyK = [107, 75] +fromKey KeyL = [108, 76] +fromKey KeyM = [109, 77] +fromKey KeyN = [110, 78] +fromKey KeyO = [111, 79] +fromKey KeyP = [112, 80] +fromKey KeyQ = [113, 81] +fromKey KeyR = [114, 82] +fromKey KeyS = [115, 83] +fromKey KeyT = [116, 84] +fromKey KeyU = [117, 85] +fromKey KeyV = [118, 86] +fromKey KeyW = [119, 87] +fromKey KeyX = [120, 88] +fromKey KeyY = [121, 89] +fromKey KeyZ = [122, 90] +fromKey Key0 = [48] +fromKey Key1 = [49] +fromKey Key2 = [50] +fromKey Key3 = [51] +fromKey Key4 = [52] +fromKey Key5 = [53] +fromKey Key6 = [54] +fromKey Key7 = [55] +fromKey Key8 = [56] +fromKey Key9 = [57] +fromKey KeySpace = [32] +fromKey KeyEnter = [13] +fromKey KeyTab = [9] +fromKey KeyEsc = [27] +fromKey KeyBackspace = [8] +fromKey KeyShift = [16] +fromKey KeyControl = [17] +fromKey KeyAlt = [18] +fromKey KeyCapsLock = [20] +fromKey KeyNumLock = [144] +fromKey KeyArrowLeft = [37] +fromKey KeyArrowUp = [38] +fromKey KeyArrowRight = [39] +fromKey KeyArrowDown = [40] +fromKey KeyIns = [45] +fromKey KeyDel = [46] +fromKey KeyHome = [36] +fromKey KeyEnd = [35] +fromKey KeyPgUp = [33] +fromKey KeyPgDown = [34] +fromKey KeyF1 = [112] +fromKey KeyF2 = [113] +fromKey KeyF3 = [114] +fromKey KeyF4 = [115] +fromKey KeyF5 = [116] +fromKey KeyF6 = [117] +fromKey KeyF7 = [118] +fromKey KeyF8 = [119] +fromKey KeyF9 = [120] +fromKey KeyF10 = [121] +fromKey KeyF11 = [122] +fromKey KeyF12 = [123] +fromKey KeyPadDel = [46] +fromKey KeyPadIns = [45] +fromKey KeyPadEnd = [35] +fromKey KeyPadDown = [40] +fromKey KeyPadPgDown = [34] +fromKey KeyPadLeft = [37] +fromKey KeyPadRight = [39] +fromKey KeyPadHome = [36] +fromKey KeyPadUp = [38] +fromKey KeyPadPgUp = [33] +fromKey KeyPadAdd = [107] +fromKey KeyPadSub = [109] +fromKey KeyPadMul = [106] +fromKey KeyPadDiv = [111] +fromKey KeyPadEnter = [13] +fromKey KeyPadDot = [46] +fromKey KeyPad0 = [48] +fromKey KeyPad1 = [49] +fromKey KeyPad2 = [50] +fromKey KeyPad3 = [51] +fromKey KeyPad4 = [52] +fromKey KeyPad5 = [53] +fromKey KeyPad6 = [54] +fromKey KeyPad7 = [55] +fromKey KeyPad8 = [56] +fromKey KeyPad9 = [57] + +fromMouseButton :: MouseButton -> Int +fromMouseButton MouseLeft = 0 +fromMouseButton MouseMiddle = 1 +fromMouseButton MouseRight = 2 diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null diff --git a/netwire-input-javascript.cabal b/netwire-input-javascript.cabal --- a/netwire-input-javascript.cabal +++ b/netwire-input-javascript.cabal @@ -1,5 +1,5 @@ name: netwire-input-javascript -version: 0.0.1 +version: 0.0.2 synopsis: JavaScript instance of netwire-input description: GHCJS implementation of netwire-input. homepage: https://github.com/ziocroc/netwire-input-javascript @@ -9,7 +9,6 @@ maintainer: ziocroc@gmail.com category: Game build-type: Simple -extra-source-files: README.md cabal-version: >=1.10 source-repository head @@ -17,7 +16,9 @@ location: https://github.com/ziocroc/netwire-input-javascript library - exposed-modules: FRP.Netwire.Input.JavaScript, FRP.Netwire.Input.JavaScript.Key + exposed-modules: FRP.Netwire.Input.JavaScript + other-modules: JavaScript.Input, JavaScript.Input.Key other-extensions: OverloadedStrings, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses build-depends: base >=4.9 && <4.10, ghcjs-base, transformers, netwire >=5.0 && <5.2, netwire-input >=0.0 && <0.1, containers default-language: Haskell2010 + hs-source-dirs: .