GLFW.hs

{-# 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 System.Exit (ExitCode)
import System.IO (hPutStrLn, stderr)
import System.Info (os)

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
  , 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)
    , 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
  getDpiScale = getDpiScaleGLFW
  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 =
          hPutStrLn stderr $ 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 ----------------------------------------------------------------

{-| Request an OpenGL 2.1 context.

Brillo's anti-aliased shapes are rendered with @#version 120@ GLSL shaders
that rely on compatibility built-ins (e.g. @gl_ModelViewProjectionMatrix@,
@gl_MultiTexCoord0@, @gl_FragColor@) mixed with immediate-mode drawing.
Without a version hint the context is driver-dependent, and some drivers
(notably on Windows) hand out a context that rejects that mixed path with
@GL_INVALID_OPERATION@. Asking for 2.1 yields a context that is required to
be backwards compatible with it, which avoids that.

No @WindowHint'OpenGLProfile@ is set on purpose:
context profiles are only defined for OpenGL 3.2 and above and GLFW aborts
window creation with @GLFW_INVALID_VALUE@ if one is combined with a lower
version, no matter which platform or driver is used.
-}
setWindowHints :: IO ()
setWindowHints = do
  GLFW.windowHint (GLFW.WindowHint'ContextVersionMajor 2)
  GLFW.windowHint (GLFW.WindowHint'ContextVersionMinor 1)


-- | Describe the last GLFW error, if there was one.
lastGlfwError :: IO String
lastGlfwError = do
  optError <- GLFW.getError
  pure $ case optError of
    Nothing -> ""
    Just (err, msg) -> " (" <> show err <> ": " <> msg <> ")"


{-| Create a window with Brillo's preferred context hints.

If the driver can't provide such a context, 'GLFW.createWindow' returns
'Nothing' instead of falling back on its own.
Retry with GLFW's default hints in that case,
as a suboptimal context is still better than no window at all.
-}
createWindowWithHints ::
  Int ->
  Int ->
  String ->
  Maybe GLFW.Monitor ->
  IO (Maybe GLFW.Window)
createWindowWithHints sizeX sizeY title monitor = do
  GLFW.defaultWindowHints
  setWindowHints
  winWithHints <- GLFW.createWindow sizeX sizeY title monitor Nothing

  case winWithHints of
    Just _ -> pure winWithHints
    Nothing -> do
      errorMsg <- lastGlfwError
      hPutStrLn stderr $
        "Warning: Could not create an OpenGL 2.1 context"
          <> errorMsg
          <> ". Retrying with the driver's default context …"
      GLFW.defaultWindowHints
      GLFW.createWindow sizeX sizeY title monitor Nothing


{-| Move the window, keeping its title bar reachable.

The given position is the upper left corner of the content area,
so a window at @(0, 0)@ would have its title bar above the top edge
of the screen and couldn't be moved by the user anymore.
Push the window down by the height of the title bar in that case.
-}
setWindowPosOnScreen :: GLFW.Window -> Int -> Int -> IO ()
setWindowPosOnScreen win posX posY = do
  -- Left, top, right, and bottom edge of the window's frame
  (_, titleBarHeight, _, _) <- GLFW.getWindowFrameSize win
  GLFW.setWindowPos win posX (max titleBarHeight posY)


-- | Open a new window.
openWindowGLFW ::
  IORef GLFWState ->
  Display ->
  IO ()
openWindowGLFW ref (InWindow title (sizeX, sizeY) pos) =
  do
    win <-
      createWindowWithHints
        sizeX
        sizeY
        (T.unpack title)
        Nothing

    case win of
      Nothing -> do
        errorMsg <- lastGlfwError
        error $
          "GLFW.createWindow failed to create a "
            ++ show sizeX
            ++ "x"
            ++ show sizeY
            ++ " window"
            ++ errorMsg
            ++ ". Check that your GPU drivers support OpenGL."
      Just w -> do
        modifyIORef' ref (\s -> s{optWinHdl = win})
        uncurry (setWindowPosOnScreen 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 <-
              createWindowWithHints
                sizeX
                sizeY
                ""
                mon

            case win of
              Nothing -> do
                errorMsg <- lastGlfwError
                error $
                  "GLFW.createWindow failed to create a fullscreen window"
                    ++ errorMsg
                    ++ ". Check that your GPU drivers support OpenGL."
              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)


{-| The scale factor between window coordinates and logical UI units,
e.g. @1.5@ for a display configured to 150 % scaling.

On macOS window coordinates already are logical points
(only the framebuffer is the high resolution one),
so the factor is always 1 there.
On Windows and X11 window coordinates are physical pixels,
which makes the factor the content scale of the primary monitor.
-}
getDpiScaleGLFW :: IORef GLFWState -> IO Float
getDpiScaleGLFW _state =
  if os == "darwin"
    then pure 1
    else do
      monitorMb <- GLFW.getPrimaryMonitor
      case monitorMb of
        Nothing -> pure 1
        Just monitor -> do
          (scaleX, scaleY) <- GLFW.getMonitorContentScale monitor
          let scale = max scaleX scaleY
          -- Guard against drivers reporting a nonsensical scale
          pure $ if scale > 0 then scale else 1


-- | 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 $ callbackScroll 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{modifiers = mods, mousePosition = 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{modifiers = mods, mousePosition = 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{modifiers = mods, mousePosition = 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 this when the user scrolls with a mouse wheel or a trackpad.
  The offsets are relative to the last scroll event and are passed on as is.
-}
callbackScroll ::
  IORef GLFWState ->
  [Callback] ->
  GLFW.ScrollCallback -- = Window -> Double -> Double -> IO ()
callbackScroll stateRef callbacks _win x y =
  do
    GLFWState{modifiers = mods, mousePosition = pos} <- readIORef stateRef

    -- Call all the Brillo Scroll actions with the new state.
    mapM_
      (\f -> f (x, y) mods pos)
      ([f stateRef | Scroll f <- callbacks])


-- | 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 =
  (go `X.catch` handleException) `X.finally` cleanup
  where
    cleanup :: IO ()
    cleanup = do
      GLFW.destroyWindow =<< windowHandle stateRef
      GLFW.terminate

    -- Report unexpected errors to stderr, but re-throw `ExitCode` so that
    -- `exitSuccess` / `exitFailure` from user code reach GHC's top-level
    -- handler and terminate the program with the intended status. Without
    -- this, those exits were silently swallowed, and since GHC 9.10 the
    -- printed `SomeException` also carried a noisy HasCallStack backtrace.
    handleException :: X.SomeException -> IO ()
    handleException exc
      | Just (ec :: ExitCode) <- X.fromException exc = X.throwIO ec
      | otherwise = hPutStrLn stderr (X.displayException exc)

    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