netwire-input-javascript 0.0.1 → 0.0.2
raw patch · 6 files changed
+431/−377 lines, 6 files
Files
- FRP/Netwire/Input/JavaScript.hs +21/−243
- FRP/Netwire/Input/JavaScript/Key.hs +0/−131
- JavaScript/Input.hs +281/−0
- JavaScript/Input/Key.hs +125/−0
- README.md +0/−0
- netwire-input-javascript.cabal +4/−3
FRP/Netwire/Input/JavaScript.hs view
@@ -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
− FRP/Netwire/Input/JavaScript/Key.hs
@@ -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
+ JavaScript/Input.hs view
@@ -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
+ JavaScript/Input/Key.hs view
@@ -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
− README.md
netwire-input-javascript.cabal view
@@ -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: .