{-# 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
| | IdleCB
| CloseCB | MouseWheelCB | PositionCB
| MultiEntryCB | MultiMotionCB | MultiButtonCB
| MultiPassiveCB | InitContextCB | AppStatusCB
deriving ( CallbackType -> CallbackType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CallbackType -> CallbackType -> Bool
$c/= :: CallbackType -> CallbackType -> Bool
== :: CallbackType -> CallbackType -> Bool
$c== :: CallbackType -> CallbackType -> Bool
Eq, Eq CallbackType
CallbackType -> CallbackType -> Bool
CallbackType -> CallbackType -> Ordering
CallbackType -> CallbackType -> CallbackType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CallbackType -> CallbackType -> CallbackType
$cmin :: CallbackType -> CallbackType -> CallbackType
max :: CallbackType -> CallbackType -> CallbackType
$cmax :: CallbackType -> CallbackType -> CallbackType
>= :: CallbackType -> CallbackType -> Bool
$c>= :: CallbackType -> CallbackType -> Bool
> :: CallbackType -> CallbackType -> Bool
$c> :: CallbackType -> CallbackType -> Bool
<= :: CallbackType -> CallbackType -> Bool
$c<= :: CallbackType -> CallbackType -> Bool
< :: CallbackType -> CallbackType -> Bool
$c< :: CallbackType -> CallbackType -> Bool
compare :: CallbackType -> CallbackType -> Ordering
$ccompare :: CallbackType -> CallbackType -> Ordering
Ord )
isGlobal :: CallbackType -> Bool
isGlobal :: CallbackType -> Bool
isGlobal CallbackType
MenuStatusCB = Bool
True
isGlobal CallbackType
IdleCB = Bool
True
isGlobal CallbackType
_ = Bool
False
data CallbackID = CallbackID (Maybe Window) CallbackType
deriving ( CallbackID -> CallbackID -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CallbackID -> CallbackID -> Bool
$c/= :: CallbackID -> CallbackID -> Bool
== :: CallbackID -> CallbackID -> Bool
$c== :: CallbackID -> CallbackID -> Bool
Eq, Eq CallbackID
CallbackID -> CallbackID -> Bool
CallbackID -> CallbackID -> Ordering
CallbackID -> CallbackID -> CallbackID
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CallbackID -> CallbackID -> CallbackID
$cmin :: CallbackID -> CallbackID -> CallbackID
max :: CallbackID -> CallbackID -> CallbackID
$cmax :: CallbackID -> CallbackID -> CallbackID
>= :: CallbackID -> CallbackID -> Bool
$c>= :: CallbackID -> CallbackID -> Bool
> :: CallbackID -> CallbackID -> Bool
$c> :: CallbackID -> CallbackID -> Bool
<= :: CallbackID -> CallbackID -> Bool
$c<= :: CallbackID -> CallbackID -> Bool
< :: CallbackID -> CallbackID -> Bool
$c< :: CallbackID -> CallbackID -> Bool
compare :: CallbackID -> CallbackID -> Ordering
$ccompare :: CallbackID -> CallbackID -> Ordering
Ord )
getCallbackID :: CallbackType -> IO CallbackID
getCallbackID :: CallbackType -> IO CallbackID
getCallbackID CallbackType
callbackType = do
Maybe Window
maybeWindow <- if CallbackType -> Bool
isGlobal CallbackType
callbackType
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> IO Window
getCurrentWindow String
"getCallbackID"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Window -> CallbackType -> CallbackID
CallbackID Maybe Window
maybeWindow CallbackType
callbackType
getCurrentWindow :: String -> IO Window
getCurrentWindow :: String -> IO Window
getCurrentWindow String
func = do
Maybe Window
win <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar (Maybe Window)
currentWindow
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error (String
func forall a. [a] -> [a] -> [a]
++ String
": no current window")) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Window
win
{-# NOINLINE theCallbackTable #-}
theCallbackTable :: IORef (CallbackTable a)
theCallbackTable :: forall a. IORef (CallbackTable a)
theCallbackTable = forall a. IO a -> a
unsafePerformIO (forall a. a -> IO (IORef a)
newIORef forall a. CallbackTable a
emptyCallbackTable)
getCallbackTable :: IO (CallbackTable a)
getCallbackTable :: forall a. IO (CallbackTable a)
getCallbackTable = forall a. IORef a -> IO a
readIORef forall a. IORef (CallbackTable a)
theCallbackTable
modifyCallbackTable :: (CallbackTable a -> CallbackTable a) -> IO ()
modifyCallbackTable :: forall a. (CallbackTable a -> CallbackTable a) -> IO ()
modifyCallbackTable = forall a. IORef a -> (a -> a) -> IO ()
modifyIORef forall a. IORef (CallbackTable a)
theCallbackTable
type CallbackTable a = M.Map CallbackID (FunPtr a)
emptyCallbackTable :: CallbackTable a
emptyCallbackTable :: forall a. CallbackTable a
emptyCallbackTable = forall k a. Map k a
M.empty
lookupInCallbackTable :: CallbackID -> IO (Maybe (FunPtr a))
lookupInCallbackTable :: forall a. CallbackID -> IO (Maybe (FunPtr a))
lookupInCallbackTable CallbackID
callbackID =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup CallbackID
callbackID) forall a. IO (CallbackTable a)
getCallbackTable
deleteFromCallbackTable :: CallbackID -> IO ()
deleteFromCallbackTable :: CallbackID -> IO ()
deleteFromCallbackTable CallbackID
callbackID =
forall a. (CallbackTable a -> CallbackTable a) -> IO ()
modifyCallbackTable (forall k a. Ord k => k -> Map k a -> Map k a
M.delete CallbackID
callbackID)
addToCallbackTable :: CallbackID -> FunPtr a -> IO ()
addToCallbackTable :: forall a. CallbackID -> FunPtr a -> IO ()
addToCallbackTable CallbackID
callbackID FunPtr a
funPtr =
forall a. (CallbackTable a -> CallbackTable a) -> IO ()
modifyCallbackTable (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert CallbackID
callbackID FunPtr a
funPtr)
{-# NOINLINE theCleanupList #-}
theCleanupList :: IORef [FunPtr a]
theCleanupList :: forall a. IORef [FunPtr a]
theCleanupList = forall a. IO a -> a
unsafePerformIO (forall a. a -> IO (IORef a)
newIORef [])
getCleanupList :: IO [FunPtr a]
getCleanupList :: forall a. IO [FunPtr a]
getCleanupList = forall a. IORef a -> IO a
readIORef forall a. IORef [FunPtr a]
theCleanupList
setCleanupList :: [FunPtr a] -> IO ()
setCleanupList :: forall a. [FunPtr a] -> IO ()
setCleanupList = forall a. IORef a -> a -> IO ()
writeIORef forall a. IORef [FunPtr a]
theCleanupList
{-# NOINLINE theScavenger #-}
theScavenger :: IORef (FunPtr TimerFunc)
theScavenger :: IORef (FunPtr TimerFunc)
theScavenger = forall a. IO a -> a
unsafePerformIO (forall a. a -> IO (IORef a)
newIORef forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TimerFunc -> IO (FunPtr TimerFunc)
makeTimerFunc (\CInt
_ -> do
[FunPtr Any]
cleanupList <- forall a. IO [FunPtr a]
getCleanupList
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. FunPtr a -> IO ()
freeHaskellFunPtr [FunPtr Any]
cleanupList
forall a. [FunPtr a] -> IO ()
setCleanupList []))
getScavenger :: IO (FunPtr TimerFunc)
getScavenger :: IO (FunPtr TimerFunc)
getScavenger = forall a. IORef a -> IO a
readIORef IORef (FunPtr TimerFunc)
theScavenger
registerForCleanup :: FunPtr a -> IO ()
registerForCleanup :: forall a. FunPtr a -> IO ()
registerForCleanup FunPtr a
funPtr = do
[FunPtr a]
oldCleanupList <- forall a. IO [FunPtr a]
getCleanupList
forall a. [FunPtr a] -> IO ()
setCleanupList (FunPtr a
funPtr forall a. a -> [a] -> [a]
: [FunPtr a]
oldCleanupList)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FunPtr a]
oldCleanupList) forall a b. (a -> b) -> a -> b
$ do
FunPtr TimerFunc
scavenger <- IO (FunPtr TimerFunc)
getScavenger
forall (m :: * -> *).
MonadIO m =>
CUInt -> FunPtr TimerFunc -> CInt -> m ()
glutTimerFunc CUInt
0 FunPtr TimerFunc
scavenger CInt
0
setCallback :: CallbackType -> (FunPtr a -> IO ()) -> (b -> IO (FunPtr a))
-> Maybe b -> IO ()
setCallback :: forall a b.
CallbackType
-> (FunPtr a -> IO ()) -> (b -> IO (FunPtr a)) -> Maybe b -> IO ()
setCallback CallbackType
callbackType FunPtr a -> IO ()
registerAtGLUT b -> IO (FunPtr a)
makeCallback Maybe b
maybeCallback = do
CallbackID
callbackID <- CallbackType -> IO CallbackID
getCallbackID CallbackType
callbackType
Maybe (FunPtr Any)
maybeOldFunPtr <- forall a. CallbackID -> IO (Maybe (FunPtr a))
lookupInCallbackTable CallbackID
callbackID
case Maybe (FunPtr Any)
maybeOldFunPtr of
Maybe (FunPtr Any)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just FunPtr Any
oldFunPtr -> do forall a. FunPtr a -> IO ()
registerForCleanup FunPtr Any
oldFunPtr
CallbackID -> IO ()
deleteFromCallbackTable CallbackID
callbackID
case Maybe b
maybeCallback of
Maybe b
Nothing -> FunPtr a -> IO ()
registerAtGLUT forall a. FunPtr a
nullFunPtr
Just b
callback -> do FunPtr a
newFunPtr <- b -> IO (FunPtr a)
makeCallback b
callback
forall a. CallbackID -> FunPtr a -> IO ()
addToCallbackTable CallbackID
callbackID FunPtr a
newFunPtr
FunPtr a -> IO ()
registerAtGLUT FunPtr a
newFunPtr