{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE CPP #-}

-- | Support for using GLFW as the window manager backend.
module Graphics.Gloss.Internals.Interface.Backend.GLFW
        (GLFWState)
where
import Data.IORef
import Data.Maybe                          (fromJust)
import Control.Concurrent
import Control.Monad
import Graphics.Gloss.Data.Display
import qualified Graphics.UI.GLFW          as GLFW
import Graphics.Rendering.OpenGL (($=))
import qualified Graphics.Rendering.OpenGL as GL
import qualified Control.Exception         as X


-- [Note: FreeGlut]
-- ~~~~~~~~~~~~~~~~
-- We use GLUT for font rendering.
--   On freeglut-based installations (usually linux) we need to explicitly
--   initialize GLUT before we can use any of it's functions.
--
---  We also need to deinitialize (exit) GLUT when we close the GLFW
--   window, otherwise opening a gloss window again from GHCi will crash.
--   For the OS X and Windows version of GLUT there are no such restrictions.
--
--   We assume also assume that only linux installations use freeglut.
--
#ifdef linux_HOST_OS
import qualified Graphics.UI.GLUT          as GLUT
#endif

import Graphics.Gloss.Internals.Interface.Backend.Types


-- | State of the GLFW backend library.
data GLFWState
        = GLFWState
        { -- | Status of Ctrl, Alt or Shift (Up or Down?)
          modifiers     :: Modifiers

        -- | Latest mouse position
        , mousePosition :: (Int,Int)

        -- | Latest mousewheel position
        , mouseWheelPos :: Int

        -- | Does the screen need to be redrawn?
        , dirtyScreen   :: Bool

        -- | Action that draws on the screen
        , display       :: IO ()

        -- | Action perforrmed when idling
        , idle          :: IO ()

        -- | The Window Handle
        , optWinHdl     :: Maybe GLFW.Window
        }


-- | Initial GLFW state.
glfwStateInit :: GLFWState
glfwStateInit
        = GLFWState
        { modifiers      = Modifiers Up Up Up
        , mousePosition = (0, 0)
        , mouseWheelPos = 0
        , dirtyScreen   = True
        , display       = return ()
        , idle          = return ()
        , optWinHdl     = Nothing }


-- | Fetch the window handle from the state if it has been initialized.
winHdl :: GLFWState -> GLFW.Window
winHdl state =
        case optWinHdl state of
                Just handle -> handle
                Nothing     -> error "GLFW backend: requested uninitialized window handle"


instance Backend GLFWState where
        initBackendState           = glfwStateInit
        initializeBackend          = initializeGLFW
        exitBackend                = exitGLFW
        openWindow                 = openWindowGLFW
        dumpBackendState           = dumpStateGLFW
        installDisplayCallback     = installDisplayCallbackGLFW
        installWindowCloseCallback = installWindowCloseCallbackGLFW
        installReshapeCallback     = installReshapeCallbackGLFW
        installKeyMouseCallback    = installKeyMouseCallbackGLFW
        installMotionCallback      = installMotionCallbackGLFW
        installIdleCallback        = installIdleCallbackGLFW
        runMainLoop                = runMainLoopGLFW
        postRedisplay              = postRedisplayGLFW
        getWindowDimensions        = (\ref   -> windowHandle ref >>= \win -> GLFW.getWindowSize win)
        getScreenSize              = getScreenSizeGLFW
        elapsedTime                = (\_     -> GLFW.getTime >>= \mt -> return $ fromJust mt)
        sleep                      = (\_ sec -> threadDelay (floor (sec * 1000000.0))) --GLFW.sleep sec)

-- Initialise -----------------------------------------------------------------
-- | Initialise the GLFW backend.
initializeGLFW :: IORef GLFWState -> Bool-> IO ()
initializeGLFW _ debug
 = do

        let simpleErrorCallback e s =
                putStrLn $ unwords [ "GLFW backend: ",  show e, show s ]
        GLFW.setErrorCallback (Just simpleErrorCallback)

        _                   <- GLFW.init
        glfwVersion         <- GLFW.getVersion

