{-# OPTIONS_HADDOCK hide #-}
module Graphics.Gloss.Internals.Interface.Backend.GLUT
        (GLUTState,glutStateInit,initializeGLUT)
where

import Data.IORef
import Control.Monad
import Control.Concurrent
import Graphics.UI.GLUT                           (get,($=))
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLUT               as GLUT
import qualified System.Exit                    as System
import Graphics.Gloss.Internals.Interface.Backend.Types
import System.IO.Unsafe

-- Were we to support freeglut only, we could use GLUT.get to discover
-- whether we are initialized or not. If not, we do a quick initialize,
-- get the screenzie, and then do GLUT.exit. This avoids the use of
-- global variables. Unfortunately, there is no failsafe way to check
-- whether glut is initialized in some older versions of glut, which is
-- what we'd use instead of the global variable to get the required info.
glutInitialized :: IORef Bool
{-# NOINLINE glutInitialized #-}
glutInitialized :: IORef Bool
glutInitialized = IO (IORef Bool) -> IORef Bool
forall a. IO a -> a
unsafePerformIO (IO (IORef Bool) -> IORef Bool) -> IO (IORef Bool) -> IORef Bool
forall a b. (a -> b) -> a -> b
$ do Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False

-- | State information for the GLUT backend.
data GLUTState
        = GLUTState
        { -- Count of total number of frames that we have drawn.
          GLUTState -> Int
glutStateFrameCount   :: !Int

          -- Bool to remember if we've set the timeout callback.
        , GLUTState -> Bool
glutStateHasTimeout   :: Bool

          -- Bool to remember if we've set the idle callback.
        , GLUTState -> Bool
glutStateHasIdle      :: Bool }
        deriving Int -> GLUTState -> ShowS
[GLUTState] -> ShowS
GLUTState -> String
(Int -> GLUTState -> ShowS)
-> (GLUTState -> String)
-> ([GLUTState] -> ShowS)
-> Show GLUTState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GLUTState] -> ShowS
$cshowList :: [GLUTState] -> ShowS
show :: GLUTState -> String
$cshow :: GLUTState -> String
showsPrec :: Int -> GLUTState -> ShowS
$cshowsPrec :: Int -> GLUTState -> ShowS
Show


-- | Initial GLUT state.
glutStateInit :: GLUTState
glutStateInit :: GLUTState
glutStateInit
        = GLUTState :: Int -> Bool -> Bool -> GLUTState
GLUTState
        { glutStateFrameCount :: Int
glutStateFrameCount   = Int
0
        , glutStateHasTimeout :: Bool
glutStateHasTimeout   = Bool
False
        , glutStateHasIdle :: Bool
glutStateHasIdle      = Bool
False }


instance Backend GLUTState where
        initBackendState :: GLUTState
initBackendState           = GLUTState
glutStateInit
        initializeBackend :: IORef GLUTState -> Bool -> IO ()
initializeBackend          = IORef GLUTState -> Bool -> IO ()
initializeGLUT

        -- non-freeglut doesn't like this: (\_ -> GLUT.leaveMainLoop)
        exitBackend :: IORef GLUTState -> IO ()
exitBackend                = (\IORef GLUTState
_ -> ExitCode -> IO ()
forall a. ExitCode -> IO a
System.exitWith ExitCode
System.ExitSuccess)

        openWindow :: IORef GLUTState -> Display -> IO ()
openWindow                 = IORef GLUTState -> Display -> IO ()
openWindowGLUT
        dumpBackendState :: IORef GLUTState -> IO ()
dumpBackendState           = IORef GLUTState -> IO ()
dumpStateGLUT
        installDisplayCallback :: IORef GLUTState -> [Callback] -> IO ()
installDisplayCallback     = IORef GLUTState -> [Callback] -> IO ()
installDisplayCallbackGLUT

        -- We can ask for this in freeglut, but it doesn't seem to work :(.
        -- (\_ -> GLUT.actionOnWindowClose $= GLUT.MainLoopReturns)
        installWindowCloseCallback :: IORef GLUTState -> IO ()
installWindowCloseCallback = (\IORef GLUTState
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

        installReshapeCallback :: IORef GLUTState -> [Callback] -> IO ()
installReshapeCallback     = IORef GLUTState -> [Callback] -> IO ()
installReshapeCallbackGLUT
        installKeyMouseCallback :: IORef GLUTState -> [Callback] -> IO ()
installKeyMouseCallback    = IORef GLUTState -> [Callback] -> IO ()
installKeyMouseCallbackGLUT
        installMotionCallback :: IORef GLUTState -> [Callback] -> IO ()
installMotionCallback      = IORef GLUTState -> [Callback] -> IO ()
installMotionCallbackGLUT
        installIdleCallback :: IORef GLUTState -> [Callback] -> IO ()
installIdleCallback        = IORef GLUTState -> [Callback] -> IO ()
installIdleCallbackGLUT

        -- Call the GLUT mainloop.
        -- This function will return when something calls GLUT.leaveMainLoop
        runMainLoop :: IORef GLUTState -> IO ()
runMainLoop IORef GLUTState
_
         =      IO ()
forall (m :: * -> *). MonadIO m => m ()
GLUT.mainLoop

        postRedisplay :: IORef GLUTState -> IO ()
postRedisplay IORef GLUTState
_
         =      Maybe Window -> IO ()
forall (m :: * -> *). MonadIO m => Maybe Window -> m ()
GLUT.postRedisplay Maybe Window
forall a. Maybe a
Nothing

        getWindowDimensions :: IORef GLUTState -> IO (Int, Int)
getWindowDimensions IORef GLUTState
_
         = do   GL.Size GLsizei
sizeX GLsizei
sizeY   <- StateVar Size -> IO Size
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar Size
GLUT.windowSize
                (Int, Int) -> IO (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
sizeX,GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
sizeY)

        getScreenSize :: IORef GLUTState -> IO (Int, Int)
getScreenSize IORef GLUTState
_
         = do   GL.Size GLsizei
width GLsizei
height  <- IO Size -> IO Size
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get IO Size
GLUT.screenSize
                (Int, Int) -> IO (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (GLsizei -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
width, GLsizei -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
height)

        elapsedTime :: IORef GLUTState -> IO Double
elapsedTime IORef GLUTState
_
         = do   Int
t       <- GettableStateVar Int -> GettableStateVar Int
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar Int
GLUT.elapsedTime
                Double -> IO Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> IO Double) -> Double -> IO Double
forall a b. (a -> b) -> a -> b
$ (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
t) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000

        sleep :: IORef GLUTState -> Double -> IO ()
sleep IORef GLUTState
_ Double
sec
         = do   Int -> IO ()
threadDelay (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
sec Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000000)


-- Initialise -----------------------------------------------------------------
initializeGLUT
        :: IORef GLUTState
        -> Bool
        -> IO ()

initializeGLUT :: IORef GLUTState -> Bool -> IO ()
initializeGLUT IORef GLUTState
_ Bool
debug
  = do Bool
initialized <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
glutInitialized
       if Bool -> Bool
not Bool
initialized
         then do  (String
_progName, [String]
_args)  <- IO (String, [String])
forall (m :: * -> *). MonadIO m => m (String, [String])
GLUT.getArgsAndInitialize
                  String
glutVersion         <- GettableStateVar String -> GettableStateVar String
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar String
GLUT.glutVersion
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug
                    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr  (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"  glutVersion        = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
glutVersion   String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"

                  StateVar [DisplayMode]
GLUT.initialDisplayMode
                    StateVar [DisplayMode] -> [DisplayMode] -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= [ DisplayMode
GLUT.RGBMode
                       , DisplayMode
GLUT.DoubleBuffered]

                  IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
glutInitialized Bool
True

                  -- See if our requested display mode is possible
                  [DisplayMode]
displayMode         <- StateVar [DisplayMode] -> IO [DisplayMode]
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar [DisplayMode]
GLUT.initialDisplayMode
                  Bool
displayModePossible <- IO Bool -> IO Bool
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get IO Bool
GLUT.displayModePossible
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug
                    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$  String
"  displayMode        = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [DisplayMode] -> String
forall a. Show a => a -> String
show [DisplayMode]
displayMode String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"       possible      = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
displayModePossible String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
         else Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (String -> IO ()
putStrLn String
"Already initialized")

-- Open Window ----------------------------------------------------------------
openWindowGLUT
        :: IORef GLUTState
        -> Display
        -> IO ()

openWindowGLUT :: IORef GLUTState -> Display -> IO ()
openWindowGLUT IORef GLUTState
_ Display
display
 = do
       -- Setup and create a new window.
       -- Be sure to set initialWindow{Position,Size} before calling
       -- createWindow. If we don't do this we get wierd half-created
       -- windows some of the time.
        case Display
display of
          InWindow String
windowName (Int
sizeX, Int
sizeY) (Int
posX, Int
posY) ->
            do StateVar Size
GLUT.initialWindowSize
                     StateVar Size -> Size -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLsizei -> GLsizei -> Size
GL.Size
                          (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeX)
                          (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeY)

               StateVar Position
GLUT.initialWindowPosition
                     StateVar Position -> Position -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLsizei -> GLsizei -> Position
GL.Position
                          (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
posX)
                          (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
posY)

               Window
_ <- String -> IO Window
forall (m :: * -> *). MonadIO m => String -> m Window
GLUT.createWindow String
windowName

               StateVar Size
GLUT.windowSize
                     StateVar Size -> Size -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLsizei -> GLsizei -> Size
GL.Size
                          (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeX)
                          (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeY)

          Display
FullScreen ->
            do Size
size <- IO Size -> IO Size
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get IO Size
GLUT.screenSize
               StateVar Size
GLUT.initialWindowSize StateVar Size -> Size -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Size
size
               Window
_ <- String -> IO Window
forall (m :: * -> *). MonadIO m => String -> m Window
GLUT.createWindow String
"Gloss Application"
               IO ()
forall (m :: * -> *). MonadIO m => m ()
GLUT.fullScreen

        --  Switch some things.
        --  auto repeat interferes with key up / key down checks.
        --  BUGS: this doesn't seem to work?
        StateVar PerWindowKeyRepeat
GLUT.perWindowKeyRepeat   StateVar PerWindowKeyRepeat -> PerWindowKeyRepeat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= PerWindowKeyRepeat
GLUT.PerWindowKeyRepeatOff


-- Dump State -----------------------------------------------------------------
dumpStateGLUT
        :: IORef GLUTState
        -> IO ()

dumpStateGLUT :: IORef GLUTState -> IO ()
dumpStateGLUT IORef GLUTState
_
 = do
        Int
wbw             <- GettableStateVar Int -> GettableStateVar Int
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar Int
GLUT.windowBorderWidth
        Int
whh             <- GettableStateVar Int -> GettableStateVar Int
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar Int
GLUT.windowHeaderHeight
        Bool
rgba            <- IO Bool -> IO Bool
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get IO Bool
GLUT.rgba

        (Int, Int, Int, Int)
rgbaBD          <- GettableStateVar (Int, Int, Int, Int)
-> GettableStateVar (Int, Int, Int, Int)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar (Int, Int, Int, Int)
GLUT.rgbaBufferDepths
        Int
colorBD         <- GettableStateVar Int -> GettableStateVar Int
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar Int
GLUT.colorBufferDepth
        Int
depthBD         <- GettableStateVar Int -> GettableStateVar Int
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar Int
GLUT.depthBufferDepth
        (Int, Int, Int, Int)
accumBD         <- GettableStateVar (Int, Int, Int, Int)
-> GettableStateVar (Int, Int, Int, Int)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar (Int, Int, Int, Int)
GLUT.accumBufferDepths
        Int
stencilBD       <- GettableStateVar Int -> GettableStateVar Int
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar Int
GLUT.stencilBufferDepth

        Bool
doubleBuffered  <- IO Bool -> IO Bool
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get IO Bool
GLUT.doubleBuffered

        Color4 Capability
colorMask       <- StateVar (Color4 Capability) -> IO (Color4 Capability)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar (Color4 Capability)
GLUT.colorMask
        Capability
depthMask       <- StateVar Capability -> IO Capability
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar Capability
GLUT.depthMask

        String -> IO ()
putStr  (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$  String
"* dumpGlutState\n"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"  windowBorderWidth  = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
wbw            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"  windowHeaderHeight = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
whh            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"  rgba               = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
rgba           String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"  depth      rgba    = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int, Int, Int, Int) -> String
forall a. Show a => a -> String
show (Int, Int, Int, Int)
rgbaBD         String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"             color   = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
colorBD        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"             depth   = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
depthBD        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"             accum   = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int, Int, Int, Int) -> String
forall a. Show a => a -> String
show (Int, Int, Int, Int)
accumBD        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"             stencil = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
stencilBD      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"  doubleBuffered     = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
doubleBuffered String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"  mask         color = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Color4 Capability -> String
forall a. Show a => a -> String
show Color4 Capability
colorMask      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"               depth = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Capability -> String
forall a. Show a => a -> String
show Capability
depthMask      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"

-- Display Callback -----------------------------------------------------------
installDisplayCallbackGLUT
        :: IORef GLUTState -> [Callback]
        -> IO ()
installDisplayCallbackGLUT :: IORef GLUTState -> [Callback] -> IO ()
installDisplayCallbackGLUT IORef GLUTState
ref [Callback]
callbacks
        = SettableStateVar (IO ())
GLUT.displayCallback SettableStateVar (IO ()) -> IO () -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= IORef GLUTState -> [Callback] -> IO ()
callbackDisplay IORef GLUTState
ref [Callback]
callbacks


callbackDisplay
        :: IORef GLUTState -> [Callback]
        -> IO ()

callbackDisplay :: IORef GLUTState -> [Callback] -> IO ()
callbackDisplay IORef GLUTState
refState [Callback]
callbacks
 = do
        -- Clear the display
        [ClearBuffer] -> IO ()
GL.clear [ClearBuffer
GL.ColorBuffer, ClearBuffer
GL.DepthBuffer]
        Color4 GLfloat -> IO ()
forall a. Color a => a -> IO ()
GL.color (Color4 GLfloat -> IO ()) -> Color4 GLfloat -> IO ()
forall a b. (a -> b) -> a -> b
$ GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat
forall a. a -> a -> a -> a -> Color4 a
GL.Color4 GLfloat
0 GLfloat
0 GLfloat
0 (GLfloat
1 :: GL.GLfloat)

        -- Run all the display callbacks to draw the window contents.
        let funs :: [IO ()]
funs  = [IORef GLUTState -> IO ()
DisplayCallback
f IORef GLUTState
refState | (Display DisplayCallback
f) <- [Callback]
callbacks]
        [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
funs

        -- Swap front and back buffers
        IO ()
forall (m :: * -> *). MonadIO m => m ()
GLUT.swapBuffers

        -- Timeout.
        -- When there is no idle callback set the GLUT mainloop will block
        -- forever waiting for display events. This prevents us from updating
        -- the display on external events like files changing. The API doesn't
        -- provide a way to wake it up on these other events.
        --
        -- Set a timeout so that GLUT will return from its mainloop after a
        -- a second and give us a chance to check for other events.
        --
        -- The alternative would be to set an Idle callback and spin the CPU.
        -- This is ok for real-time animations, but a CPU hog for mostly static
        -- displays.
        --
        -- We only want to add a timeout when one doesn't already exist,
        -- otherwise we'll get both events.
        --
        GLUTState
state   <- IORef GLUTState -> IO GLUTState
forall a. IORef a -> IO a
readIORef IORef GLUTState
refState
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (  (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ GLUTState -> Bool
glutStateHasTimeout GLUTState
state)
             Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ GLUTState -> Bool
glutStateHasIdle    GLUTState
state))
         (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                -- Setting the timer interrupt to 1sec keeps CPU usage for a
                -- single process to < 0.5% or so on OSX. This is the rate
                -- that the process is woken up, but GLUT will only actually
                -- call the display call if postRedisplay has been set.
                let msecHeartbeat :: Int
msecHeartbeat = Int
1000

                -- We're installing this callback on the first display
                -- call because it's a GLUT specific mechanism.
                -- We don't do the same thing for other Backends.
                Int -> IO () -> IO ()
GLUT.addTimerCallback Int
msecHeartbeat
                 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
timerCallback Int
msecHeartbeat

                -- Rember that we've done this filthy hack.
                IORef GLUTState -> (GLUTState -> (GLUTState, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef GLUTState
refState
                 ((GLUTState -> (GLUTState, ())) -> IO ())
-> (GLUTState -> (GLUTState, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GLUTState
s -> (GLUTState
s { glutStateHasTimeout :: Bool
glutStateHasTimeout = Bool
True }, ())


    -- Don't report errors by default.
    -- The windows OpenGL implementation seems to complain for no reason.
    --  GLUT.reportErrors

        IORef GLUTState -> (GLUTState -> (GLUTState, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef GLUTState
refState
         ((GLUTState -> (GLUTState, ())) -> IO ())
-> (GLUTState -> (GLUTState, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GLUTState
s -> ( GLUTState
s { glutStateFrameCount :: Int
glutStateFrameCount = GLUTState -> Int
glutStateFrameCount GLUTState
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
                 , ())

        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | Oneshot timer callback that re-registers itself.
timerCallback :: Int -> IO ()
timerCallback :: Int -> IO ()
timerCallback Int
msec
 = do   Int -> IO () -> IO ()
GLUT.addTimerCallback Int
msec
         (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do   Int -> IO ()
timerCallback Int
msec


-- Reshape Callback -----------------------------------------------------------
installReshapeCallbackGLUT
        :: IORef GLUTState -> [Callback]
        -> IO ()

installReshapeCallbackGLUT :: IORef GLUTState -> [Callback] -> IO ()
installReshapeCallbackGLUT IORef GLUTState
ref [Callback]
callbacks
        = SettableStateVar (Maybe (Size -> IO ()))
GLUT.reshapeCallback SettableStateVar (Maybe (Size -> IO ()))
-> Maybe (Size -> IO ()) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (Size -> IO ()) -> Maybe (Size -> IO ())
forall a. a -> Maybe a
Just (IORef GLUTState -> [Callback] -> Size -> IO ()
callbackReshape IORef GLUTState
ref [Callback]
callbacks)

callbackReshape
        :: IORef GLUTState -> [Callback]
        -> GLUT.Size
        -> IO ()

callbackReshape :: IORef GLUTState -> [Callback] -> Size -> IO ()
callbackReshape IORef GLUTState
ref [Callback]
callbacks (GLUT.Size GLsizei
sizeX GLsizei
sizeY)
        = [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
        ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ (((Int, Int) -> IO ()) -> IO ())
-> [(Int, Int) -> IO ()] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map   (\(Int, Int) -> IO ()
f -> (Int, Int) -> IO ()
f (GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
sizeX, GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
sizeY))
                [IORef GLUTState -> (Int, Int) -> IO ()
ReshapeCallback
f IORef GLUTState
ref | Reshape ReshapeCallback
f <- [Callback]
callbacks]


-- KeyMouse Callback ----------------------------------------------------------
installKeyMouseCallbackGLUT
        :: IORef GLUTState -> [Callback]
        -> IO ()

installKeyMouseCallbackGLUT :: IORef GLUTState -> [Callback] -> IO ()
installKeyMouseCallbackGLUT IORef GLUTState
ref [Callback]
callbacks
        = SettableStateVar (Maybe KeyboardMouseCallback)
GLUT.keyboardMouseCallback SettableStateVar (Maybe KeyboardMouseCallback)
-> Maybe KeyboardMouseCallback -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= KeyboardMouseCallback -> Maybe KeyboardMouseCallback
forall a. a -> Maybe a
Just (IORef GLUTState -> [Callback] -> KeyboardMouseCallback
callbackKeyMouse IORef GLUTState
ref [Callback]
callbacks)

callbackKeyMouse
        :: IORef GLUTState -> [Callback]
        -> GLUT.Key
        -> GLUT.KeyState
        -> GLUT.Modifiers
        -> GLUT.Position
        -> IO ()

callbackKeyMouse :: IORef GLUTState -> [Callback] -> KeyboardMouseCallback
callbackKeyMouse IORef GLUTState
ref [Callback]
callbacks Key
key KeyState
keystate Modifiers
modifiers (GLUT.Position GLsizei
posX GLsizei
posY)
  = [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
  ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ ((Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()) -> IO ())
-> [Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map (\Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
f -> Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
f Key
key' KeyState
keyState' Modifiers
modifiers' (Int, Int)
pos)
      [IORef GLUTState
-> Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
KeyboardMouseCallback
f IORef GLUTState
ref | KeyMouse KeyboardMouseCallback
f <- [Callback]
callbacks]
  where
    key' :: Key
key'       = Key -> Key
glutKeyToKey Key
key
    keyState' :: KeyState
keyState'  = KeyState -> KeyState
glutKeyStateToKeyState KeyState
keystate
    modifiers' :: Modifiers
modifiers' = Modifiers -> Modifiers
glutModifiersToModifiers Modifiers
modifiers
    pos :: (Int, Int)
pos        = (GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
posX, GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
posY)


-- Motion Callback ------------------------------------------------------------
installMotionCallbackGLUT
        :: IORef GLUTState -> [Callback]
        -> IO ()

installMotionCallbackGLUT :: IORef GLUTState -> [Callback] -> IO ()
installMotionCallbackGLUT IORef GLUTState
ref [Callback]
callbacks
 = do   SettableStateVar (Maybe (Position -> IO ()))
GLUT.motionCallback        SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (Position -> IO ()) -> Maybe (Position -> IO ())
forall a. a -> Maybe a
Just (IORef GLUTState -> [Callback] -> Position -> IO ()
callbackMotion IORef GLUTState
ref [Callback]
callbacks)
        SettableStateVar (Maybe (Position -> IO ()))
GLUT.passiveMotionCallback SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (Position -> IO ()) -> Maybe (Position -> IO ())
forall a. a -> Maybe a
Just (IORef GLUTState -> [Callback] -> Position -> IO ()
callbackMotion IORef GLUTState
ref [Callback]
callbacks)

callbackMotion
        :: IORef GLUTState -> [Callback]
        -> GLUT.Position
        -> IO ()

callbackMotion :: IORef GLUTState -> [Callback] -> Position -> IO ()
callbackMotion IORef GLUTState
ref [Callback]
callbacks (GLUT.Position GLsizei
posX GLsizei
posY)
 = do   let pos :: (Int, Int)
pos = (GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
posX, GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
posY)
        [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
         ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ (((Int, Int) -> IO ()) -> IO ())
-> [(Int, Int) -> IO ()] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map  (\(Int, Int) -> IO ()
f -> (Int, Int) -> IO ()
f (Int, Int)
pos)
                [IORef GLUTState -> (Int, Int) -> IO ()
ReshapeCallback
f IORef GLUTState
ref | Motion ReshapeCallback
f <- [Callback]
callbacks]


-- Idle Callback --------------------------------------------------------------
installIdleCallbackGLUT
        :: IORef GLUTState -> [Callback]
        -> IO ()

installIdleCallbackGLUT :: IORef GLUTState -> [Callback] -> IO ()
installIdleCallbackGLUT IORef GLUTState
refState [Callback]
callbacks
        -- If the callback list does not actually contain an idle callback
        -- then don't install one that just does nothing. If we do then GLUT
        -- will still call us back after whenever it's idle and waste CPU time.
        | (Callback -> Bool) -> [Callback] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Callback -> Bool
isIdleCallback [Callback]
callbacks
        = do    SettableStateVar (Maybe (IO ()))
GLUT.idleCallback SettableStateVar (Maybe (IO ())) -> Maybe (IO ()) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IORef GLUTState -> [Callback] -> IO ()
callbackIdle IORef GLUTState
refState [Callback]
callbacks)
                IORef GLUTState -> (GLUTState -> (GLUTState, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef GLUTState
refState
                 ((GLUTState -> (GLUTState, ())) -> IO ())
-> (GLUTState -> (GLUTState, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GLUTState
state -> (GLUTState
state { glutStateHasIdle :: Bool
glutStateHasIdle = Bool
True }, ())

        | Bool
otherwise
        = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | Call back when glut is idle.
callbackIdle
        :: IORef GLUTState -> [Callback]
        -> IO ()

callbackIdle :: IORef GLUTState -> [Callback] -> IO ()
callbackIdle IORef GLUTState
ref [Callback]
callbacks
        = [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
        ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ [IORef GLUTState -> IO ()
DisplayCallback
f IORef GLUTState
ref | Idle DisplayCallback
f <- [Callback]
callbacks]


-------------------------------------------------------------------------------
-- | Convert GLUTs key codes to our internal ones.
glutKeyToKey :: GLUT.Key -> Key
glutKeyToKey :: Key -> Key
glutKeyToKey Key
key
 = case Key
key of
        GLUT.Char Char
'\32'                            -> SpecialKey -> Key
SpecialKey SpecialKey
KeySpace
        GLUT.Char Char
'\13'                            -> SpecialKey -> Key
SpecialKey SpecialKey
KeyEnter
        GLUT.Char Char
'\9'                             -> SpecialKey -> Key
SpecialKey SpecialKey
KeyTab
        GLUT.Char Char
'\ESC'                           -> SpecialKey -> Key
SpecialKey SpecialKey
KeyEsc
        GLUT.Char Char
'\DEL'                           -> SpecialKey -> Key
SpecialKey SpecialKey
KeyDelete
        GLUT.Char Char
c                                -> Char -> Key
Char Char
c
        GLUT.SpecialKey SpecialKey
GLUT.KeyF1                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF1
        GLUT.SpecialKey SpecialKey
GLUT.KeyF2                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF2
        GLUT.SpecialKey SpecialKey
GLUT.KeyF3                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF3
        GLUT.SpecialKey SpecialKey
GLUT.KeyF4                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF4
        GLUT.SpecialKey SpecialKey
GLUT.KeyF5                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF5
        GLUT.SpecialKey SpecialKey
GLUT.KeyF6                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF6
        GLUT.SpecialKey SpecialKey
GLUT.KeyF7                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF7
        GLUT.SpecialKey SpecialKey
GLUT.KeyF8                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF8
        GLUT.SpecialKey SpecialKey
GLUT.KeyF9                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF9
        GLUT.SpecialKey SpecialKey
GLUT.KeyF10                -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF10
        GLUT.SpecialKey SpecialKey
GLUT.KeyF11                -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF11
        GLUT.SpecialKey SpecialKey
GLUT.KeyF12                -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF12
        GLUT.SpecialKey SpecialKey
GLUT.KeyLeft               -> SpecialKey -> Key
SpecialKey SpecialKey
KeyLeft
        GLUT.SpecialKey SpecialKey
GLUT.KeyUp                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyUp
        GLUT.SpecialKey SpecialKey
GLUT.KeyRight              -> SpecialKey -> Key
SpecialKey SpecialKey
KeyRight
        GLUT.SpecialKey SpecialKey
GLUT.KeyDown               -> SpecialKey -> Key
SpecialKey SpecialKey
KeyDown
        GLUT.SpecialKey SpecialKey
GLUT.KeyPageUp             -> SpecialKey -> Key
SpecialKey SpecialKey
KeyPageUp
        GLUT.SpecialKey SpecialKey
GLUT.KeyPageDown           -> SpecialKey -> Key
SpecialKey SpecialKey
KeyPageDown
        GLUT.SpecialKey SpecialKey
GLUT.KeyHome               -> SpecialKey -> Key
SpecialKey SpecialKey
KeyHome
        GLUT.SpecialKey SpecialKey
GLUT.KeyEnd                -> SpecialKey -> Key
SpecialKey SpecialKey
KeyEnd
        GLUT.SpecialKey SpecialKey
GLUT.KeyInsert             -> SpecialKey -> Key
SpecialKey SpecialKey
KeyInsert
        GLUT.SpecialKey SpecialKey
GLUT.KeyNumLock            -> SpecialKey -> Key
SpecialKey SpecialKey
KeyNumLock
        GLUT.SpecialKey SpecialKey
GLUT.KeyBegin              -> SpecialKey -> Key
SpecialKey SpecialKey
KeyBegin
        GLUT.SpecialKey SpecialKey
GLUT.KeyDelete             -> SpecialKey -> Key
SpecialKey SpecialKey
KeyDelete
        GLUT.SpecialKey (GLUT.KeyUnknown Int
_)        -> SpecialKey -> Key
SpecialKey SpecialKey
KeyUnknown
        GLUT.SpecialKey SpecialKey
GLUT.KeyShiftL             -> SpecialKey -> Key
SpecialKey SpecialKey
KeyShiftL
        GLUT.SpecialKey SpecialKey
GLUT.KeyShiftR             -> SpecialKey -> Key
SpecialKey SpecialKey
KeyShiftR
        GLUT.SpecialKey SpecialKey
GLUT.KeyCtrlL              -> SpecialKey -> Key
SpecialKey SpecialKey
KeyCtrlL
        GLUT.SpecialKey SpecialKey
GLUT.KeyCtrlR              -> SpecialKey -> Key
SpecialKey SpecialKey
KeyCtrlR
        GLUT.SpecialKey SpecialKey
GLUT.KeyAltL               -> SpecialKey -> Key
SpecialKey SpecialKey
KeyAltL
        GLUT.SpecialKey SpecialKey
GLUT.KeyAltR               -> SpecialKey -> Key
SpecialKey SpecialKey
KeyAltR
        GLUT.MouseButton MouseButton
GLUT.LeftButton           -> MouseButton -> Key
MouseButton MouseButton
LeftButton
        GLUT.MouseButton MouseButton
GLUT.MiddleButton         -> MouseButton -> Key
MouseButton MouseButton
MiddleButton
        GLUT.MouseButton MouseButton
GLUT.RightButton          -> MouseButton -> Key
MouseButton MouseButton
RightButton
        GLUT.MouseButton MouseButton
GLUT.WheelUp              -> MouseButton -> Key
MouseButton MouseButton
WheelUp
        GLUT.MouseButton MouseButton
GLUT.WheelDown            -> MouseButton -> Key
MouseButton MouseButton
WheelDown
        GLUT.MouseButton (GLUT.AdditionalButton Int
i) -> MouseButton -> Key
MouseButton (Int -> MouseButton
AdditionalButton Int
i)

-- | Convert GLUTs key states to our internal ones.
glutKeyStateToKeyState :: GLUT.KeyState -> KeyState
glutKeyStateToKeyState :: KeyState -> KeyState
glutKeyStateToKeyState KeyState
state
 = case KeyState
state of
        KeyState
GLUT.Down       -> KeyState
Down
        KeyState
GLUT.Up         -> KeyState
Up


-- | Convert GLUTs key states to our internal ones.
glutModifiersToModifiers
        :: GLUT.Modifiers
        -> Modifiers

glutModifiersToModifiers :: Modifiers -> Modifiers
glutModifiersToModifiers (GLUT.Modifiers KeyState
a KeyState
b KeyState
c)
        = KeyState -> KeyState -> KeyState -> Modifiers
Modifiers     (KeyState -> KeyState
glutKeyStateToKeyState KeyState
a)
                        (KeyState -> KeyState
glutKeyStateToKeyState KeyState
b)
                        (KeyState -> KeyState
glutKeyStateToKeyState KeyState
c)