{-|
Module      : FRP.Netwire.Input.GLFW
Description : netwire-input instances for use with GLFW
Copyright   : (c) Pavel Krajcevski, 2018
License     : MIT
Maintainer  : Krajcevski@gmail.com
Stability   : experimental
Portability : POSIX

This module contains data types with instances  needed to create wires
that can be used with the netwire-input combinators. In particular, this
package implements 'GLFWInputT' which has instances of 'MonadKeyboard' and
'MonadMouse'

-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module FRP.Netwire.Input.GLFW (
  -- * GLFW Input

  -- ** Basic Input Monad
  GLFWInput, runGLFWInput,

  -- ** Monad Transformer
  GLFWInputT, runGLFWInputT,

  -- * Typeclass
  MonadGLFWInput(..),

  -- * State Types
  GLFWInputControl, GLFWInputState,
  emptyGLFWState,
  getInput, mkInputControl, pollGLFW
) where

--------------------------------------------------------------------------------
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Graphics.UI.GLFW as GLFW
import Control.Applicative
import Control.Concurrent.STM
import Control.DeepSeq
import Control.Monad
import Control.Monad.Fix
import Control.Monad.RWS
import Control.Monad.State
import Control.Monad.Except
import Control.Monad.Cont
import Control.Monad.Identity
import GHC.Float hiding (clamp)
import GHC.Generics

import FRP.Netwire.Input
--------------------------------------------------------------------------------

clamp :: Ord a => a -> a -> a -> a
clamp :: forall a. Ord a => a -> a -> a -> a
clamp a
x a
a a
b
  | a
x forall a. Ord a => a -> a -> Bool
< a
a = a
a
  | a
x forall a. Ord a => a -> a -> Bool
> a
b = a
b
  | Bool
otherwise = a
x

newRange :: Floating a => a -> (a, a) -> (a, a) -> a
newRange :: forall a. Floating a => a -> (a, a) -> (a, a) -> a
newRange a
x (a
omin, a
omax) (a
nmin, a
nmax) =
  a
nmin forall a. Num a => a -> a -> a
+ (a
nmax forall a. Num a => a -> a -> a
- a
nmin) forall a. Num a => a -> a -> a
* ((a
x forall a. Num a => a -> a -> a
- a
omin) forall a. Fractional a => a -> a -> a
/ (a
omax forall a. Num a => a -> a -> a
- a
omin))

newRangeC :: (Ord a, Floating a) => a -> (a, a) -> (a, a) -> a
newRangeC :: forall a. (Ord a, Floating a) => a -> (a, a) -> (a, a) -> a
newRangeC a
x (a, a)
o n :: (a, a)
n@(a
nmin, a
nmax) = forall a. Ord a => a -> a -> a -> a
clamp (forall a. Floating a => a -> (a, a) -> (a, a) -> a
newRange a
x (a, a)
o (a, a)
n) a
nmin a
nmax

modeToGLFWMode :: CursorMode -> GLFW.CursorInputMode
modeToGLFWMode :: CursorMode -> CursorInputMode
modeToGLFWMode CursorMode
CursorMode'Reset = CursorInputMode
GLFW.CursorInputMode'Disabled
modeToGLFWMode CursorMode
CursorMode'Disabled = CursorInputMode
GLFW.CursorInputMode'Disabled
modeToGLFWMode CursorMode
CursorMode'Hidden = CursorInputMode
GLFW.CursorInputMode'Hidden
modeToGLFWMode CursorMode
CursorMode'Enabled = CursorInputMode
GLFW.CursorInputMode'Normal

-- | The GLFW input state is a record that keeps track of which buttons and keys
-- are currently pressed. Because GLFW works with callbacks, a call to pollEvents
-- must be made in order to process any of the events. At this time, all of the
-- appropriate callbacks are fired in order of the events received, and this record
-- is updated to reflect the most recent input state.
data GLFWInputState = GLFWInputState {
  GLFWInputState -> Map Key Int
keysPressed :: Map.Map GLFW.Key Int,
  GLFWInputState -> Set Key
keysReleased :: Set.Set GLFW.Key,
  GLFWInputState -> Map MouseButton Int
mbPressed :: Map.Map GLFW.MouseButton Int,
  GLFWInputState -> Set MouseButton
mbReleased :: Set.Set GLFW.MouseButton,
  GLFWInputState -> (Float, Float)
cursorPos :: (Float, Float),
  GLFWInputState -> CursorMode
cmode :: CursorMode,
  GLFWInputState -> (Double, Double)
scrollAmt :: (Double, Double)
} deriving(Int -> GLFWInputState -> ShowS
[GLFWInputState] -> ShowS
GLFWInputState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GLFWInputState] -> ShowS
$cshowList :: [GLFWInputState] -> ShowS
show :: GLFWInputState -> String
$cshow :: GLFWInputState -> String
showsPrec :: Int -> GLFWInputState -> ShowS
$cshowsPrec :: Int -> GLFWInputState -> ShowS
Show, forall x. Rep GLFWInputState x -> GLFWInputState
forall x. GLFWInputState -> Rep GLFWInputState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GLFWInputState x -> GLFWInputState
$cfrom :: forall x. GLFWInputState -> Rep GLFWInputState x
Generic)