#ifdef linux_HOST_OS
-- See [Note: FreeGlut] for why we need this.
        (_progName, _args)  <- GLUT.getArgsAndInitialize
#endif

        when debug
         $ putStr  $ "  glfwVersion        = " ++ show glfwVersion   ++ "\n"


-- Exit -----------------------------------------------------------------------
-- | Tell the GLFW backend to close the window and exit.
exitGLFW :: IORef GLFWState -> IO ()
exitGLFW ref
 = do
#ifdef linux_HOST_OS
-- See [Note: FreeGlut] on why we exit GLUT for Linux
        GLUT.exit
#endif
        win <- windowHandle ref
        GLFW.setWindowShouldClose win True


-- Open Window ----------------------------------------------------------------
-- | Open a new window.
openWindowGLFW
        :: IORef GLFWState
        -> Display
        -> IO ()

openWindowGLFW ref (InWindow title (sizeX, sizeY) pos)
 = do   win <- GLFW.createWindow
                sizeX
                sizeY
                title
                Nothing
                Nothing

        modifyIORef' ref (\s -> s { optWinHdl = win })
        uncurry (GLFW.setWindowPos (fromJust win)) pos
        GLFW.makeContextCurrent win

        -- Try to enable sync-to-vertical-refresh by setting the number
        -- of buffer swaps per vertical refresh to 1.
        GLFW.swapInterval 1

openWindowGLFW ref FullScreen
 = do   mon   <- GLFW.getPrimaryMonitor
        vmode <- GLFW.getVideoMode (fromJust mon)

        let sizeX = GLFW.videoModeWidth (fromJust vmode)
        let sizeY = GLFW.videoModeHeight (fromJust vmode)

        win <- GLFW.createWindow
                sizeX
                sizeY
                ""
                mon
                Nothing

        modifyIORef' ref (\s -> s { optWinHdl = win})
        GLFW.makeContextCurrent win

        -- Try to enable sync-to-vertical-refresh by setting the number
        -- of buffer swaps per vertical refresh to 1.
        GLFW.swapInterval 1
        --GLFW.enableMouseCursor
        GLFW.setCursorInputMode (fromJust win) GLFW.CursorInputMode'Normal


windowHandle :: IORef GLFWState -> IO GLFW.Window
windowHandle ref
 = do s <- readIORef ref
      return $ winHdl s


getScreenSizeGLFW :: IORef GLFWState -> IO (Int,Int)
getScreenSizeGLFW _state = do
        monitor <- GLFW.getPrimaryMonitor
        vmode   <- GLFW.getVideoMode (fromJust monitor)

        let sizeX = GLFW.videoModeWidth (fromJust vmode)
        let sizeY = GLFW.videoModeHeight (fromJust vmode)

        pure (sizeX, sizeY)


-- Dump State -----------------------------------------------------------------
-- | Print out the internal GLFW state.
dumpStateGLFW :: IORef GLFWState -> IO ()
dumpStateGLFW ref
 = do   win         <- windowHandle ref
        (ww,wh)     <- GLFW.getWindowSize win

