GLFW.hs

{-# 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.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.Cursor (CursorShape (..))
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)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map


-- | 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
  , cursorCache :: Map CursorShape GLFW.Cursor
  -- ^ Cache of created cursors
  }


-- | 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
    , cursorCache = Map.empty
    }


-- | 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
  installRefreshCallback = installRefreshCallbackGLFW
  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 -> case mt of
      Nothing -> error "GLFW.getTime returned Nothing. Is GLFW initialized?"
      Just t -> return t
  sleep _ sec = threadDelay (floor (sec * 1000000.0)) -- GLFW.sleep sec)
  setCursor = setCursorGLFW


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


-- Cursor ---------------------------------------------------------------------

-- | Set the cursor shape for the GLFW window.
setCursorGLFW :: IORef GLFWState -> CursorShape -> IO ()
setCursorGLFW stateRef shape = do
  state <- readIORef stateRef
  win <- windowHandle stateRef

  case shape of
    CursorHidden -> do
      -- Hide cursor using GLFW's cursor input mode
      GLFW.setCursorInputMode win GLFW.CursorInputMode'Hidden
    _ -> do
      -- Ensure cursor is visible
      GLFW.setCursorInputMode win GLFW.CursorInputMode'Normal

      -- Check if cursor is already cached
      case Map.lookup shape (cursorCache state) of
        Just cursor -> do
          GLFW.setCursor win cursor
        Nothing -> do
          -- Create and cache the cursor
          let stdCursor = cursorShapeToGLFW shape
          cursor <- GLFW.createStandardCursor stdCursor
          -- Cache the cursor for future use
          modifyIORef' stateRef $ \s ->
            s{cursorCache = Map.insert shape cursor (cursorCache s)}
          GLFW.setCursor win cursor


-- | Convert Brillo CursorShape to GLFW StandardCursorShape.
cursorShapeToGLFW :: CursorShape -> GLFW.StandardCursorShape
cursorShapeToGLFW shape = case shape of
  CursorArrow -> GLFW.StandardCursorShape'Arrow
  CursorIBeam -> GLFW.StandardCursorShape'IBeam
  CursorCrosshair -> GLFW.StandardCursorShape'Crosshair
  CursorHand -> GLFW.StandardCursorShape'Hand
  CursorResizeH -> GLFW.StandardCursorShape'HResize
  CursorResizeV -> GLFW.StandardCursorShape'VResize
  CursorHidden -> GLFW.StandardCursorShape'Arrow -- Not used, handled separately


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

    case win of
      Nothing ->
        error $
          "GLFW.createWindow failed to create a "
            ++ show sizeX
            ++ "x"
            ++ show sizeY
            ++ " window."
            ++ " Check that your GPU drivers support OpenGL."
      Just w -> do
        modifyIORef' ref (\s -> s{optWinHdl = win})
        uncurry (GLFW.setWindowPos w) 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
    case mon of
      Nothing ->
        error "GLFW.getPrimaryMonitor returned Nothing. No monitor detected."
      Just m -> do
        vmode <- GLFW.getVideoMode m
        case vmode of
          Nothing ->
            error "GLFW.getVideoMode returned Nothing for primary monitor."
          Just vm -> do
            let sizeX = GLFW.videoModeWidth vm
            let sizeY = GLFW.videoModeHeight vm

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

            case win of
              Nothing ->
                error "GLFW.createWindow failed to create a fullscreen window."
              Just w -> do
                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.setCursorInputMode w 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
  case monitor of
    Nothing ->
      error "GLFW.getPrimaryMonitor returned Nothing. No monitor detected."
    Just m -> do
      vmode <- GLFW.getVideoMode m
      case vmode of
        Nothing ->
          error "GLFW.getVideoMode returned Nothing for primary monitor."
        Just vm -> do
          let sizeX = GLFW.videoModeWidth vm
          let sizeY = GLFW.videoModeHeight vm
          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 stateRef callbacks _win sizeX sizeY =
  -- Call all reshape callbacks (which will update world state, viewport, etc.)
  -- Note: The actual redraw during live resize is handled by callbackRefresh,
  -- since on macOS the window size callback doesn't fire during drag.
  mapM_
    (\f -> f (sizeX, sizeY))
    ([f stateRef | Reshape f <- callbacks])


-- Refresh -----------------------------------------------------------------------

-- | Callback for when the window needs to be refreshed (e.g., during live resize on macOS).
installRefreshCallbackGLFW ::
  IORef GLFWState -> [Callback] -> IO ()
installRefreshCallbackGLFW stateRef callbacks = do
  win <- windowHandle stateRef
  GLFW.setWindowRefreshCallback win (Just $ callbackRefresh stateRef callbacks)


callbackRefresh ::
  IORef GLFWState ->
  [Callback] ->
  GLFW.WindowRefreshCallback -- = Window -> IO ()
callbackRefresh stateRef callbacks win = do
  -- Get the current window size and fire reshape callbacks
  -- This ensures EventResize is sent during live resize on macOS
  (sizeX, sizeY) <- GLFW.getWindowSize win
  mapM_
    (\f -> f (sizeX, sizeY))
    ([f stateRef | Reshape f <- callbacks])

  -- Run idle callbacks to advance simulations/animations
  callbackIdle stateRef callbacks

  -- Redraw and present the frame
  callbackDisplay stateRef callbacks
  GLFW.swapBuffers win


-- 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 GLFW.KeyState'Repeating _modifiers =
  return ()
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