{-# 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
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

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

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

--------------------------------------------------------------------------------
-- 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 :: 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)

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

{-# 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

--------------------------------------------------------------------------------
-- 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 = 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

--------------------------------------------------------------------------------
-- 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 :: 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