-- GLFW-b does not provide a general function to query windowHints
-- could be added by adding additional getWindowHint which
-- uses glfwGetWindowAttrib behind the scenes as has been done
-- already for e.g. getWindowVisible which uses glfwGetWindowAttrib
{-
        r           <- GLFW.getWindowHint NumRedBits
        g           <- GLFW.getWindowHint NumGreenBits
        b           <- GLFW.getWindowHint NumBlueBits
        a           <- GLFW.getWindowHint NumAlphaBits
        let rgbaBD  = [r,g,b,a]

        depthBD     <- GLFW.getWindowHint NumDepthBits

        ra          <- GLFW.getWindowHint NumAccumRedBits
        ga          <- GLFW.getWindowHint NumAccumGreenBits
        ba          <- GLFW.getWindowHint NumAccumBlueBits
        aa          <- GLFW.getWindowHint NumAccumAlphaBits
        let accumBD = [ra,ga,ba,aa]

        stencilBD   <- GLFW.getWindowHint NumStencilBits

        auxBuffers  <- GLFW.getWindowHint NumAuxBuffers

        fsaaSamples <- GLFW.getWindowHint NumFsaaSamples

        putStr  $ "* dumpGlfwState\n"
                ++ " windowWidth  = " ++ show ww          ++ "\n"
                ++ " windowHeight = " ++ show wh          ++ "\n"
                ++ " depth rgba   = " ++ show rgbaBD      ++ "\n"
                ++ " depth        = " ++ show depthBD     ++ "\n"
                ++ " accum        = " ++ show accumBD     ++ "\n"
                ++ " stencil      = " ++ show stencilBD   ++ "\n"
                ++ " aux Buffers  = " ++ show auxBuffers  ++ "\n"
                ++ " FSAA Samples = " ++ show fsaaSamples ++ "\n"
                ++ "\n"
-}

        putStr  $ "* dumpGlfwState\n"
                ++ " windowWidth  = " ++ show ww          ++ "\n"
                ++ " windowHeight = " ++ show wh          ++ "\n"
                ++ "\n"

-- Display Callback -----------------------------------------------------------
-- | Callback for when GLFW needs us to redraw the contents of the window.
installDisplayCallbackGLFW
        :: IORef GLFWState -> [Callback] -> IO ()

installDisplayCallbackGLFW stateRef callbacks
 =  modifyIORef' stateRef $ \s -> s
        { display = callbackDisplay stateRef callbacks }


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

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

        -- set the OpenGL viewport to account for any HiDPI discrepancy
        (width, height) <- windowHandle stateRef >>= GLFW.getFramebufferSize
        GL.viewport $= ( GL.Position 0 0
                       , GL.Size (fromIntegral width) (fromIntegral height))

        -- get the display callbacks from the chain
        let funs  = [f stateRef | (Display f) <- callbacks]
        sequence_ funs

        return ()


-- Close Callback -------------------------------------------------------------
-- | Callback for when the user closes the window.
--   We can do some cleanup here.
installWindowCloseCallbackGLFW
        :: IORef GLFWState -> IO ()

installWindowCloseCallbackGLFW ref
 = do win <- windowHandle ref
      GLFW.setWindowCloseCallback win (Just winClosed)
 where
  winClosed :: GLFW.WindowCloseCallback
  winClosed _win = do
#ifdef linux_HOST_OS
-- See [Note: FreeGlut] for why we need this.
        GLUT.exit
#endif
        return ()

-- Reshape --------------------------------------------------------------------
-- | Callback for when the user reshapes the window.
installReshapeCallbackGLFW
        :: IORef GLFWState -> [Callback] -> IO ()

installReshapeCallbackGLFW stateRef callbacks
 = do win <- windowHandle stateRef
      GLFW.setWindowSizeCallback win (Just $ callbackReshape stateRef callbacks)

callbackReshape
        :: IORef GLFWState -> [Callback]
        -> GLFW.WindowSizeCallback -- = Window -> Int -> Int -> IO ()

callbackReshape glfwState callbacks _win sizeX sizeY
  = sequence_
  $ map   (\f -> f (sizeX, sizeY))
    [f glfwState | Reshape f  <- callbacks]


-- KeyMouse -----------------------------------------------------------------------
-- | Callbacks for when the user presses a key or moves / clicks the mouse.
--   This is a bit verbose because we have to do impedence matching between
--   GLFW's event system, and the one use by Gloss which was originally
--   based on GLUT. The main problem is that GLUT only provides a single callback
--   slot for character keys, arrow keys, mouse buttons and mouse wheel movement,
--   while GLFW provides a single slot for each.
--
installKeyMouseCallbackGLFW
        :: IORef GLFWState -> [Callback]
        -> IO ()

installKeyMouseCallbackGLFW stateRef callbacks
 = do   win <- windowHandle stateRef
        GLFW.setKeyCallback         win (Just $ callbackKeyboard    stateRef callbacks)
        GLFW.setCharCallback        win (Just $ callbackChar        stateRef callbacks)
        GLFW.setMouseButtonCallback win (Just $ callbackMouseButton stateRef callbacks)
        GLFW.setScrollCallback      win (Just $ callbackMouseWheel  stateRef callbacks)


