    {-# 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
    $c== :: CallbackType -> CallbackType -> Bool
    == :: CallbackType -> CallbackType -> Bool
    $c/= :: CallbackType -> CallbackType -> Bool
    /= :: 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
    $ccompare :: CallbackType -> CallbackType -> Ordering
    compare :: CallbackType -> CallbackType -> Ordering
    $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
    >= :: CallbackType -> CallbackType -> Bool
    $cmax :: CallbackType -> CallbackType -> CallbackType
    max :: CallbackType -> CallbackType -> CallbackType
    $cmin :: CallbackType -> CallbackType -> CallbackType
    min :: CallbackType -> CallbackType -> 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
    $c== :: CallbackID -> CallbackID -> Bool
    == :: CallbackID -> CallbackID -> Bool
    $c/= :: CallbackID -> CallbackID -> Bool
    /= :: 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
    $ccompare :: CallbackID -> CallbackID -> Ordering
    compare :: CallbackID -> CallbackID -> Ordering
    $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
    >= :: CallbackID -> CallbackID -> Bool
    $cmax :: CallbackID -> CallbackID -> CallbackID
    max :: CallbackID -> CallbackID -> CallbackID
    $cmin :: CallbackID -> CallbackID -> CallbackID
    min :: CallbackID -> CallbackID -> CallbackID
    Ord )

    getCallbackID :: CallbackType -> IO CallbackID
    getCallbackID :: CallbackType -> IO CallbackID
    getCallbackID CallbackType
    callbackType = do
       maybeWindow <- if CallbackType -> Bool
    isGlobal CallbackType
    callbackType
                         then Maybe Window -> IO (Maybe Window)
    forall a. a -> IO a
    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 a b. (a -> b) -> IO a -> IO b
    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"
       return $ CallbackID maybeWindow callbackType

    getCurrentWindow :: String -> IO Window
    getCurrentWindow :: String -> IO Window
    getCurrentWindow String
    func = do
       win <- StateVar (Maybe Window) -> IO (Maybe Window)
    forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
    forall (m :: * -> *).
    MonadIO m =>
    StateVar (Maybe Window) -> m (Maybe Window)
    get StateVar (Maybe Window)
    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 :: forall a. 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 :: forall a. 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 :: forall a. (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 :: forall a. CallbackTable a
    emptyCallbackTable = Map CallbackID (FunPtr a)
    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 =
       (Map CallbackID (FunPtr a) -> Maybe (FunPtr a))
    -> IO (Map CallbackID (FunPtr a)) -> IO (Maybe (FunPtr a))
    forall a b. (a -> b) -> IO a -> IO b
    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 (ZonkAny 2) -> CallbackTable (ZonkAny 2)) -> IO ()
    forall a. (CallbackTable a -> CallbackTable a) -> IO ()
    modifyCallbackTable (CallbackID
    -> CallbackTable (ZonkAny 2) -> CallbackTable (ZonkAny 2)
    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 =
       (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 :: forall a. 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 :: forall a. 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 :: forall a. [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
       cleanupList <- IO [FunPtr (ZonkAny 0)]
    forall a. IO [FunPtr a]
    getCleanupList
       mapM_ freeHaskellFunPtr cleanupList
       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 :: forall a. FunPtr a -> IO ()
    registerForCleanup FunPtr a
    funPtr = do
       oldCleanupList <- IO [FunPtr a]
    forall a. IO [FunPtr a]
    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 :: 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 <- CallbackType -> IO CallbackID
    getCallbackID CallbackType
    callbackType
       maybeOldFunPtr <- lookupInCallbackTable callbackID
       case maybeOldFunPtr of
          Maybe (FunPtr (ZonkAny 3))
    Nothing -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          Just FunPtr (ZonkAny 3)
    oldFunPtr -> do FunPtr (ZonkAny 3) -> IO ()
    forall a. FunPtr a -> IO ()
    registerForCleanup FunPtr (ZonkAny 3)
    oldFunPtr
                               CallbackID -> IO ()
    deleteFromCallbackTable CallbackID
    callbackID
       case maybeCallback of
          Maybe b
    Nothing -> FunPtr a -> IO ()
    registerAtGLUT FunPtr a
    forall a. FunPtr a
    nullFunPtr
          Just b
    callback -> do newFunPtr <- b -> IO (FunPtr a)
    makeCallback b
    callback
                              addToCallbackTable callbackID newFunPtr
                              registerAtGLUT newFunPtr