brillo-1.13.3: Brillo/Internals/Interface/Backend/GLFW.hs

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

-- | Support for using GLFW as the window manager backend.
module Brillo.Internals.Interface.Backend.GLFW (GLFWState)
where

import Control.Concurrent (threadDelay)
import Control.Exception qualified as X
import Control.Monad (unless, when)
import Data.IORef (IORef, modifyIORef', readIORef, writeIORef)
import Data.Maybe (fromJust)
import Graphics.Rendering.OpenGL (($=))
import Graphics.Rendering.OpenGL qualified as GL
import Graphics.UI.GLFW qualified as GLFW

import Brillo.Internals.Interface.Backend.Types


-- | State of the GLFW backend library.
data GLFWState
  = GLFWState
  { modifiers :: Modifiers
  -- ^ Status of Ctrl, Alt or Shift (Up or Down?)
  , mousePosition :: (Int, Int)
  -- ^ Latest mouse position
  , mouseWheelPos :: Int
  -- ^ Latest mousewheel position
  , dirtyScreen :: Bool
  -- ^ Does the screen need to be redrawn?
  , display :: IO ()
  -- ^ Action that draws on the screen
  , idle :: IO ()
  -- ^ Action perforrmed when idling
  , optWinHdl :: Maybe GLFW.Window
  -- ^ The Window Handle
  }


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

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