instance NFData GLFWInputState

instance Key GLFW.Key
instance MouseButton GLFW.MouseButton

-- | The 'GLFWInputT' monad transformer is simply a state monad transformer using
-- 'GLFWInputState'
newtype GLFWInputT m a =
  GLFWInputT (StateT GLFWInputState m a)
  deriving ( forall a b. a -> GLFWInputT m b -> GLFWInputT m a
forall a b. (a -> b) -> GLFWInputT m a -> GLFWInputT m b
forall (m :: * -> *) a b.
Functor m =>
a -> GLFWInputT m b -> GLFWInputT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GLFWInputT m a -> GLFWInputT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> GLFWInputT m b -> GLFWInputT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> GLFWInputT m b -> GLFWInputT m a
fmap :: forall a b. (a -> b) -> GLFWInputT m a -> GLFWInputT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GLFWInputT m a -> GLFWInputT m b
Functor
           , forall a. a -> GLFWInputT m a
forall a b. GLFWInputT m a -> GLFWInputT m b -> GLFWInputT m a
forall a b. GLFWInputT m a -> GLFWInputT m b -> GLFWInputT m b
forall a b.
GLFWInputT m (a -> b) -> GLFWInputT m a -> GLFWInputT m b
forall a b c.
(a -> b -> c) -> GLFWInputT m a -> GLFWInputT m b -> GLFWInputT m c
forall {m :: * -> *}. Monad m => Functor (GLFWInputT m)
forall (m :: * -> *) a. Monad m => a -> GLFWInputT m a
forall (m :: * -> *) a b.
Monad m =>
GLFWInputT m a -> GLFWInputT m b -> GLFWInputT m a
forall (m :: * -> *) a b.
Monad m =>
GLFWInputT m a -> GLFWInputT m b -> GLFWInputT m b
forall (m :: * -> *) a b.
Monad m =>
GLFWInputT m (a -> b) -> GLFWInputT m a -> GLFWInputT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> GLFWInputT m a -> GLFWInputT m b -> GLFWInputT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. GLFWInputT m a -> GLFWInputT m b -> GLFWInputT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
GLFWInputT m a -> GLFWInputT m b -> GLFWInputT m a
*> :: forall a b. GLFWInputT m a -> GLFWInputT m b -> GLFWInputT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
GLFWInputT m a -> GLFWInputT m b -> GLFWInputT m b
liftA2 :: forall a b c.
(a -> b -> c) -> GLFWInputT m a -> GLFWInputT m b -> GLFWInputT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> GLFWInputT m a -> GLFWInputT m b -> GLFWInputT m c
<*> :: forall a b.
GLFWInputT m (a -> b) -> GLFWInputT m a -> GLFWInputT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
GLFWInputT m (a -> b) -> GLFWInputT m a -> GLFWInputT m b
pure :: forall a. a -> GLFWInputT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> GLFWInputT m a
Applicative
           , forall a. GLFWInputT m a
forall a. GLFWInputT m a -> GLFWInputT m [a]
forall a. GLFWInputT m a -> GLFWInputT m a -> GLFWInputT m a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
forall {m :: * -> *}. MonadPlus m => Applicative (GLFWInputT m)
forall (m :: * -> *) a. MonadPlus m => GLFWInputT m a
forall (m :: * -> *) a.
MonadPlus m =>
GLFWInputT m a -> GLFWInputT m [a]
forall (m :: * -> *) a.
MonadPlus m =>
GLFWInputT m a -> GLFWInputT m a -> GLFWInputT m a
many :: forall a. GLFWInputT m a -> GLFWInputT m [a]
$cmany :: forall (m :: * -> *) a.
MonadPlus m =>
GLFWInputT m a -> GLFWInputT m [a]
some :: forall a. GLFWInputT m a -> GLFWInputT m [a]
$csome :: forall (m :: * -> *) a.
MonadPlus m =>
GLFWInputT m a -> GLFWInputT m [a]
<|> :: forall a. GLFWInputT m a -> GLFWInputT m a -> GLFWInputT m a
$c<|> :: forall (m :: * -> *) a.
MonadPlus m =>
GLFWInputT m a -> GLFWInputT m a -> GLFWInputT m a
empty :: forall a. GLFWInputT m a
$cempty :: forall (m :: * -> *) a. MonadPlus m => GLFWInputT m a
Alternative
           , forall a. a -> GLFWInputT m a
forall a b. GLFWInputT m a -> GLFWInputT m b -> GLFWInputT m b
forall a b.
GLFWInputT m a -> (a -> GLFWInputT m b) -> GLFWInputT m b
forall (m :: * -> *). Monad m => Applicative (GLFWInputT m)
forall (m :: * -> *) a. Monad m => a -> GLFWInputT m a
forall (m :: * -> *) a b.
Monad m =>
GLFWInputT m a -> GLFWInputT m b -> GLFWInputT m b
forall (m :: * -> *) a b.
Monad m =>
GLFWInputT m a -> (a -> GLFWInputT m b) -> GLFWInputT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> GLFWInputT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> GLFWInputT m a
>> :: forall a b. GLFWInputT m a -> GLFWInputT m b -> GLFWInputT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
GLFWInputT m a -> GLFWInputT m b -> GLFWInputT m b
>>= :: forall a b.
GLFWInputT m a -> (a -> GLFWInputT m b) -> GLFWInputT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
GLFWInputT m a -> (a -> GLFWInputT m b) -> GLFWInputT m b
Monad
           , forall a. (a -> GLFWInputT m a) -> GLFWInputT m a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
forall {m :: * -> *}. MonadFix m => Monad (GLFWInputT m)
forall (m :: * -> *) a.
MonadFix m =>
(a -> GLFWInputT m a) -> GLFWInputT m a
mfix :: forall a. (a -> GLFWInputT m a) -> GLFWInputT m a
$cmfix :: forall (m :: * -> *) a.
MonadFix m =>
(a -> GLFWInputT m a) -> GLFWInputT m a
MonadFix
           , forall a. IO a -> GLFWInputT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (GLFWInputT m)
forall (m :: * -> *) a. MonadIO m => IO a -> GLFWInputT m a
liftIO :: forall a. IO a -> GLFWInputT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> GLFWInputT m a
MonadIO
           , MonadWriter w
           , MonadReader r
           , MonadError e
           , forall a. GLFWInputT m a
forall a. GLFWInputT m a -> GLFWInputT m a -> GLFWInputT m a
forall {m :: * -> *}. MonadPlus m => Monad (GLFWInputT m)
forall (m :: * -> *). MonadPlus m => Alternative (GLFWInputT m)
forall (m :: * -> *) a. MonadPlus m => GLFWInputT m a
forall (m :: * -> *) a.
MonadPlus m =>
GLFWInputT m a -> GLFWInputT m a -> GLFWInputT m a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
mplus :: forall a. GLFWInputT m a -> GLFWInputT m a -> GLFWInputT m a
$cmplus :: forall (m :: * -> *) a.
MonadPlus m =>
GLFWInputT m a -> GLFWInputT m a -> GLFWInputT m a
mzero :: forall a. GLFWInputT m a
$cmzero :: forall (m :: * -> *) a. MonadPlus m => GLFWInputT m a
MonadPlus
           , forall a b.
((a -> GLFWInputT m b) -> GLFWInputT m a) -> GLFWInputT m a
forall (m :: * -> *).
Monad m -> (forall a b. ((a -> m b) -> m a) -> m a) -> MonadCont m
forall {m :: * -> *}. MonadCont m => Monad (GLFWInputT m)
forall (m :: * -> *) a b.
MonadCont m =>
((a -> GLFWInputT m b) -> GLFWInputT m a) -> GLFWInputT m a
callCC :: forall a b.
((a -> GLFWInputT m b) -> GLFWInputT m a) -> GLFWInputT m a
$ccallCC :: forall (m :: * -> *) a b.
MonadCont m =>
((a -> GLFWInputT m b) -> GLFWInputT m a) -> GLFWInputT m a
MonadCont
           , forall (m :: * -> *) a. Monad m => m a -> GLFWInputT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> GLFWInputT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> GLFWInputT m a
MonadTrans
           )

