-- {-# 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
(KeyEvent -> KeyEvent -> Bool)
-> (KeyEvent -> KeyEvent -> Bool) -> Eq KeyEvent
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 = [(Key, Modifiers, Position)] -> IO KeyTable
forall a. a -> IO (IORef a)
newIORef []

getKeys :: KeyTable -> IO [(Key, Modifiers, Position)]
getKeys :: KeyTable -> IO [(Key, Modifiers, Position)]
getKeys = KeyTable -> IO [(Key, Modifiers, Position)]
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 = KeyTable
-> ([(Key, Modifiers, Position)] -> [(Key, Modifiers, Position)])
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef KeyTable
keyTab ((Key
key,Modifiers
mods,Position
pos)(Key, Modifiers, Position)
-> [(Key, Modifiers, Position)] -> [(Key, Modifiers, Position)]
forall a. a -> [a] -> [a]
:)

deleteFromKeyTable :: KeyTable -> Key -> IO ()
deleteFromKeyTable :: KeyTable -> Key -> IO ()
deleteFromKeyTable KeyTable
keyTab Key
key = KeyTable
-> ([(Key, Modifiers, Position)] -> [(Key, Modifiers, Position)])
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef KeyTable
keyTab (((Key, Modifiers, Position) -> (Key, Modifiers, Position) -> Bool)
-> (Key, Modifiers, Position)
-> [(Key, Modifiers, Position)]
-> [(Key, Modifiers, Position)]
forall a. (a -> a -> Bool) -> a -> [a] -> [a]
deleteBy (\(Key
k,Modifiers
_,Position
_) (Key
l,Modifiers
_,Position
_) -> Key
kKey -> Key -> Bool
forall 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 = [((Key, KeyEvent), Modifiers -> Position -> IO ())]
-> IO BindingTable
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 =
   BindingTable
-> ([((Key, KeyEvent), Modifiers -> Position -> IO ())]
    -> [((Key, KeyEvent), Modifiers -> Position -> IO ())])
-> IO ()
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 (Key, KeyEvent) -> (Key, KeyEvent) -> Bool
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 Maybe (Modifiers -> Position -> IO ())
forall a. Maybe a
Nothing
   BindingTable
-> ([((Key, KeyEvent), Modifiers -> Position -> IO ())]
    -> [((Key, KeyEvent), Modifiers -> Position -> IO ())])
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef BindingTable
bindingTable (((Key
key, KeyEvent
event), Modifiers -> Position -> IO ()
action) ((Key, KeyEvent), Modifiers -> Position -> IO ())
-> [((Key, KeyEvent), Modifiers -> Position -> IO ())]
-> [((Key, KeyEvent), Modifiers -> Position -> IO ())]
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  =
   BindingTable
-> IO [((Key, KeyEvent), Modifiers -> Position -> IO ())]
forall a. IORef a -> IO a
readIORef BindingTable
bindingTable IO [((Key, KeyEvent), Modifiers -> Position -> IO ())]
-> ([((Key, KeyEvent), Modifiers -> Position -> IO ())] -> IO ())
-> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IO ()
-> ((Modifiers -> Position -> IO ()) -> IO ())
-> Maybe (Modifiers -> Position -> IO ())
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\Modifiers -> Position -> IO ()
a -> Modifiers -> Position -> IO ()
a Modifiers
mods Position
pos) (Maybe (Modifiers -> Position -> IO ()) -> IO ())
-> ([((Key, KeyEvent), Modifiers -> Position -> IO ())]
    -> Maybe (Modifiers -> Position -> IO ()))
-> [((Key, KeyEvent), Modifiers -> Position -> IO ())]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, KeyEvent)
-> [((Key, KeyEvent), Modifiers -> Position -> IO ())]
-> Maybe (Modifiers -> Position -> IO ())
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 IO [(Key, Modifiers, Position)]
-> ([(Key, Modifiers, Position)] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Key, Modifiers, Position) -> IO ())
-> [(Key, Modifiers, Position)] -> IO ()
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 StateVar PerWindowKeyRepeat -> PerWindowKeyRepeat -> IO ()
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 :: Key -> KeyState -> Modifiers -> Position -> IO ()
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 (Key -> KeyState -> Modifiers -> Position -> IO ()))
keyboardMouseCallback SettableStateVar
  (Maybe (Key -> KeyState -> Modifiers -> Position -> IO ()))
-> Maybe (Key -> KeyState -> Modifiers -> Position -> IO ())
-> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (Key -> KeyState -> Modifiers -> Position -> IO ())
-> Maybe (Key -> KeyState -> Modifiers -> Position -> IO ())
forall a. a -> Maybe a
Just Key -> KeyState -> Modifiers -> Position -> IO ()
keyboardMouse
   (KeyBinder, IO ()) -> IO (KeyBinder, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (BindingTable -> KeyBinder
bindKey BindingTable
bindingTable, BindingTable -> KeyTable -> IO ()
stillDown BindingTable
bindingTable KeyTable
pressedKeys)