{-
   GLUT-based keyboard/mouse handling
   Sven Panne 2000.   mailto:Sven.Panne@informatik.uni-muenchen.de
-}

module UserInput (
  KeyEvent(..), KeyBinder, StillDownHandler, initUserInput
) where

import Data.IORef ( IORef, newIORef, readIORef, modifyIORef )
import Data.List  ( delete )

import Graphics.UI.GLUT

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

data KeyEvent = Press | StillDown | Release   deriving Eq

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

type KeyTable = IORef [Key]

newKeyTable :: IO KeyTable
newKeyTable = newIORef []

getKeys :: KeyTable -> IO [Key]
getKeys = readIORef

insertIntoKeyTable :: KeyTable -> Key -> IO ()
insertIntoKeyTable keyTab key = modifyIORef keyTab (key:)

deleteFromKeyTable :: KeyTable -> Key -> IO ()
deleteFromKeyTable keyTab key = modifyIORef keyTab (delete key)

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

type KeyCallback = Modifiers -> WindowPosition -> IO ()

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

-- TODO: Improve type
type BindingTable = IORef [((Key,KeyEvent), KeyCallback)]

newBindingTable :: IO BindingTable
newBindingTable = newIORef []

bindKey :: BindingTable -> KeyBinder
bindKey bindingTable key event Nothing =
   modifyIORef bindingTable (\t -> [ e | e@(b,_) <- t, b /= (key, event)])
bindKey bindingTable key event (Just action) = do
   bindKey bindingTable key event Nothing
   modifyIORef bindingTable (((key, event), action) :)

execAction :: BindingTable -> Key -> KeyEvent -> Modifiers -> WindowPosition -> IO ()
execAction bindingTable key event m p = do
   tab <- readIORef bindingTable
   case lookup (key, event) tab of
      Just cb -> cb m p
      Nothing -> return ()

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

type StillDownHandler = IO ()

-- ToDo: Pass a more sensible Modifiers and WindowPosition, probably with
-- the help of passiveMotionFunc
stillDown :: BindingTable -> KeyTable -> StillDownHandler
stillDown bindingTable pressedKeys =
   getKeys pressedKeys >>= mapM_ (\k -> execAction bindingTable k StillDown (Modifiers Up Up Up) (WindowPosition 0 0))

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

initUserInput :: IO (KeyBinder, StillDownHandler)
initUserInput = do
   -- Using "setGlobalKeyRepeat GlobalKeyRepeatOff" would be a little bit
   --more efficient, but has two disadvantages: It is not yet implemented
   -- for M$ and it changes the global state of X11.
   setPerWindowKeyRepeat PerWindowKeyRepeatOff

   bindingTable <- newBindingTable
   pressedKeys  <- newKeyTable
   setKeyboardMouseCallback (Just (\k state m p -> case state of
      Down -> do insertIntoKeyTable pressedKeys k
                 execAction bindingTable k Press m p
      Up   -> do deleteFromKeyTable pressedKeys k
                 execAction bindingTable k Release m p))

   return (bindKey bindingTable, stillDown bindingTable pressedKeys)