instance MonadState s m => MonadState s (GLFWInputT m) where
  get :: GLFWInputT m s
get = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall s (m :: * -> *). MonadState s m => m s
get
  put :: s -> GLFWInputT m ()
put = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadState s m => s -> m ()
put
  state :: forall a. (s -> (a, s)) -> GLFWInputT m a
state = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
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 m GLFWInputState
getGLFWInput = forall (m :: * -> *) a. StateT GLFWInputState m a -> GLFWInputT m a
GLFWInputT forall s (m :: * -> *). MonadState s m => m s
get

  putGLFWInput :: GLFWInputState -> GLFWInputT m ()
  putGLFWInput :: GLFWInputState -> GLFWInputT m ()
putGLFWInput = forall (m :: * -> *) a. StateT GLFWInputState m a -> GLFWInputT m a
GLFWInputT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadState s m => s -> m ()
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 :: forall (m :: * -> *) a.
GLFWInputT m a -> GLFWInputState -> m (a, GLFWInputState)
runGLFWInputT (GLFWInputT StateT GLFWInputState m a
m) = forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT GLFWInputState m a
m

-- | 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 :: forall a. GLFWInput a -> GLFWInputState -> (a, GLFWInputState)
runGLFWInput GLFWInput a
m = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
GLFWInputT m a -> GLFWInputState -> m (a, GLFWInputState)
runGLFWInputT GLFWInput a
m

