module Graphics.UI.GLUT.Callbacks.Registration (
CallbackType(..), registerForCleanup, setCallback, getCurrentWindow
) where
import Control.Monad
import Data.IORef
import qualified Data.Map as Map ( empty, lookup, insert, delete )
import Data.Map ( Map )
import Foreign.Ptr
import Graphics.Rendering.OpenGL ( get )
import Graphics.UI.GLUT.Raw
import Graphics.UI.GLUT.Window
data CallbackType
= DisplayCB | OverlayDisplayCB | ReshapeCB
| KeyboardCB | KeyboardUpCB | MouseCB
| MotionCB | PassiveMotionCB | CrossingCB
| VisibilityCB | WindowStatusCB | SpecialCB
| SpecialUpCB | SpaceballMotionCB | SpaceballRotateCB
| SpaceballButtonCB | ButtonBoxCB | DialsCB
| TabletMotionCB | TabletButtonCB | JoystickCB
| MenuStatusCB | IdleCB
| CloseCB
| MouseWheelCB
deriving ( Eq, Ord )
isGlobal :: CallbackType -> Bool
isGlobal MenuStatusCB = True
isGlobal IdleCB = True
isGlobal _ = False
data CallbackID = CallbackID (Maybe Window) CallbackType
deriving ( Eq, Ord )
getCallbackID :: CallbackType -> IO CallbackID
getCallbackID callbackType = do
maybeWindow <- if isGlobal callbackType
then return Nothing
else fmap Just $ getCurrentWindow "getCallbackID"
return $ CallbackID maybeWindow callbackType
getCurrentWindow :: String -> IO Window
getCurrentWindow func = do
win <- get currentWindow
maybe (error (func ++ ": no current window")) return win
theCallbackTable :: IORef (CallbackTable a)
theCallbackTable = unsafePerformIO (newIORef emptyCallbackTable)
getCallbackTable :: IO (CallbackTable a)
getCallbackTable = readIORef theCallbackTable
modifyCallbackTable :: (CallbackTable a -> CallbackTable a) -> IO ()
modifyCallbackTable = modifyIORef theCallbackTable
type CallbackTable a = Map CallbackID (FunPtr a)
emptyCallbackTable :: CallbackTable a
emptyCallbackTable = Map.empty
lookupInCallbackTable :: CallbackID -> IO (Maybe (FunPtr a))
lookupInCallbackTable callbackID =
fmap (Map.lookup callbackID) getCallbackTable
deleteFromCallbackTable :: CallbackID -> IO ()
deleteFromCallbackTable callbackID =
modifyCallbackTable (Map.delete callbackID)
addToCallbackTable :: CallbackID -> FunPtr a -> IO ()
addToCallbackTable callbackID funPtr =
modifyCallbackTable (Map.insert callbackID funPtr)
theCleanupList :: IORef [FunPtr a]
theCleanupList = unsafePerformIO (newIORef [])
getCleanupList :: IO [FunPtr a]
getCleanupList = readIORef theCleanupList
setCleanupList :: [FunPtr a] -> IO ()
setCleanupList = writeIORef theCleanupList
theScavenger :: IORef (FunPtr TimerFunc)
theScavenger = unsafePerformIO (newIORef =<< makeTimerFunc (\_ -> do
cleanupList <- getCleanupList
mapM_ freeHaskellFunPtr cleanupList
setCleanupList []))
getScavenger :: IO (FunPtr TimerFunc)
getScavenger = readIORef theScavenger
registerForCleanup :: FunPtr a -> IO ()
registerForCleanup funPtr = do
oldCleanupList <- getCleanupList
setCleanupList (funPtr : oldCleanupList)
when (null oldCleanupList) $ do
scavenger <- getScavenger
glutTimerFunc 0 scavenger 0
setCallback :: CallbackType -> (FunPtr a -> IO ()) -> (b -> IO (FunPtr a))
-> Maybe b -> IO ()
setCallback callbackType registerAtGLUT makeCallback maybeCallback = do
callbackID <- getCallbackID callbackType
maybeOldFunPtr <- lookupInCallbackTable callbackID
case maybeOldFunPtr of
Nothing -> return ()
Just oldFunPtr -> do registerForCleanup oldFunPtr
deleteFromCallbackTable callbackID
case maybeCallback of
Nothing -> registerAtGLUT nullFunPtr
Just callback -> do newFunPtr <- makeCallback callback
addToCallbackTable callbackID newFunPtr
registerAtGLUT newFunPtr