{-# OPTIONS_GHC -fno-cse #-}

{-# OPTIONS_HADDOCK hide #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.GLUT.Callbacks.Registration
-- Copyright   :  (c) Sven Panne 2002-2018
-- License     :  BSD3
--
-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
-- 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 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

--------------------------------------------------------------------------------
-- 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
   -- freeglut-only callback types
   | CloseCB           | MouseWheelCB      | PositionCB
   | MultiEntryCB      | MultiMotionCB     | MultiButtonCB
   | MultiPassiveCB    | InitContextCB     | AppStatusCB
   deriving ( CallbackType -> CallbackType -> Bool
(CallbackType -> CallbackType -> Bool)
-> (CallbackType -> CallbackType -> Bool) -> Eq CallbackType
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
Eq CallbackType
-> (CallbackType -> CallbackType -> Ordering)
-> (CallbackType -> CallbackType -> Bool)
-> (CallbackType -> CallbackType -> Bool)
-> (CallbackType -> CallbackType -> Bool)
-> (CallbackType -> CallbackType -> Bool)
-> (CallbackType -> CallbackType -> CallbackType)
-> (CallbackType -> CallbackType -> CallbackType)
-> Ord 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
$cp1Ord :: Eq CallbackType
Ord )

isGlobal :: CallbackType -> Bool
isGlobal :: CallbackType -> Bool
isGlobal CallbackType
MenuStatusCB = Bool
True
isGlobal CallbackType
IdleCB       = Bool
True
isGlobal CallbackType
_            = Bool
False

--------------------------------------------------------------------------------
-- To uniquely identify a particular callback, the associated window is needed
-- for window callbacks.

data CallbackID = CallbackID (Maybe Window) CallbackType
   deriving ( CallbackID -> CallbackID -> Bool
(CallbackID -> CallbackID -> Bool)
-> (CallbackID -> CallbackID -> Bool) -> Eq CallbackID
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
Eq CallbackID
-> (CallbackID -> CallbackID -> Ordering)
-> (CallbackID -> CallbackID -> Bool)
-> (CallbackID -> CallbackID -> Bool)
-> (CallbackID -> CallbackID -> Bool)
-> (CallbackID -> CallbackID -> Bool)
-> (CallbackID -> CallbackID -> CallbackID)
-> (CallbackID -> CallbackID -> CallbackID)
-> Ord 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
$cp1Ord :: Eq CallbackID
Ord )

getCallbackID :: CallbackType -> IO CallbackID
getCallbackID :: CallbackType -> IO CallbackID
getCallbackID CallbackType
callbackType = do
   Maybe Window
maybeWindow <- if CallbackType -> Bool
isGlobal CallbackType
callbackType
                     then Maybe Window -> IO (Maybe Window)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Window
forall a. Maybe a
Nothing
                     else (Window -> Maybe Window) -> IO Window -> IO (Maybe Window)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Window -> Maybe Window
forall a. a -> Maybe a
Just (IO Window -> IO (Maybe Window)) -> IO Window -> IO (Maybe Window)
forall a b. (a -> b) -> a -> b
$ String -> IO Window
getCurrentWindow String
"getCallbackID"
   CallbackID -> IO CallbackID
forall (m :: * -> *) a. Monad m => a -> m a
return (CallbackID -> IO CallbackID) -> CallbackID -> IO CallbackID
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 <- StateVar (Maybe Window) -> IO (Maybe Window)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar (Maybe Window)
currentWindow
   IO Window -> (Window -> IO Window) -> Maybe Window -> IO Window
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO Window
forall a. HasCallStack => String -> a
error (String
func String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": no current window")) Window -> IO Window
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Window
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 :: IORef (CallbackTable a)
theCallbackTable = IO (IORef (CallbackTable a)) -> IORef (CallbackTable a)
forall a. IO a -> a
unsafePerformIO (CallbackTable a -> IO (IORef (CallbackTable a))
forall a. a -> IO (IORef a)
newIORef CallbackTable a
forall a. CallbackTable a
emptyCallbackTable)

getCallbackTable :: IO (CallbackTable a)
getCallbackTable :: IO (CallbackTable a)
getCallbackTable = IORef (CallbackTable a) -> IO (CallbackTable a)
forall a. IORef a -> IO a
readIORef IORef (CallbackTable a)
forall a. IORef (CallbackTable a)
theCallbackTable

modifyCallbackTable :: (CallbackTable a -> CallbackTable a) -> IO ()
modifyCallbackTable :: (CallbackTable a -> CallbackTable a) -> IO ()
modifyCallbackTable = IORef (CallbackTable a)
-> (CallbackTable a -> CallbackTable a) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (CallbackTable a)
forall a. IORef (CallbackTable a)
theCallbackTable

--------------------------------------------------------------------------------

type CallbackTable a = M.Map CallbackID (FunPtr a)

emptyCallbackTable :: CallbackTable a
emptyCallbackTable :: CallbackTable a
emptyCallbackTable = CallbackTable a
forall k a. Map k a
M.empty

lookupInCallbackTable :: CallbackID -> IO (Maybe (FunPtr a))
lookupInCallbackTable :: CallbackID -> IO (Maybe (FunPtr a))
lookupInCallbackTable CallbackID
callbackID =
   (Map CallbackID (FunPtr a) -> Maybe (FunPtr a))
-> IO (Map CallbackID (FunPtr a)) -> IO (Maybe (FunPtr a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CallbackID -> Map CallbackID (FunPtr a) -> Maybe (FunPtr a)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup CallbackID
callbackID) IO (Map CallbackID (FunPtr a))
forall a. IO (CallbackTable a)
getCallbackTable

deleteFromCallbackTable :: CallbackID -> IO ()
deleteFromCallbackTable :: CallbackID -> IO ()
deleteFromCallbackTable CallbackID
callbackID =
   (CallbackTable Any -> CallbackTable Any) -> IO ()
forall a. (CallbackTable a -> CallbackTable a) -> IO ()
modifyCallbackTable (CallbackID -> CallbackTable Any -> CallbackTable Any
forall k a. Ord k => k -> Map k a -> Map k a
M.delete CallbackID
callbackID)

addToCallbackTable :: CallbackID -> FunPtr a -> IO ()
addToCallbackTable :: CallbackID -> FunPtr a -> IO ()
addToCallbackTable CallbackID
callbackID FunPtr a
funPtr =
   (CallbackTable a -> CallbackTable a) -> IO ()
forall a. (CallbackTable a -> CallbackTable a) -> IO ()
modifyCallbackTable (CallbackID -> FunPtr a -> CallbackTable a -> CallbackTable a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert CallbackID
callbackID FunPtr a
funPtr)

--------------------------------------------------------------------------------
-- Another global mutable variable: The list of function pointers ready to be
-- freed by freeHaskellFunPtr

{-# NOINLINE theCleanupList #-}
theCleanupList :: IORef [FunPtr a]
theCleanupList :: IORef [FunPtr a]
theCleanupList = IO (IORef [FunPtr a]) -> IORef [FunPtr a]
forall a. IO a -> a
unsafePerformIO ([FunPtr a] -> IO (IORef [FunPtr a])
forall a. a -> IO (IORef a)
newIORef [])

getCleanupList :: IO [FunPtr a]
getCleanupList :: IO [FunPtr a]
getCleanupList = IORef [FunPtr a] -> IO [FunPtr a]
forall a. IORef a -> IO a
readIORef IORef [FunPtr a]
forall a. IORef [FunPtr a]
theCleanupList

setCleanupList :: [FunPtr a] -> IO ()
setCleanupList :: [FunPtr a] -> IO ()
setCleanupList = IORef [FunPtr a] -> [FunPtr a] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [FunPtr a]
forall a. IORef [FunPtr a]
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 TimerFunc)
theScavenger :: IORef (FunPtr TimerFunc)
theScavenger = IO (IORef (FunPtr TimerFunc)) -> IORef (FunPtr TimerFunc)
forall a. IO a -> a
unsafePerformIO (FunPtr TimerFunc -> IO (IORef (FunPtr TimerFunc))
forall a. a -> IO (IORef a)
newIORef (FunPtr TimerFunc -> IO (IORef (FunPtr TimerFunc)))
-> IO (FunPtr TimerFunc) -> IO (IORef (FunPtr TimerFunc))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TimerFunc -> IO (FunPtr TimerFunc)
makeTimerFunc (\CInt
_ -> do
   [FunPtr Any]
cleanupList <- IO [FunPtr Any]
forall a. IO [FunPtr a]
getCleanupList
   (FunPtr Any -> IO ()) -> [FunPtr Any] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FunPtr Any -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr [FunPtr Any]
cleanupList
   [FunPtr Any] -> IO ()
forall a. [FunPtr a] -> IO ()
setCleanupList []))

getScavenger :: IO (FunPtr TimerFunc)
getScavenger :: IO (FunPtr TimerFunc)
getScavenger = IORef (FunPtr TimerFunc) -> IO (FunPtr TimerFunc)
forall a. IORef a -> IO a
readIORef IORef (FunPtr TimerFunc)
theScavenger

--------------------------------------------------------------------------------
-- 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 a -> IO ()
registerForCleanup FunPtr a
funPtr = do
   [FunPtr a]
oldCleanupList <- IO [FunPtr a]
forall a. IO [FunPtr a]
getCleanupList
   [FunPtr a] -> IO ()
forall a. [FunPtr a] -> IO ()
setCleanupList (FunPtr a
funPtr FunPtr a -> [FunPtr a] -> [FunPtr a]
forall a. a -> [a] -> [a]
: [FunPtr a]
oldCleanupList)
   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([FunPtr a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FunPtr a]
oldCleanupList) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        FunPtr TimerFunc
scavenger <- IO (FunPtr TimerFunc)
getScavenger
        CUInt -> FunPtr TimerFunc -> TimerFunc
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 :: 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 <- CallbackID -> IO (Maybe (FunPtr Any))
forall a. CallbackID -> IO (Maybe (FunPtr a))
lookupInCallbackTable CallbackID
callbackID
   case Maybe (FunPtr Any)
maybeOldFunPtr of
      Maybe (FunPtr Any)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just FunPtr Any
oldFunPtr -> do FunPtr Any -> IO ()
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 FunPtr a
forall a. FunPtr a
nullFunPtr
      Just b
callback -> do FunPtr a
newFunPtr <- b -> IO (FunPtr a)
makeCallback b
callback
                          CallbackID -> FunPtr a -> IO ()
forall a. CallbackID -> FunPtr a -> IO ()
addToCallbackTable CallbackID
callbackID FunPtr a
newFunPtr
                          FunPtr a -> IO ()
registerAtGLUT FunPtr a
newFunPtr