instance MonadGLFWInput m => MonadKeyboard GLFW.Key m where
  keyIsPressed :: GLFW.Key -> m Bool
  keyIsPressed :: Key -> m Bool
keyIsPressed Key
key = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Key -> GLFWInputState -> Bool
isKeyDown Key
key) forall (m :: * -> *). MonadGLFWInput m => m GLFWInputState
getGLFWInput

  releaseKey :: GLFW.Key -> m ()
  releaseKey :: Key -> m ()
releaseKey Key
key = forall (m :: * -> *). MonadGLFWInput m => m GLFWInputState
getGLFWInput forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (m :: * -> *). MonadGLFWInput m => GLFWInputState -> m ()
putGLFWInput forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> GLFWInputState -> GLFWInputState
debounceKey Key
key)

instance MonadGLFWInput m => MonadMouse GLFW.MouseButton m where
  mbIsPressed :: GLFW.MouseButton -> m Bool
  mbIsPressed :: MouseButton -> m Bool
mbIsPressed MouseButton
mb = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (MouseButton -> GLFWInputState -> Bool
isButtonPressed MouseButton
mb) forall (m :: * -> *). MonadGLFWInput m => m GLFWInputState
getGLFWInput

  releaseButton :: GLFW.MouseButton -> m ()
  releaseButton :: MouseButton -> m ()
releaseButton MouseButton
mb = forall (m :: * -> *). MonadGLFWInput m => m GLFWInputState
getGLFWInput forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (m :: * -> *). MonadGLFWInput m => GLFWInputState -> m ()
putGLFWInput forall b c a. (b -> c) -> (a -> b) -> a -> c
. MouseButton -> GLFWInputState -> GLFWInputState
debounceButton MouseButton
mb)

  cursor :: m (Float, Float)
  cursor :: m (Float, Float)
cursor = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM GLFWInputState -> (Float, Float)
cursorPos forall (m :: * -> *). MonadGLFWInput m => m GLFWInputState
getGLFWInput

  setCursorMode :: CursorMode -> m ()
  setCursorMode :: CursorMode -> m ()
setCursorMode CursorMode
mode = do
    GLFWInputState
ipt <- forall (m :: * -> *). MonadGLFWInput m => m GLFWInputState
getGLFWInput
    forall (m :: * -> *). MonadGLFWInput m => GLFWInputState -> m ()
