-- {-# OPTIONS_HADDOCK hide #-}
{- |
GLUT-based keyboard/mouse handling.

Sven Panne 2000 <Sven.Panne@informatik.uni-muenchen.de>

This provides a "still down" event in addition to GLUT's key/mouse
button up/down events, and manages bindings from input events to actions.

-}

module Graphics.UI.GLUT.Input (
   Key(..), KeyEvent(..), KeyBinder, InputHandler, StillDownHandler, glutInitInput
) where

import Data.IORef(IORef, newIORef, readIORef, modifyIORef)
import Data.List(deleteBy)
import Graphics.UI.GLUT

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

data KeyEvent = Press | StillDown | Release   deriving KeyEvent -> KeyEvent -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyEvent -> KeyEvent -> Bool
$c/= :: KeyEvent -> KeyEvent -> Bool
== :: KeyEvent -> KeyEvent -> Bool
$c== :: KeyEvent -> KeyEvent -> Bool
Eq

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

-- | A mutable list of keys (or mouse buttons), along with modifier
-- state and mouse position.
type KeyTable = IORef [(Key, Modifiers, Position)]

newKeyTable :: IO KeyTable
newKeyTable :: IO KeyTable
newKeyTable = forall a. a -> IO (IORef a)
newIORef []

getKeys :: KeyTable -> IO [(Key, Modifiers, Position)]
getKeys :: KeyTable -> IO [(Key, Modifiers, Position)]
getKeys = forall a. IORef a -> IO a
readIORef

insertIntoKeyTable :: KeyTable -> Key -> Modifiers -> Position -> IO ()
insertIntoKeyTable :: KeyTable -> Key -> Modifiers -> Position -> IO ()
insertIntoKeyTable KeyTable
keyTab Key
key Modifiers
mods Position
pos = forall a. IORef a -> (a -> a) -> IO ()
modifyIORef KeyTable
keyTab ((Key
key,Modifiers
mods,Position
pos)forall a. a -> [a] -> [a]
:)

deleteFromKeyTable :: KeyTable -> Key -> IO ()
deleteFromKeyTable :: KeyTable -> Key -> IO ()
deleteFromKeyTable KeyTable
keyTab Key
key = forall a. IORef a -> (a -> a) -> IO ()
modifyIORef KeyTable
keyTab (forall a. (a -> a -> Bool) -> a -> [a] -> [a]
deleteBy (\(Key
k,Modifiers
_,Position
_) (Key
l,Modifiers
_,Position
_) -> Key
kforall a. Eq a => a -> a -> Bool
==Key
l) (Key
key, Modifiers
nullmods, Position
nullpos))
  where nullmods :: Modifiers
nullmods = KeyState -> KeyState -> KeyState -> Modifiers
Modifiers KeyState
Up KeyState
Up KeyState
Up
        nullpos :: Position
nullpos = GLint -> GLint -> Position
Position GLint
0 GLint
0

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

type InputHandler = Modifiers -> Position -> IO ()

type KeyBinder = Key -> KeyEvent -> Maybe InputHandler -> IO ()

-- TODO: Improve type 

-- | A mutable list of mappings from key/mousebutton up/down/stilldown
-- events to IO actions.
type BindingTable = IORef [((Key,KeyEvent), InputHandler)]

newBindingTable :: IO BindingTable
newBindingTable :: IO BindingTable
newBindingTable = forall a. a -> IO (IORef a)
newIORef []

bindKey :: BindingTable -> KeyBinder
bindKey :: BindingTable -> KeyBinder
bindKey BindingTable
bindingTable Key
key KeyEvent
event Maybe (Modifiers -> Position -> IO ())
Nothing =
   forall a. IORef a -> (a -> a) -> IO ()
modifyIORef BindingTable
bindingTable (\[((Key, KeyEvent), Modifiers -> Position -> IO ())]
t -> [ ((Key, KeyEvent), Modifiers -> Position -> IO ())
e | e :: ((Key, KeyEvent), Modifiers -> Position -> IO ())
e@((Key, KeyEvent)
b,Modifiers -> Position -> IO ()
_) <- [((Key, KeyEvent), Modifiers -> Position -> IO ())]
t, (Key, KeyEvent)
b forall a. Eq a => a -> a -> Bool
/= (Key
key, KeyEvent
event)])
bindKey BindingTable
bindingTable Key
key KeyEvent
event (Just Modifiers -> Position -> IO ()
action) = do
   BindingTable -> KeyBinder
bindKey BindingTable
bindingTable Key
key KeyEvent
event forall a. Maybe a
Nothing
   forall a. IORef a -> (a -> a) -> IO ()
modifyIORef BindingTable
bindingTable (((Key
key, KeyEvent
event), Modifiers -> Position -> IO ()
action) forall a. a -> [a] -> [a]
:)

execAction :: BindingTable -> Key -> KeyEvent -> Modifiers -> Position -> IO ()
execAction :: BindingTable -> Key -> KeyEvent -> Modifiers -> Position -> IO ()
execAction BindingTable
bindingTable Key
key KeyEvent
event Modifiers
mods Position
pos  =
   forall a. IORef a -> IO a
readIORef BindingTable
bindingTable forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\Modifiers -> Position -> IO ()
a -> Modifiers -> Position -> IO ()
a Modifiers
mods Position
pos) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Key
key, KeyEvent
event))

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

