    {-# 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 = unsafePerformIO $ do newIORef False

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

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

              -- Bool to remember if we've set the idle callback.
            , glutStateHasIdle      :: Bool }
            deriving Show

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

    instance Backend GLUTState where
            initBackendState           = glutStateInit
            initializeBackend          = initializeGLUT

            -- non-freeglut doesn't like this: (\_ -> GLUT.leaveMainLoop)
            exitBackend                = (\_ -> System.exitWith System.ExitSuccess)

            openWindow                 = openWindowGLUT
            dumpBackendState           = dumpStateGLUT
            installDisplayCallback     = installDisplayCallbackGLUT

            -- We can ask for this in freeglut, but it doesn't seem to work :(.
            -- (\_ -> GLUT.actionOnWindowClose $= GLUT.MainLoopReturns)
            installWindowCloseCallback = (\_ -> return ())

            installReshapeCallback     = installReshapeCallbackGLUT
            installKeyMouseCallback    = installKeyMouseCallbackGLUT
            installMotionCallback      = installMotionCallbackGLUT
            installIdleCallback        = installIdleCallbackGLUT

            -- Call the GLUT mainloop.
            -- This function will return when something calls GLUT.leaveMainLoop
            runMainLoop _
             =      GLUT.mainLoop

            postRedisplay _
             =      GLUT.postRedisplay Nothing

            getWindowDimensions _
             = do   GL.Size sizeX sizeY   <- get GLUT.windowSize
                    return (fromEnum sizeX,fromEnum sizeY)

            elapsedTime _
             = do   t       <- get GLUT.elapsedTime
                    return $ (fromIntegral t) / 1000

            sleep _ sec
             = do   threadDelay (round $ sec * 1000000)

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

    initializeGLUT _ debug
      = do initialized <- readIORef glutInitialized
           if not initialized
             then do  (_progName, _args)  <- GLUT.getArgsAndInitialize
                      glutVersion         <- get GLUT.glutVersion
                      when debug
                        $ putStr  $ "  glutVersion        = " ++ show glutVersion   ++ "\n"

                      GLUT.initialDisplayMode
                        $= [ GLUT.RGBMode
                           , GLUT.DoubleBuffered]

                      writeIORef glutInitialized True

                      -- See if our requested display mode is possible
                      displayMode         <- get GLUT.initialDisplayMode
                      displayModePossible <- get GLUT.displayModePossible
                      when debug
                        $ do putStr $  "  displayMode        = " ++ show displayMode ++ "\n"
                                    ++ "       possible      = " ++ show displayModePossible ++ "\n"
                                    ++ "\n"
             else when debug (putStrLn "Already initialized")

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

    openWindowGLUT _ 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 of
              InWindow windowName (sizeX, sizeY) (posX, posY) ->
                do GLUT.initialWindowSize
                         $= GL.Size
                              (fromIntegral sizeX)
                              (fromIntegral sizeY)

                   GLUT.initialWindowPosition
                         $= GL.Position
                              (fromIntegral posX)
                              (fromIntegral posY)

                   _ <- GLUT.createWindow windowName

                   GLUT.windowSize
                         $= GL.Size
                              (fromIntegral sizeX)
                              (fromIntegral sizeY)

              FullScreen ->
                do size <- get GLUT.screenSize
                   GLUT.initialWindowSize $= size
                   _ <- GLUT.createWindow "Gloss Application"
                   GLUT.fullScreen

            --  Switch some things.
            --  auto repeat interferes with key up / key down checks.
            --  BUGS: this doesn't seem to work?
            GLUT.perWindowKeyRepeat   $= GLUT.PerWindowKeyRepeatOff

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

    dumpStateGLUT _
     = do
            wbw             <- get GLUT.windowBorderWidth
            whh             <- get GLUT.windowHeaderHeight
            rgba            <- get GLUT.rgba

            rgbaBD          <- get GLUT.rgbaBufferDepths
            colorBD         <- get GLUT.colorBufferDepth
            depthBD         <- get GLUT.depthBufferDepth
            accumBD         <- get GLUT.accumBufferDepths
            stencilBD       <- get GLUT.stencilBufferDepth

            doubleBuffered  <- get GLUT.doubleBuffered

            colorMask       <- get GLUT.colorMask
            depthMask       <- get GLUT.depthMask

            putStr  $  "* dumpGlutState\n"
                    ++ "  windowBorderWidth  = " ++ show wbw            ++ "\n"
                    ++ "  windowHeaderHeight = " ++ show whh            ++ "\n"
                    ++ "  rgba               = " ++ show rgba           ++ "\n"
                    ++ "  depth      rgba    = " ++ show rgbaBD         ++ "\n"
                    ++ "             color   = " ++ show colorBD        ++ "\n"
                    ++ "             depth   = " ++ show depthBD        ++ "\n"
                    ++ "             accum   = " ++ show accumBD        ++ "\n"
                    ++ "             stencil = " ++ show stencilBD      ++ "\n"
                    ++ "  doubleBuffered     = " ++ show doubleBuffered ++ "\n"
                    ++ "  mask         color = " ++ show colorMask      ++ "\n"
                    ++ "               depth = " ++ show depthMask      ++ "\n"
                    ++ "\n"

    -- Display Callback -----------------------------------------------------------
    installDisplayCallbackGLUT
            :: IORef GLUTState -> [Callback]
            -> IO ()
    installDisplayCallbackGLUT ref callbacks
            = GLUT.displayCallback $= callbackDisplay ref callbacks

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

    callbackDisplay refState callbacks
     = do
            -- Clear the display
            GL.clear [GL.ColorBuffer, GL.DepthBuffer]
            GL.color $ GL.Color4 0 0 0 (1 :: GL.GLfloat)

            -- Run all the display callbacks to draw the window contents.
            let funs  = [f refState | (Display f) <- callbacks]
            sequence_ funs

            -- Swap front and back buffers
            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.
            --
            state   <- readIORef refState
            when (  (not $ glutStateHasTimeout state)
                 && (not $ glutStateHasIdle    state))
             $ 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 = 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.
                    GLUT.addTimerCallback msecHeartbeat
                     $ timerCallback msecHeartbeat

                    -- Rember that we've done this filthy hack.
                    atomicModifyIORef' refState
                     $ \s -> (s { glutStateHasTimeout = True }, ())

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

            atomicModifyIORef' refState
             $ \s -> ( s { glutStateFrameCount = glutStateFrameCount s + 1 }
                     , ())

            return ()

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

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

    installReshapeCallbackGLUT ref callbacks
            = GLUT.reshapeCallback $= Just (callbackReshape ref callbacks)

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

    callbackReshape ref callbacks (GLUT.Size sizeX sizeY)
            = sequence_
            $ map   (\f -> f (fromEnum sizeX, fromEnum sizeY))
                    [f ref | Reshape f <- callbacks]

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

    installKeyMouseCallbackGLUT ref callbacks
            = GLUT.keyboardMouseCallback $= Just (callbackKeyMouse ref callbacks)

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

    callbackKeyMouse ref callbacks key keystate modifiers (GLUT.Position posX posY)
      = sequence_
      $ map (\f -> f key' keyState' modifiers' pos)
          [f ref | KeyMouse f <- callbacks]
      where
        key'       = glutKeyToKey key
        keyState'  = glutKeyStateToKeyState keystate
        modifiers' = glutModifiersToModifiers modifiers
        pos        = (fromEnum posX, fromEnum posY)

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

    installMotionCallbackGLUT ref callbacks
     = do   GLUT.motionCallback        $= Just (callbackMotion ref callbacks)
            GLUT.passiveMotionCallback $= Just (callbackMotion ref callbacks)

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

    callbackMotion ref callbacks (GLUT.Position posX posY)
     = do   let pos = (fromEnum posX, fromEnum posY)
            sequence_
             $ map  (\f -> f pos)
                    [f ref | Motion f <- callbacks]

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

    installIdleCallbackGLUT refState 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.
            | any isIdleCallback callbacks
            = do    GLUT.idleCallback $= Just (callbackIdle refState callbacks)
                    atomicModifyIORef' refState
                     $ \state -> (state { glutStateHasIdle = True }, ())

            | otherwise
            = return ()

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

    callbackIdle ref callbacks
            = sequence_
            $ [f ref | Idle f <- callbacks]

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

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

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

    glutModifiersToModifiers (GLUT.Modifiers a b c)
            = Modifiers     (glutKeyStateToKeyState a)
                            (glutKeyStateToKeyState b)
                            (glutKeyStateToKeyState c)