putGLFWInput (GLFWInputState
ipt { cmode :: CursorMode
cmode = CursorMode
mode })

  scroll :: m (Double, Double)
  scroll :: m (Double, Double)
scroll = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM GLFWInputState -> (Double, Double)
scrollAmt forall (m :: * -> *). MonadGLFWInput m => m GLFWInputState
getGLFWInput

isKeyDown :: GLFW.Key -> GLFWInputState -> Bool
isKeyDown :: Key -> GLFWInputState -> Bool
isKeyDown Key
key = (forall k a. Ord k => k -> Map k a -> Bool
Map.member Key
key) forall b c a. (b -> c) -> (a -> b) -> a -> c
. GLFWInputState -> Map Key Int
keysPressed

withPressedKey :: GLFWInputState -> GLFW.Key -> (a -> a) -> a -> a
withPressedKey :: forall a. GLFWInputState -> Key -> (a -> a) -> a -> a
withPressedKey GLFWInputState
input Key
key a -> a
fn
  | Key -> GLFWInputState -> Bool
isKeyDown Key
key GLFWInputState
input = a -> a
fn
  | Bool
otherwise = forall a. a -> a
id

debounceKey :: GLFW.Key -> GLFWInputState -> GLFWInputState
debounceKey :: Key -> GLFWInputState -> GLFWInputState
debounceKey Key
key GLFWInputState
input = GLFWInputState
input { keysPressed :: Map Key Int
keysPressed = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Key
key (GLFWInputState -> Map Key Int
keysPressed GLFWInputState
input) }

isButtonPressed :: GLFW.MouseButton -> GLFWInputState -> Bool
isButtonPressed :: MouseButton -> GLFWInputState -> Bool
isButtonPressed MouseButton
mb = forall k a. Ord k => k -> Map k a -> Bool
Map.member MouseButton
mb forall b c a. (b -> c) -> (a -> b) -> a -> c
. GLFWInputState -> Map MouseButton Int
mbPressed

withPressedButton :: GLFWInputState -> GLFW.MouseButton -> (a -> a) -> a -> a
withPressedButton :: forall a. GLFWInputState -> MouseButton -> (a -> a) -> a -> a
withPressedButton GLFWInputState
input MouseButton
mb a -> a
fn = if MouseButton -> GLFWInputState -> Bool
isButtonPressed MouseButton
mb GLFWInputState
input then a -> a
fn else forall a. a -> a
id

debounceButton :: GLFW.MouseButton -> GLFWInputState -> GLFWInputState
debounceButton :: MouseButton -> GLFWInputState -> GLFWInputState
debounceButton MouseButton
mb GLFWInputState
input = GLFWInputState
input { mbPressed :: Map MouseButton Int
mbPressed = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete MouseButton
mb (GLFWInputState -> Map MouseButton Int
mbPressed GLFWInputState
input) }

-- | This is an 'STM' variable that holds the current input state. It cannot be
-- manipulated directly, but it is updated by GLFW each time 'pollGLFW' is called.
data GLFWInputControl = IptCtl (TVar GLFWInputState) GLFW.Window

setCursorToWindowCenter :: GLFW.Window -> IO ()
setCursorToWindowCenter :: Window -> IO ()
setCursorToWindowCenter Window
win = do
  (Int
w, Int
h) <- Window -> IO (Int, Int)
GLFW.getWindowSize Window
win
  Window -> Double -> Double -> IO ()
GLFW.setCursorPos Window
win (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w forall a. Fractional a => a -> a -> a
/ Double
2.0) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h forall a. Fractional a => a -> a -> a
/ Double
2.0)

-- | Returns a current snapshot of the input
getInput :: GLFWInputControl -> IO GLFWInputState
getInput :: GLFWInputControl -> IO GLFWInputState
getInput (IptCtl TVar GLFWInputState
var Window
_) = forall a. TVar a -> IO a
readTVarIO TVar GLFWInputState
var

setInput :: GLFWInputControl -> GLFWInputState -> IO ()
setInput :: GLFWInputControl -> GLFWInputState -> IO ()
setInput (IptCtl TVar GLFWInputState
var Window
win) GLFWInputState
ipt = do
  -- Do we need to change the cursor mode?
  CursorInputMode
