module Graphics.UI.Fungen.UserInput (
Key(..), 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 KeyBinder = Key -> KeyEvent -> Maybe (IO ()) -> IO ()
type BindingTable = IORef [((Key,KeyEvent), IO ())]
newBindingTable :: IO BindingTable
newBindingTable = newIORef []
bindKey :: BindingTable -> KeyBinder
bindKey bindingTable key event Nothing =
modifyIORef bindingTable (\t -> [ e | e@(b,a) <- 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 -> IO ()
execAction bindingTable key event =
readIORef bindingTable >>= (maybe (return ()) id . lookup (key, event))
type StillDownHandler = IO ()
stillDown :: BindingTable -> KeyTable -> StillDownHandler
stillDown bindingTable pressedKeys =
getKeys pressedKeys >>= mapM_ (\k -> execAction bindingTable k StillDown)
initUserInput :: IO (KeyBinder, StillDownHandler)
initUserInput = do
globalKeyRepeat $= GlobalKeyRepeatOff
bindingTable <- newBindingTable
pressedKeys <- newKeyTable
let keyPress k = do insertIntoKeyTable pressedKeys k
execAction bindingTable k Press
keyRelease k = do deleteFromKeyTable pressedKeys k
execAction bindingTable k Release
keyboardMouse k Down _ _ = keyPress k
keyboardMouse k Up _ _ = keyRelease k
keyboardMouseCallback $= Just keyboardMouse
return (bindKey bindingTable, stillDown bindingTable pressedKeys)