netwire-input-javascript (empty) → 0.0.1
raw patch · 6 files changed
+465/−0 lines, 6 filesdep +basedep +containersdep +ghcjs-basesetup-changed
Dependencies added: base, containers, ghcjs-base, netwire, netwire-input, transformers
Files
- FRP/Netwire/Input/JavaScript.hs +279/−0
- FRP/Netwire/Input/JavaScript/Key.hs +131/−0
- LICENSE +30/−0
- README.md +0/−0
- Setup.hs +2/−0
- netwire-input-javascript.cabal +23/−0
+ FRP/Netwire/Input/JavaScript.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances,+ FlexibleInstances, MultiParamTypeClasses #-}++module FRP.Netwire.Input.JavaScript (+ JSInputState,+ JSInputControl,+ JSInput,+ JSInputT,+ Key(..),+ MouseButton(..),+ mkInputControl,+ initialInputState,+ pollJavaScript,+ cursorLocked,+ lockCursor,+ 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 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+ }++-- | 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 = hiddenCursor is+ locked = lockedCursor is'++ hidden' <- case newCursorMode is of+ Just cm -> changeCursorMode hidden locked cm+ element ptrLockVar+ _ -> return hidden++ return is' { hiddenCursor = hidden', newCursorMode = Nothing }++-- | 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')+-- and 'mouseMickies' will not actually lock the pointer, but will schedule+-- the pointer lock request for the next interaction from the user.+-- In particular, 'mouseMickies' will behave like 'mouseCursor' if the pointer+-- is not locked.+--+-- This wire, which inhibits if the pointer is not locked, is+-- 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+ 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 view
@@ -0,0 +1,131 @@+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
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Luca "ziocroc" Prezzavento++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Luca "ziocroc" Prezzavento nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ netwire-input-javascript.cabal view
@@ -0,0 +1,23 @@+name: netwire-input-javascript+version: 0.0.1+synopsis: JavaScript instance of netwire-input+description: GHCJS implementation of netwire-input.+homepage: https://github.com/ziocroc/netwire-input-javascript+license: BSD3+license-file: LICENSE+author: Luca "ziocroc" Prezzavento+maintainer: ziocroc@gmail.com+category: Game+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/ziocroc/netwire-input-javascript++library+ exposed-modules: FRP.Netwire.Input.JavaScript, FRP.Netwire.Input.JavaScript.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