curMode <- Window -> IO CursorInputMode
GLFW.getCursorInputMode Window
win
  let newMode :: CursorInputMode
newMode = CursorMode -> CursorInputMode
modeToGLFWMode (GLFWInputState -> CursorMode
cmode GLFWInputState
ipt)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CursorInputMode
newMode forall a. Eq a => a -> a -> Bool
== CursorInputMode
curMode) forall a b. (a -> b) -> a -> b
$
    Window -> CursorInputMode -> IO ()
GLFW.setCursorInputMode Window
win CursorInputMode
newMode

  -- Write the new input
  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar GLFWInputState
var forall a b. NFData a => (a -> b) -> a -> b
$!! (GLFWInputState
ipt { scrollAmt :: (Double, Double)
scrollAmt = (Double
0, Double
0) })

resetCursorPos :: GLFWInputState -> GLFWInputState
resetCursorPos :: GLFWInputState -> GLFWInputState
resetCursorPos GLFWInputState
input = GLFWInputState
input { cursorPos :: (Float, Float)
cursorPos = (Float
0, Float
0) }

resolveReleased :: GLFWInputState -> GLFWInputState
resolveReleased :: GLFWInputState -> GLFWInputState
resolveReleased GLFWInputState
input = GLFWInputState
input {
  keysPressed :: Map Key Int
keysPressed =
     (forall a. Num a => a -> a -> a
+Int
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
     forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Map k a
Map.delete) (GLFWInputState -> Map Key Int
keysPressed GLFWInputState
input) (forall a. Set a -> [a]
Set.elems forall a b. (a -> b) -> a -> b
$ GLFWInputState -> Set Key
keysReleased GLFWInputState
input),
  keysReleased :: Set Key
keysReleased = forall a. Set a
Set.empty,
  mbPressed :: Map MouseButton Int
mbPressed =
    (forall a. Num a => a -> a -> a
+Int
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Map k a
Map.delete) (GLFWInputState -> Map MouseButton Int
mbPressed GLFWInputState
input) (forall a. Set a -> [a]
Set.elems forall a b. (a -> b) -> a -> b
$ GLFWInputState -> Set MouseButton
mbReleased GLFWInputState
input),
  mbReleased :: Set MouseButton
mbReleased = forall a. Set a
Set.empty
  }

--------------------------

scrollCallback :: GLFWInputControl -> GLFW.Window -> Double -> Double -> IO ()
scrollCallback :: GLFWInputControl -> Window -> Double -> Double -> IO ()
scrollCallback (IptCtl TVar GLFWInputState
ctl Window
_) Window
_ Double
xoff Double
yoff =
  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar GLFWInputState
ctl GLFWInputState -> GLFWInputState
updateScroll
  where
    updateScroll :: GLFWInputState -> GLFWInputState
    updateScroll :: GLFWInputState -> GLFWInputState
updateScroll = (\GLFWInputState
input -> GLFWInputState
input { scrollAmt :: (Double, Double)
scrollAmt = (Double
xoff, Double
yoff) })

keyCallback :: GLFWInputControl -> GLFW.Window ->
               GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys -> IO ()
keyCallback :: GLFWInputControl
-> Window -> Key -> Int -> KeyState -> ModifierKeys -> IO ()
keyCallback (IptCtl TVar GLFWInputState
ctl Window
_) Window
_ Key
key Int
_ KeyState
keystate ModifierKeys
_ =
  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar GLFWInputState
ctl GLFWInputState -> GLFWInputState
modifyKeys
  where
    modifyKeys :: GLFWInputState -> GLFWInputState
    modifyKeys :: GLFWInputState -> GLFWInputState
modifyKeys GLFWInputState
input = case KeyState
keystate of
      KeyState
GLFW.KeyState'Pressed -> GLFWInputState
input {
        keysPressed :: Map Key Int
keysPressed = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (GLFWInputState -> Map Key Int
keysPressed GLFWInputState
input) (forall k a. k -> a -> Map k a
Map.singleton Key
key Int
0) }
      KeyState
