content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE OverloadedRecordDot #-}
  {-# 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.Functor ((<&>))
  import Data.IORef (IORef, modifyIORef', readIORef, writeIORef)
  import Data.Maybe (fromJust)
  import Data.Text qualified as T
  import GHC.Desugar ((>>>))
  import Graphics.Rendering.OpenGL (($=))
  import Graphics.Rendering.OpenGL qualified as GL
  import Graphics.UI.GLFW qualified as GLFW
  
  import Brillo.Data.FileDialog (FileDialog (..), SelectionMode (..))
  import Brillo.Internals.Interface.Backend.Types (
    Backend (..),
    Callback (..),
    Display (..),
    Key (..),
    KeyState (..),
    Modifiers (..),
    MouseButton (..),
    SpecialKey (..),
   )
  import Brillo.Internals.TinyFileDialogs as TinyFileDialogs
  import Data.List (singleton)
  
  
  -- | 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
    installDropCallback = installDropCallbackGLFW
    installIdleCallback = installIdleCallbackGLFW
    runMainLoop = runMainLoopGLFW
    postRedisplay = postRedisplayGLFW
    getWindowDimensions ref = windowHandle ref >>= \win -> GLFW.getWindowSize win
    getScreenSize = getScreenSizeGLFW
    openFileDialog = openFileDialogGLFW
    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 $
        putStrLn $
          "  glfwVersion        = " ++ show glfwVersion
  
  
  -- 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
          (T.unpack 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)
  
  
  -- | Open a file dialog. Return `Nothing` if the user cancels the dialog.
  openFileDialogGLFW :: IORef GLFWState -> FileDialog -> IO (Maybe [FilePath])
  openFileDialogGLFW _state fileDialog = do
    case fileDialog.selectionMode of
      SingleDirectorySelect -> do
        dirPathMb <-
          TinyFileDialogs.selectFolderDialog
            fileDialog.title
            fileDialog.defaultPath
  
        return (dirPathMb <&> T.unpack >>> singleton)
      _ -> do
        filePathsMb <-
          TinyFileDialogs.openFileDialog
            fileDialog.title
            fileDialog.defaultPath
            fileDialog.filterPatterns
            fileDialog.filterDescription
            (fileDialog.selectionMode == MultiFileSelect)
  
        return $ filePathsMb <&> (<&> T.unpack)
  
  
  -- 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
  
  
  -- 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 =
    mapM_
      (\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.setDropCallback win (Just $ callbackDrop 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
  
      -- Only process key presses for keys that won't generate character events
      -- or process any key release (since char callback only handles presses)
      let shouldProcess = not keystate || not (isCharacterKey key)
  
      -- Call the Brillo KeyMouse actions with the new state.
      unless (modsSet || isCharKey key' && keystate || not shouldProcess) $
        mapM_
          (\f -> f key' keystate' mods pos)
          ([f stateRef | KeyMouse f <- callbacks])
  
  
  {-| Check if a GLFW key will generate a character callback event
  These are keys that produce printable characters and will trigger both
  key and character callbacks, causing duplicate events
  -}
  isCharacterKey :: GLFW.Key -> Bool
  isCharacterKey key = case key of
    -- Alphabetic keys
    GLFW.Key'A -> True
    GLFW.Key'B -> True
    GLFW.Key'C -> True
    GLFW.Key'D -> True
    GLFW.Key'E -> True
    GLFW.Key'F -> True
    GLFW.Key'G -> True
    GLFW.Key'H -> True
    GLFW.Key'I -> True
    GLFW.Key'J -> True
    GLFW.Key'K -> True
    GLFW.Key'L -> True
    GLFW.Key'M -> True
    GLFW.Key'N -> True
    GLFW.Key'O -> True
    GLFW.Key'P -> True
    GLFW.Key'Q -> True
    GLFW.Key'R -> True
    GLFW.Key'S -> True
    GLFW.Key'T -> True
    GLFW.Key'U -> True
    GLFW.Key'V -> True
    GLFW.Key'W -> True
    GLFW.Key'X -> True
    GLFW.Key'Y -> True
    GLFW.Key'Z -> True
    -- Number keys
    GLFW.Key'0 -> True
    GLFW.Key'1 -> True
    GLFW.Key'2 -> True
    GLFW.Key'3 -> True
    GLFW.Key'4 -> True
    GLFW.Key'5 -> True
    GLFW.Key'6 -> True
    GLFW.Key'7 -> True
    GLFW.Key'8 -> True
    GLFW.Key'9 -> True
    -- Printable symbols
    GLFW.Key'Space -> True
    GLFW.Key'Apostrophe -> True
    GLFW.Key'Comma -> True
    GLFW.Key'Minus -> True
    GLFW.Key'Period -> True
    GLFW.Key'Slash -> True
    GLFW.Key'Semicolon -> True
    GLFW.Key'Equal -> True
    GLFW.Key'LeftBracket -> True
    GLFW.Key'Backslash -> True
    GLFW.Key'RightBracket -> True
    GLFW.Key'GraveAccent -> True
    -- All other keys (function keys, arrows, etc.) don't generate char events
    _ -> False
  
  
  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.
      mapM_
        (\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.
      mapM_
        (\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.
      mapM_
        (\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)
  
  
  -- | GLFW calls this when the user drops files/directories onto the window
  callbackDrop ::
    IORef GLFWState ->
    [Callback] ->
    GLFW.DropCallback
  callbackDrop stateRef callbacks _win paths = do
    mapM_
      (\f -> f paths)
      ([f stateRef | Drop f <- callbacks])
  
  
  -- 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)
  
  
  -- Drop Paths Callback ---------------------------------------------------------
  
  -- | Callback for when the user drops files/directories onto the window.
  installDropCallbackGLFW ::
    IORef GLFWState ->
    [Callback] ->
    IO ()
  installDropCallbackGLFW stateRef callbacks = do
    win <- windowHandle stateRef
    GLFW.setDropCallback win (Just $ callbackDrop 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.
      mapM_
        (\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
  