-- GLFW calls this on a non-character keyboard action.
callbackKeyboard
        :: IORef GLFWState -> [Callback]
        -> GLFW.KeyCallback -- = Window -> Key -> Int -> KeyState -> ModifierKeys -> IO ()
        -- -> GLFW.Key -> Bool
        -- -> IO ()

callbackKeyboard stateRef callbacks _win key _scancode keystateglfw _modifiers
 = do   let keystate = keystateglfw == GLFW.KeyState'Pressed
        (modsSet, GLFWState mods pos _ _ _ _ _)
                <- setModifiers stateRef key keystate
        let key'      = fromGLFW key
        let keystate' = if keystate then Down else Up
        let isCharKey (Char _) = True
            isCharKey _        = False

        -- Call the Gloss KeyMouse actions with the new state.
        unless (modsSet || isCharKey key' && keystate)
         $ sequence_
         $ map  (\f -> f key' keystate' mods pos)
                [f stateRef | KeyMouse f <- callbacks]


setModifiers
        :: IORef GLFWState
        -> GLFW.Key -> Bool
        -> IO (Bool, GLFWState)

setModifiers stateRef key pressed
 = do   glfwState <- readIORef stateRef
        let mods  = modifiers glfwState
        let mods' = case key of
                GLFW.Key'LeftShift    -> mods {shift = if pressed then Down else Up}
                GLFW.Key'LeftControl  -> mods {ctrl  = if pressed then Down else Up}
                GLFW.Key'LeftAlt      -> mods {alt   = if pressed then Down else Up}
                _                     -> mods

        if (mods' /= mods)
         then do
                let glfwState' = glfwState {modifiers = mods'}
                writeIORef stateRef glfwState'
                return (True, glfwState')
         else return (False, glfwState)


-- GLFW calls this on a when the user presses or releases a character key.
callbackChar
        :: IORef GLFWState -> [Callback]
        -> GLFW.CharCallback
        -- Window -> Char -> IO ()
        -- -> Char -> Bool -> IO ()

callbackChar stateRef callbacks _win char -- keystate
 = do   (GLFWState mods pos _ _ _ _ _) <- readIORef stateRef
        let key'      = charToSpecial char
        -- TODO: is this correct? GLFW does not provide the keystate
        -- in a character callback, here we asume that its pressed
        let keystate = True

        -- Only key presses of characters are passed to this callback,
        -- character key releases are caught by the 'keyCallback'. This is an
        -- intentional feature of GLFW. What this means that a key press of
        -- the '>' char  (on a US Intl keyboard) is captured by this callback,
        -- but a release is captured as a '.' with the shift-modifier in the
        -- keyCallback.
        let keystate' = if keystate then Down else Up

        -- Call all the Gloss KeyMouse actions with the new state.
        sequence_
         $ map  (\f -> f key' keystate' mods pos)
                [f stateRef | KeyMouse f <- callbacks]


-- GLFW calls on this when the user clicks or releases a mouse button.
callbackMouseButton
        :: IORef GLFWState -> [Callback]
        -> GLFW.MouseButtonCallback -- = Window -> MouseButton -> MouseButtonState -> ModifierKeys -> IO ()

callbackMouseButton stateRef callbacks _win key keystate _modifier
 = do   (GLFWState mods pos _ _ _ _ _) <- readIORef stateRef
        let key'      = fromGLFW key
        let keystate' = if keystate == GLFW.MouseButtonState'Pressed then Down else Up

        -- Call all the Gloss KeyMouse actions with the new state.
        sequence_
         $ map  (\f -> f key' keystate' mods pos)
                [f stateRef | KeyMouse f <- callbacks]


-- GLFW calls on this when the user moves the mouse wheel.
callbackMouseWheel
        :: IORef GLFWState -> [Callback]
        -> GLFW.ScrollCallback
        -- -> Int
        -- -> IO ()
-- ScrollCallback = Window -> Double -> Double -> IO ()
callbackMouseWheel stateRef callbacks _win x _y
 = do   (key, keystate)  <- setMouseWheel stateRef (floor x)
        (GLFWState mods pos _ _ _ _ _) <- readIORef stateRef

        -- Call all the Gloss KeyMouse actions with the new state.
        sequence_
         $ map  (\f -> f key keystate mods pos)
                [f stateRef | KeyMouse f <- callbacks]

setMouseWheel
        :: IORef GLFWState
        -> Int
        -> IO (Key, KeyState)

setMouseWheel stateRef w
 = do   glfwState <- readIORef stateRef
        writeIORef stateRef $ glfwState {mouseWheelPos = w}
        case compare w (mouseWheelPos glfwState) of
                LT -> return (MouseButton WheelDown , Down)
                GT -> return (MouseButton WheelUp   , Down)
                EQ -> return (SpecialKey  KeyUnknown, Up  )


-- Motion Callback ------------------------------------------------------------
-- | Callback for when the user moves the mouse.
installMotionCallbackGLFW
        :: IORef GLFWState -> [Callback]
        -> IO ()

installMotionCallbackGLFW stateRef callbacks
 = do win <- windowHandle stateRef
      GLFW.setCursorPosCallback win (Just $ callbackMotion stateRef callbacks)

--CursorPosCallback = Window -> Double -> Double -> IO ()

callbackMotion
        :: IORef GLFWState -> [Callback]
        -> GLFW.CursorPosCallback
callbackMotion stateRef callbacks _win x y
 = do   pos <- setMousePos stateRef (floor x) (floor y)

        -- Call all the Gloss Motion actions with the new state.
        sequence_
         $ map  (\f -> f pos)
                [f stateRef | Motion f <- callbacks]

setMousePos
        :: IORef GLFWState
        -> Int -> Int
        -> IO (Int, Int)
setMousePos stateRef x y
 = do   let pos = (x,y)

        modifyIORef' stateRef $ \s -> s
                { mousePosition = pos }

        return pos


-- Idle Callback --------------------------------------------------------------
-- | Callback for when GLFW has finished its jobs and it's time for us to do
--   something for our application.
installIdleCallbackGLFW
        :: IORef GLFWState -> [Callback]
        -> IO ()

installIdleCallbackGLFW stateRef callbacks
        = modifyIORef' stateRef $ \s -> s
                { idle = callbackIdle stateRef callbacks }

callbackIdle
        :: IORef GLFWState -> [Callback]
        -> IO ()

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


-- Main Loop ------------------------------------------------------------------

runMainLoopGLFW :: IORef GLFWState -> IO ()
runMainLoopGLFW stateRef = do
        X.catch go handleException
        GLFW.destroyWindow =<< windowHandle stateRef
        GLFW.terminate

    where
        handleException :: X.SomeException -> IO ()
        handleException = print

        clearDirtyFlag :: IO ()
        clearDirtyFlag = modifyIORef'
                                stateRef
                                (\state -> state { dirtyScreen = False })

        display' :: IO ()
        display' = readIORef stateRef >>= display

        idle' :: IO ()
        idle' = readIORef stateRef >>= idle

        swapBuffers' :: IO ()
        swapBuffers' = windowHandle stateRef >>= GLFW.swapBuffers

        windowShouldClose :: IO Bool
        windowShouldClose = windowHandle stateRef >>= GLFW.windowShouldClose

        unlessM :: Monad m => m Bool -> m () -> m ()
        unlessM testAction action = do
                sentinel <- testAction
                unless sentinel action

        go :: IO ()
        go = do
                -- Perform drawing, clear the dirty flag, do idle processing
                display'
                clearDirtyFlag
                idle'

                -- Swap buffers. This swaps the GL buffers and will block
                -- until the next v-sync. In GLFW, this effectively pegs the
                -- maximum frame rate to 60fps, but will also stop the
                -- application from consuming 100% CPU.
                swapBuffers'

                -- Poll for GLFW events; quit if necessary.
                GLFW.pollEvents
                unlessM windowShouldClose go


-- Redisplay ------------------------------------------------------------------
postRedisplayGLFW
        :: IORef GLFWState
        -> IO ()

postRedisplayGLFW stateRef
        = modifyIORef' stateRef $ \s -> s
                { dirtyScreen = True }


-- Key Code Conversion --------------------------------------------------------
class GLFWKey a where
  fromGLFW :: a -> Key

instance GLFWKey GLFW.Key where
  fromGLFW key
   = case key of
        GLFW.Key'A           -> charToSpecial 'a'
        GLFW.Key'B           -> charToSpecial 'b'
        GLFW.Key'C           -> charToSpecial 'c'
        GLFW.Key'D           -> charToSpecial 'd'
        GLFW.Key'E           -> charToSpecial 'e'
        GLFW.Key'F           -> charToSpecial 'f'
        GLFW.Key'G           -> charToSpecial 'g'
        GLFW.Key'H           -> charToSpecial 'h'
        GLFW.Key'I           -> charToSpecial 'i'
        GLFW.Key'J           -> charToSpecial 'j'
        GLFW.Key'K           -> charToSpecial 'k'
        GLFW.Key'L           -> charToSpecial 'l'
        GLFW.Key'M           -> charToSpecial 'm'
        GLFW.Key'N           -> charToSpecial 'n'
        GLFW.Key'O           -> charToSpecial 'o'
        GLFW.Key'P           -> charToSpecial 'p'
        GLFW.Key'Q           -> charToSpecial 'q'
        GLFW.Key'R           -> charToSpecial 'r'
        GLFW.Key'S           -> charToSpecial 's'
        GLFW.Key'T           -> charToSpecial 't'
        GLFW.Key'U           -> charToSpecial 'u'
        GLFW.Key'V           -> charToSpecial 'v'
        GLFW.Key'W           -> charToSpecial 'w'
        GLFW.Key'X           -> charToSpecial 'x'
        GLFW.Key'Y           -> charToSpecial 'y'
        GLFW.Key'Z           -> charToSpecial 'z'
        GLFW.Key'Space       -> SpecialKey KeySpace
        GLFW.Key'Escape      -> SpecialKey KeyEsc
        GLFW.Key'F1          -> SpecialKey KeyF1
        GLFW.Key'F2          -> SpecialKey KeyF2
        GLFW.Key'F3          -> SpecialKey KeyF3
        GLFW.Key'F4          -> SpecialKey KeyF4
        GLFW.Key'F5          -> SpecialKey KeyF5
        GLFW.Key'F6          -> SpecialKey KeyF6
        GLFW.Key'F7          -> SpecialKey KeyF7
        GLFW.Key'F8          -> SpecialKey KeyF8
        GLFW.Key'F9          -> SpecialKey KeyF9
        GLFW.Key'F10         -> SpecialKey KeyF10
        GLFW.Key'F11         -> SpecialKey KeyF11
        GLFW.Key'F12         -> SpecialKey KeyF12
        GLFW.Key'F13         -> SpecialKey KeyF13
        GLFW.Key'F14         -> SpecialKey KeyF14
        GLFW.Key'F15         -> SpecialKey KeyF15
        GLFW.Key'F16         -> SpecialKey KeyF16
        GLFW.Key'F17         -> SpecialKey KeyF17
        GLFW.Key'F18         -> SpecialKey KeyF18
        GLFW.Key'F19         -> SpecialKey KeyF19
        GLFW.Key'F20         -> SpecialKey KeyF20
        GLFW.Key'F21         -> SpecialKey KeyF21
        GLFW.Key'F22         -> SpecialKey KeyF22
        GLFW.Key'F23         -> SpecialKey KeyF23
        GLFW.Key'F24         -> SpecialKey KeyF24
        GLFW.Key'F25         -> SpecialKey KeyF25
        GLFW.Key'Up          -> SpecialKey KeyUp
        GLFW.Key'Down        -> SpecialKey KeyDown
        GLFW.Key'Left        -> SpecialKey KeyLeft
        GLFW.Key'Right       -> SpecialKey KeyRight
        GLFW.Key'Tab         -> SpecialKey KeyTab
        GLFW.Key'Enter       -> SpecialKey KeyEnter
        GLFW.Key'Backspace   -> SpecialKey KeyBackspace
        GLFW.Key'Insert      -> SpecialKey KeyInsert
        GLFW.Key'Delete      -> SpecialKey KeyDelete
        GLFW.Key'PageUp      -> SpecialKey KeyPageUp
        GLFW.Key'PageDown    -> SpecialKey KeyPageDown
        GLFW.Key'Home        -> SpecialKey KeyHome
        GLFW.Key'End         -> SpecialKey KeyEnd
        GLFW.Key'Pad0        -> SpecialKey KeyPad0
        GLFW.Key'Pad1        -> SpecialKey KeyPad1
        GLFW.Key'Pad2        -> SpecialKey KeyPad2
        GLFW.Key'Pad3        -> SpecialKey KeyPad3
        GLFW.Key'Pad4        -> SpecialKey KeyPad4
        GLFW.Key'Pad5        -> SpecialKey KeyPad5
        GLFW.Key'Pad6        -> SpecialKey KeyPad6
        GLFW.Key'Pad7        -> SpecialKey KeyPad7
        GLFW.Key'Pad8        -> SpecialKey KeyPad8
        GLFW.Key'Pad9        -> SpecialKey KeyPad9
        GLFW.Key'PadDivide   -> SpecialKey KeyPadDivide
        GLFW.Key'PadMultiply -> SpecialKey KeyPadMultiply
        GLFW.Key'PadSubtract -> SpecialKey KeyPadSubtract
        GLFW.Key'PadAdd      -> SpecialKey KeyPadAdd
        GLFW.Key'PadDecimal  -> SpecialKey KeyPadDecimal
        GLFW.Key'PadEqual    -> Char '='
        GLFW.Key'PadEnter    -> SpecialKey KeyPadEnter
        _                    -> SpecialKey KeyUnknown


-- | Convert char keys to special keys to work around a bug in
--   GLFW 2.7. On OS X, GLFW sometimes registers special keys as char keys,
--   so we convert them back here.
--   GLFW 2.7 is current as of Nov 2011, and is shipped with the Hackage
--   binding GLFW-b 0.2.*
charToSpecial :: Char -> Key
charToSpecial c = case (fromEnum c) of
        32    -> SpecialKey KeySpace
        63232 -> SpecialKey KeyUp
        63233 -> SpecialKey KeyDown
        63234 -> SpecialKey KeyLeft
        63235 -> SpecialKey KeyRight
        63236 -> SpecialKey KeyF1
        63237 -> SpecialKey KeyF2
        63238 -> SpecialKey KeyF3
        63239 -> SpecialKey KeyF4
        63240 -> SpecialKey KeyF5
        63241 -> SpecialKey KeyF6
        63242 -> SpecialKey KeyF7
        63243 -> SpecialKey KeyF8
        63244 -> SpecialKey KeyF9
        63245 -> SpecialKey KeyF10
        63246 -> SpecialKey KeyF11
        63247 -> SpecialKey KeyF12
        63248 -> SpecialKey KeyF13
        63272 -> SpecialKey KeyDelete
        63273 -> SpecialKey KeyHome
        63275 -> SpecialKey KeyEnd
        63276 -> SpecialKey KeyPageUp
        63277 -> SpecialKey KeyPageDown
        _     -> Char c

instance GLFWKey GLFW.MouseButton where
  fromGLFW mouse
   = case mouse of
        GLFW.MouseButton'1 -> MouseButton LeftButton
        GLFW.MouseButton'2 -> MouseButton RightButton
        GLFW.MouseButton'3 -> MouseButton MiddleButton
        GLFW.MouseButton'4 -> MouseButton $ AdditionalButton 4
        GLFW.MouseButton'5 -> MouseButton $ AdditionalButton 5
        GLFW.MouseButton'6 -> MouseButton $ AdditionalButton 6
        GLFW.MouseButton'7 -> MouseButton $ AdditionalButton 7
        GLFW.MouseButton'8 -> MouseButton $ AdditionalButton 8