{-# OPTIONS_GHC -fno-cse #-}
{-# OPTIONS_HADDOCK hide #-}
module Graphics.UI.GLUT.Callbacks.Registration (
CallbackType(..), registerForCleanup, setCallback, getCurrentWindow
) where
import Control.Monad ( when )
import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef )
import qualified Data.Map as M
import Data.StateVar ( get )
import Foreign.Ptr ( FunPtr, nullFunPtr, freeHaskellFunPtr )
import System.IO.Unsafe ( unsafePerformIO )
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 | PositionCB
| MultiEntryCB | MultiMotionCB | MultiButtonCB
| MultiPassiveCB | InitContextCB | AppStatusCB
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
{-# NOINLINE theCallbackTable #-}
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 = M.Map CallbackID (FunPtr a)
emptyCallbackTable :: CallbackTable a
emptyCallbackTable = M.empty
lookupInCallbackTable :: CallbackID -> IO (Maybe (FunPtr a))
lookupInCallbackTable callbackID =
fmap (M.lookup callbackID) getCallbackTable
deleteFromCallbackTable :: CallbackID -> IO ()
deleteFromCallbackTable callbackID =
modifyCallbackTable (M.delete callbackID)
addToCallbackTable :: CallbackID -> FunPtr a -> IO ()
addToCallbackTable callbackID funPtr =
modifyCallbackTable (M.insert callbackID funPtr)
{-# NOINLINE theCleanupList #-}
theCleanupList :: IORef [FunPtr a]
theCleanupList = unsafePerformIO (newIORef [])
getCleanupList :: IO [FunPtr a]
getCleanupList = readIORef theCleanupList
setCleanupList :: [FunPtr a] -> IO ()
setCleanupList = writeIORef theCleanupList
{-# NOINLINE theScavenger #-}
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