1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
{-# OPTIONS_GHC -fno-cse #-}
-- #hide
--------------------------------------------------------------------------------
-- |
-- Module : Graphics.UI.GLUT.Callbacks.Registration
-- Copyright : (c) Sven Panne 2002-2005
-- License : BSD-style (see the file libraries/GLUT/LICENSE)
--
-- Maintainer : sven.panne@aedion.de
-- Stability : stable
-- Portability : portable
--
--------------------------------------------------------------------------------
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 Map ( empty, lookup, insert, delete )
import Data.Map ( Map )
import Foreign.C.Types ( CInt, CUInt )
import Foreign.Ptr ( FunPtr, nullFunPtr, freeHaskellFunPtr )
import System.IO.Unsafe ( unsafePerformIO )
import Graphics.Rendering.OpenGL.GL.StateVar ( HasGetter(get) )
import Graphics.UI.GLUT.Window ( Window, currentWindow )
--------------------------------------------------------------------------------
-- No timer callback here, because they are one-shot and "self destroy"
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 -- freeglut only
deriving ( Eq, Ord )
isGlobal :: CallbackType -> Bool
isGlobal MenuStatusCB = True
isGlobal IdleCB = True
isGlobal _ = False
--------------------------------------------------------------------------------
-- To uniquely identify a particular callback, the associated window is needed
-- for window callbacks.
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
--------------------------------------------------------------------------------
-- This seems to be a common Haskell hack nowadays: A plain old global variable
-- with an associated mutator. Perhaps some language/library support is needed?
{-# 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 = 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)
--------------------------------------------------------------------------------
-- Another global mutable variable: The list of function pointers ready to be
-- freed by freeHaskellFunPtr
{-# NOINLINE theCleanupList #-}
theCleanupList :: IORef [FunPtr a]
theCleanupList = unsafePerformIO (newIORef [])
getCleanupList :: IO [FunPtr a]
getCleanupList = readIORef theCleanupList
setCleanupList :: [FunPtr a] -> IO ()
setCleanupList = writeIORef theCleanupList
--------------------------------------------------------------------------------
-- And yet another mutable (write-once) variable: A function pointer to a
-- callback which frees all function pointers on the cleanup list.
{-# NOINLINE theScavenger #-}
theScavenger :: IORef (FunPtr TimerCallback)
theScavenger = unsafePerformIO (newIORef =<< makeTimerCallback (\_ -> do
cleanupList <- getCleanupList
mapM_ freeHaskellFunPtr cleanupList
setCleanupList []))
getScavenger :: IO (FunPtr TimerCallback)
getScavenger = readIORef theScavenger
-- More or less copied from Global.hs to avoid mutual dependencies
type TimerCallback = CInt -> IO ()
foreign import ccall "wrapper" makeTimerCallback ::
TimerCallback -> IO (FunPtr TimerCallback)
foreign import CALLCONV unsafe "glutTimerFunc" glutTimerFunc ::
CUInt -> FunPtr TimerCallback -> CInt -> IO ()
--------------------------------------------------------------------------------
-- Here is the really cunning stuff: If an element is added to the cleanup list
-- when it is empty, register an immediate callback at GLUT to free the list as
-- soon as possible.
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
|
