diff --git a/examples/Cursor.hs b/examples/Cursor.hs --- a/examples/Cursor.hs +++ b/examples/Cursor.hs @@ -143,15 +143,16 @@ -- Otherwise, pulsate based on the amount of time passed (timeF >>> (arr (cos &&& sin)) >>> (arr $ \(x, y) -> GL.Color3 x y 1)) --- This wire simply takes a vertex position and color and renders according to the --- passed in renderFn. In reality, this wire doesn't need to be a wire, and could just --- be a monad to render, but this way we can render what we need without having to --- go through the plumbing of our main game loop +-- This wire takes a vertex position and color and renders according to the +-- passed in renderFn. In reality, this wire doesn't need to be a wire, and +-- could be a monad to render, but this way we can render what we need without +-- having to go through the plumbing of our main game loop renderWire :: RenderFn -> Wire s e GameMonad (GL.Vertex2 Float, GL.Color3 Float) () renderWire rfn = mkGen_ $ \(pos, color) -> lift $ rfn pos color >> (return $ Right ()) --- Wire that behaves like the identity wire until Q is pressed, then inhibits forever. --- We can compose our main gameWire with this wire to simply quit the program when q is pressed +-- Wire that behaves like the identity wire until Q is pressed, then inhibits +-- forever. We can compose our main gameWire with this wire to quit the program +-- when q is pressed quitWire :: Monoid e => Wire s e GameMonad a a quitWire = (mkId &&& eventWire) >>> (rSwitch mkId) where diff --git a/lib/FRP/Netwire/Input/GLFW.hs b/lib/FRP/Netwire/Input/GLFW.hs --- a/lib/FRP/Netwire/Input/GLFW.hs +++ b/lib/FRP/Netwire/Input/GLFW.hs @@ -22,9 +22,13 @@ -- ** Basic Input Monad GLFWInput, runGLFWInput, + -- ** Monad Transformer GLFWInputT, runGLFWInputT, + -- * Typeclass + MonadGLFWInput(..), + -- * State Types GLFWInputControl, GLFWInputState, getInput, mkInputControl, pollGLFW @@ -106,45 +110,64 @@ put = lift . put state = lift . state +-- | Describes a monad that provides stateful access to a 'GLFWInputState'. By +-- being able to modify the state, the context that satisfies this typeclass +-- can decide to debounce or "take ownership" of the button presses at a +-- specific point of the computation. This should be done via the 'MonadKey' and +-- 'MonadMouse' instances. +class Monad m => MonadGLFWInput m where + -- | Retrieves the current input state + getGLFWInput :: m GLFWInputState + -- | Places a modified input state back into the context. This should probably + -- not be called directly. + putGLFWInput :: GLFWInputState -> m () + +instance Monad m => MonadGLFWInput (GLFWInputT m) where + getGLFWInput :: GLFWInputT m GLFWInputState + getGLFWInput = GLFWInputT get + + putGLFWInput :: GLFWInputState -> GLFWInputT m () + putGLFWInput = GLFWInputT . put + -- | To execute a computation with the current input snapshot, we need to give -- supply the current 'GLFWInputState'. This comes from the 'GLFWInputControl' -- associated with the given window. runGLFWInputT :: GLFWInputT m a -> GLFWInputState -> m (a, GLFWInputState) runGLFWInputT (GLFWInputT m) = runStateT m --- | The 'GLFWInput' monad is simply the GLFWInputT transformer around the +-- | The 'GLFWInput' monad is simply the 'GLFWInputT' transformer around the -- identity monad. type GLFWInput = GLFWInputT Identity +-- | Runs the 'GLFWInput' computation with a current input snapshot and returns +-- the potentially modified input. runGLFWInput :: GLFWInput a -> GLFWInputState -> (a, GLFWInputState) runGLFWInput m = runIdentity . runGLFWInputT m -instance Monad m => MonadKeyboard GLFW.Key (GLFWInputT m) where - - keyIsPressed :: GLFW.Key -> GLFWInputT m Bool - keyIsPressed key = GLFWInputT . liftM (isKeyDown key) $ get - - releaseKey :: GLFW.Key -> GLFWInputT m () - releaseKey key = GLFWInputT (get >>= (put . debounceKey key)) +instance MonadGLFWInput m => MonadKeyboard GLFW.Key m where + keyIsPressed :: GLFW.Key -> m Bool + keyIsPressed key = liftM (isKeyDown key) getGLFWInput -instance Monad m => MonadMouse GLFW.MouseButton (GLFWInputT m) where + releaseKey :: GLFW.Key -> m () + releaseKey key = getGLFWInput >>= (putGLFWInput . debounceKey key) - mbIsPressed :: GLFW.MouseButton -> GLFWInputT m Bool - mbIsPressed mb = GLFWInputT . liftM (isButtonPressed mb) $ get +instance MonadGLFWInput m => MonadMouse GLFW.MouseButton m where + mbIsPressed :: GLFW.MouseButton -> m Bool + mbIsPressed mb = liftM (isButtonPressed mb) getGLFWInput - releaseButton :: GLFW.MouseButton -> GLFWInputT m () - releaseButton mb = GLFWInputT (get >>= (put . debounceButton mb)) + releaseButton :: GLFW.MouseButton -> m () + releaseButton mb = getGLFWInput >>= (putGLFWInput . debounceButton mb) - cursor :: GLFWInputT m (Float, Float) - cursor = GLFWInputT . liftM cursorPos $ get + cursor :: m (Float, Float) + cursor = liftM cursorPos getGLFWInput - setCursorMode :: CursorMode -> GLFWInputT m () + setCursorMode :: CursorMode -> m () setCursorMode mode = do - ipt <- GLFWInputT get - GLFWInputT $ put (ipt { cmode = mode }) + ipt <- getGLFWInput + putGLFWInput (ipt { cmode = mode }) - scroll :: GLFWInputT m (Double, Double) - scroll = GLFWInputT . liftM scrollAmt $ get + scroll :: m (Double, Double) + scroll = liftM scrollAmt getGLFWInput kEmptyInput :: GLFWInputState kEmptyInput = GLFWInputState { keysPressed = Map.empty, @@ -216,14 +239,16 @@ -------------------------- scrollCallback :: GLFWInputControl -> GLFW.Window -> Double -> Double -> IO () -scrollCallback (IptCtl ctl _) _ xoff yoff = atomically $ modifyTVar' ctl updateScroll +scrollCallback (IptCtl ctl _) _ xoff yoff = + atomically $ modifyTVar' ctl updateScroll where updateScroll :: GLFWInputState -> GLFWInputState updateScroll = (\input -> input { scrollAmt = (xoff, yoff) }) keyCallback :: GLFWInputControl -> GLFW.Window -> GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys -> IO () -keyCallback (IptCtl ctl _) _ key _ keystate _ = atomically $ modifyTVar' ctl modifyKeys +keyCallback (IptCtl ctl _) _ key _ keystate _ = + atomically $ modifyTVar' ctl modifyKeys where modifyKeys :: GLFWInputState -> GLFWInputState modifyKeys input = case keystate of diff --git a/netwire-input-glfw.cabal b/netwire-input-glfw.cabal --- a/netwire-input-glfw.cabal +++ b/netwire-input-glfw.cabal @@ -2,13 +2,13 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: netwire-input-glfw -version: 0.0.7 +version: 0.0.8 synopsis: GLFW instance of netwire-input description: This package contains the necessary glue to allow the use - of wires from the netwire-input package. In general, the types - associated here should be used only sparingly to plumb the input - state through your netwire program. Otherwise, the state should - not be modified directly. + of wires from the netwire-input package. In general, the + types associated here should be used only sparingly to + plumb the input state through your netwire program. + Otherwise, the state should not be modified directly. homepage: https://www.github.com/Mokosha/netwire-input-glfw license: MIT license-file: LICENSE