type StillDownHandler = IO ()

stillDown :: BindingTable -> KeyTable -> StillDownHandler
stillDown :: BindingTable -> KeyTable -> IO ()
stillDown BindingTable
bindingTable KeyTable
pressedKeys =
   KeyTable -> IO [(Key, Modifiers, Position)]
getKeys KeyTable
pressedKeys forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Key
k,Modifiers
mods,Position
pos) -> BindingTable -> Key -> KeyEvent -> Modifiers -> Position -> IO ()
execAction BindingTable
bindingTable Key
k KeyEvent
StillDown Modifiers
mods Position
pos)

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

-- | Initialise the input system, which keeps a list of input event to
-- action bindings and executes the the proper actions automatically.
-- Returns a function for adding bindings, and another which should be
-- called periodically (eg from refresh) to trigger still-down actions.
glutInitInput :: IO (KeyBinder, StillDownHandler)
glutInitInput :: IO (KeyBinder, IO ())
glutInitInput = do
  -- globalKeyRepeat would be a little bit more efficient, but it has
  -- two disadvantages: it is not yet implemented for MS windows and
  -- it changes the global state of X11.
   StateVar PerWindowKeyRepeat
perWindowKeyRepeat forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= PerWindowKeyRepeat
PerWindowKeyRepeatOff
   BindingTable
bindingTable <- IO BindingTable
newBindingTable
   KeyTable
pressedKeys  <- IO KeyTable
newKeyTable
   let keyPress :: Key -> Modifiers -> Position -> IO ()
keyPress Key
k Modifiers
mods Position
pos = do
         KeyTable -> Key -> Modifiers -> Position -> IO ()
insertIntoKeyTable KeyTable
pressedKeys Key
k Modifiers
mods Position
pos
         BindingTable -> Key -> KeyEvent -> Modifiers -> Position -> IO ()
execAction BindingTable
bindingTable Key
k KeyEvent
Press Modifiers
mods Position
pos
       keyRelease :: Key -> Modifiers -> Position -> IO ()
keyRelease Key
k Modifiers
mods Position
pos = do 
         KeyTable -> Key -> IO ()
deleteFromKeyTable KeyTable
pressedKeys Key
k
         BindingTable -> Key -> KeyEvent -> Modifiers -> Position -> IO ()
execAction BindingTable
bindingTable Key
k KeyEvent
Release Modifiers
mods Position
pos
       keyboardMouse :: KeyboardMouseCallback
keyboardMouse Key
k KeyState
Down Modifiers
mods Position
pos = Key -> Modifiers -> Position -> IO ()
keyPress   Key
k Modifiers
mods Position
pos
       keyboardMouse Key
k KeyState
Up   Modifiers
mods Position
pos = Key -> Modifiers -> Position -> IO ()
keyRelease Key
k Modifiers
mods Position
pos
   SettableStateVar (Maybe KeyboardMouseCallback)
keyboardMouseCallback forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just KeyboardMouseCallback
keyboardMouse
   forall (m :: * -> *) a. Monad m => a -> m a
return (BindingTable -> KeyBinder
bindKey BindingTable
bindingTable, BindingTable -> KeyTable -> IO ()
stillDown BindingTable
bindingTable KeyTable
pressedKeys)