GLFW.KeyState'Released -> GLFWInputState
input {
        keysPressed :: Map Key Int
keysPressed = forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update Int -> Maybe Int
removeReleased Key
key (GLFWInputState -> Map Key Int
keysPressed GLFWInputState
input),
        keysReleased :: Set Key
keysReleased =
          case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
key (GLFWInputState -> Map Key Int
keysPressed GLFWInputState
input) of
            -- If the key was just added... queue it up
            Just Int
0 -> forall a. Ord a => a -> Set a -> Set a
Set.insert Key
key (GLFWInputState -> Set Key
keysReleased GLFWInputState
input)
            -- If the key isn't pressed then it must have been debounced... do nothing
            -- If the key wasn't just added we're removing it above... do nothing...
            Maybe Int
_ -> GLFWInputState -> Set Key
keysReleased GLFWInputState
input
        }
      KeyState
_ -> GLFWInputState
input

    removeReleased :: Int -> Maybe Int
    removeReleased :: Int -> Maybe Int
removeReleased Int
0 = forall a. a -> Maybe a
Just Int
0
    removeReleased Int
_ = forall a. Maybe a
Nothing

mouseButtonCallback :: GLFWInputControl -> GLFW.Window ->
                       GLFW.MouseButton -> GLFW.MouseButtonState ->
                       GLFW.ModifierKeys -> IO ()
mouseButtonCallback :: GLFWInputControl
-> Window
-> MouseButton
-> MouseButtonState
-> ModifierKeys
-> IO ()
mouseButtonCallback (IptCtl TVar GLFWInputState
ctl Window
_) Window
_ MouseButton
button MouseButtonState
state ModifierKeys
_ =
  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar GLFWInputState
ctl GLFWInputState -> GLFWInputState
modify
  where
    modify :: GLFWInputState -> GLFWInputState
    modify :: GLFWInputState -> GLFWInputState
modify GLFWInputState
input = case MouseButtonState
state of
      MouseButtonState
GLFW.MouseButtonState'Pressed -> GLFWInputState
input {
        mbPressed :: Map MouseButton Int
mbPressed = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (GLFWInputState -> Map MouseButton Int
mbPressed GLFWInputState
input) (forall k a. k -> a -> Map k a
Map.singleton MouseButton
button Int
0) }
      MouseButtonState
GLFW.MouseButtonState'Released -> GLFWInputState
input {
        mbPressed :: Map MouseButton Int
mbPressed = forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update Int -> Maybe Int
removeReleased MouseButton
button (GLFWInputState -> Map MouseButton Int
mbPressed GLFWInputState
input),
        mbReleased :: Set MouseButton
mbReleased =
          case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MouseButton
button (GLFWInputState -> Map MouseButton Int
mbPressed GLFWInputState
input) of
            Just Int
0 -> forall a. Ord a => a -> Set a -> Set a
Set.insert MouseButton
button (GLFWInputState -> Set MouseButton
mbReleased GLFWInputState
input)
            Maybe Int
_ -> GLFWInputState -> Set MouseButton
mbReleased GLFWInputState
input
        }

    removeReleased :: Int -> Maybe Int
    removeReleased :: Int -> Maybe Int
removeReleased Int
0 = forall a. a -> Maybe a
Just Int
0
    removeReleased Int
_ = forall a. Maybe a
Nothing

cursorPosCallback :: GLFWInputControl -> GLFW.Window -> Double -> Double -> IO ()
cursorPosCallback :: GLFWInputControl -> Window -> Double -> Double -> IO ()
cursorPosCallback (IptCtl TVar GLFWInputState
ctl Window
_) Window
win Double
x Double
y = do
  (Int
w, Int
h) <- Window -> IO (Int, Int)
GLFW.getWindowSize Window
win
  let xf :: Float
xf = forall a. (Ord a, Floating a) => a -> (a, a) -> (a, a) -> a
newRangeC (Double -> Float
double2Float Double
x) (Float
0, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w) (-Float
1, Float
1)
      yf :: Float
yf = forall a. (Ord a, Floating a) => a -> (a, a) -> (a, a) -> a
newRangeC (Double -> Float
double2Float Double
y) (Float
0, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h) (-Float
1, Float
1)
  forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar GLFWInputState
ctl (\GLFWInputState
ipt -> GLFWInputState
ipt { cursorPos :: (Float, Float)
cursorPos = (Float
xf, Float
yf)})

-- | Returns the empty GLFW state. In this state, no buttons are pressed, and
-- the mouse and scroll positions are set to zero. The cursor is also placed in
-- the disabled state.
emptyGLFWState :: GLFWInputState
emptyGLFWState :: GLFWInputState
emptyGLFWState = GLFWInputState
  { keysPressed :: Map Key Int
keysPressed = forall k a. Map k a
Map.empty
  , keysReleased :: Set Key
keysReleased = forall a. Set a
Set.empty
  , mbPressed :: Map MouseButton Int
mbPressed = forall k a. Map k a
Map.empty
  , mbReleased :: Set MouseButton
mbReleased = forall a. Set a
Set.empty
  , cursorPos :: (Float, Float)
cursorPos = (Float
0, Float
0)
  , cmode :: CursorMode
cmode = CursorMode
CursorMode'Disabled
  , scrollAmt :: (Double, Double)
scrollAmt = (Double
0, Double
0)
  }

-- | Creates and returns an 'STM' variable for the window that holds all of the
-- most recent input state information
mkInputControl :: GLFW.Window -> IO GLFWInputControl
mkInputControl :: Window -> IO GLFWInputControl
mkInputControl Window
win = do
  TVar GLFWInputState
ctlvar <- forall a. a -> IO (TVar a)
newTVarIO (GLFWInputState
emptyGLFWState { cmode :: CursorMode
cmode = CursorMode
CursorMode'Enabled })
  let ctl :: GLFWInputControl
ctl = TVar GLFWInputState -> Window -> GLFWInputControl
IptCtl TVar GLFWInputState
ctlvar Window
win
  Window -> Maybe (Window -> Double -> Double -> IO ()) -> IO ()
GLFW.setScrollCallback Window
win (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GLFWInputControl -> Window -> Double -> Double -> IO ()
scrollCallback GLFWInputControl
ctl)
  Window
-> Maybe
     (Window -> Key -> Int -> KeyState -> ModifierKeys -> IO ())
-> IO ()
GLFW.setKeyCallback Window
win (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GLFWInputControl
-> Window -> Key -> Int -> KeyState -> ModifierKeys -> IO ()
keyCallback GLFWInputControl
ctl)
  Window -> Maybe (Window -> Double -> Double -> IO ()) -> IO ()
GLFW.setCursorPosCallback Window
win (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GLFWInputControl -> Window -> Double -> Double -> IO ()
cursorPosCallback GLFWInputControl
ctl)
  Window
-> Maybe
     (Window
      -> MouseButton -> MouseButtonState -> ModifierKeys -> IO ())
-> IO ()
GLFW.setMouseButtonCallback Window
win (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GLFWInputControl
-> Window
-> MouseButton
-> MouseButtonState
-> ModifierKeys
-> IO ()
mouseButtonCallback GLFWInputControl
ctl)
  forall (m :: * -> *) a. Monad m => a -> m a
return GLFWInputControl
ctl

-- | Allows GLFW to interact with the windowing system to update the current
-- state. The old state must be passed in order to properly reset certain
-- properties such as the scroll wheel. The returned input state is identical
-- to a subsequent call to 'getInput' right after a call to 'GLFW.pollEvents'
pollGLFW :: GLFWInputState -> GLFWInputControl -> IO GLFWInputState
pollGLFW :: GLFWInputState -> GLFWInputControl -> IO GLFWInputState
pollGLFW GLFWInputState
ipt iptctl :: GLFWInputControl
iptctl@(IptCtl TVar GLFWInputState
_ Window
win) = do
  let ipt' :: GLFWInputState
ipt' = GLFWInputState -> GLFWInputState
resolveReleased GLFWInputState
ipt

  -- Do we need to reset the cursor?
  if GLFWInputState -> CursorMode
cmode GLFWInputState
ipt' forall a. Eq a => a -> a -> Bool
== CursorMode
CursorMode'Reset
    then do
    Window -> IO ()
setCursorToWindowCenter Window
win
    GLFWInputControl -> GLFWInputState -> IO ()
setInput GLFWInputControl
iptctl (GLFWInputState -> GLFWInputState
resetCursorPos GLFWInputState
ipt')
    else GLFWInputControl -> GLFWInputState -> IO ()
setInput GLFWInputControl
iptctl GLFWInputState
ipt'

  IO ()
GLFW.pollEvents
  GLFWInputControl -> IO GLFWInputState
getInput GLFWInputControl
iptctl