{-# 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
  { GLFWState -> Modifiers
modifiers :: Modifiers
  -- ^ Status of Ctrl, Alt or Shift (Up or Down?)
  , GLFWState -> (Int, Int)
mousePosition :: (Int, Int)
  -- ^ Latest mouse position
  , GLFWState -> Int
mouseWheelPos :: Int
  -- ^ Latest mousewheel position
  , GLFWState -> Bool
dirtyScreen :: Bool
  -- ^ Does the screen need to be redrawn?
  , GLFWState -> IO ()
display :: IO ()
  -- ^ Action that draws on the screen
  , GLFWState -> IO ()
idle :: IO ()
  -- ^ Action perforrmed when idling
  , GLFWState -> Maybe Window
optWinHdl :: Maybe GLFW.Window
  -- ^ The Window Handle
  , GLFWState -> Map CursorShape Cursor
cursorCache :: Map CursorShape GLFW.Cursor
  -- ^ Cache of created cursors
  }


-- | Initial GLFW state.
glfwStateInit :: GLFWState
glfwStateInit :: GLFWState
glfwStateInit =
  GLFWState
    { modifiers :: Modifiers
modifiers = KeyState -> KeyState -> KeyState -> Modifiers
Modifiers KeyState
Up KeyState
Up KeyState
Up
    , mousePosition :: (Int, Int)
mousePosition = (Int
0, Int
0)
    , mouseWheelPos :: Int
mouseWheelPos = Int
0
    , dirtyScreen :: Bool
dirtyScreen = Bool
True
    , display :: IO ()
display = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , idle :: IO ()
idle = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , optWinHdl :: Maybe Window
optWinHdl = Maybe Window
forall a. Maybe a
Nothing
    , cursorCache :: Map CursorShape Cursor
cursorCache = Map CursorShape Cursor
forall k a. Map k a
Map.empty
    }


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


instance Backend GLFWState where
  initBackendState :: GLFWState
initBackendState = GLFWState
glfwStateInit
  initializeBackend :: IORef GLFWState -> Bool -> IO ()
initializeBackend = IORef GLFWState -> Bool -> IO ()
initializeGLFW
  exitBackend :: IORef GLFWState -> IO ()
exitBackend = IORef GLFWState -> IO ()
exitGLFW
  openWindow :: IORef GLFWState -> Display -> IO ()
openWindow = IORef GLFWState -> Display -> IO ()
openWindowGLFW
  dumpBackendState :: IORef GLFWState -> IO ()
dumpBackendState = IORef GLFWState -> IO ()
dumpStateGLFW
  installDisplayCallback :: IORef GLFWState -> [Callback] -> IO ()
installDisplayCallback = IORef GLFWState -> [Callback] -> IO ()
installDisplayCallbackGLFW
  installWindowCloseCallback :: IORef GLFWState -> IO ()
installWindowCloseCallback = IORef GLFWState -> IO ()
installWindowCloseCallbackGLFW
  installReshapeCallback :: IORef GLFWState -> [Callback] -> IO ()
installReshapeCallback = IORef GLFWState -> [Callback] -> IO ()
installReshapeCallbackGLFW
  installRefreshCallback :: IORef GLFWState -> [Callback] -> IO ()
installRefreshCallback = IORef GLFWState -> [Callback] -> IO ()
installRefreshCallbackGLFW
  installKeyMouseCallback :: IORef GLFWState -> [Callback] -> IO ()
installKeyMouseCallback = IORef GLFWState -> [Callback] -> IO ()
installKeyMouseCallbackGLFW
  installMotionCallback :: IORef GLFWState -> [Callback] -> IO ()
installMotionCallback = IORef GLFWState -> [Callback] -> IO ()
installMotionCallbackGLFW
  installDropCallback :: IORef GLFWState -> [Callback] -> IO ()
installDropCallback = IORef GLFWState -> [Callback] -> IO ()
installDropCallbackGLFW
  installIdleCallback :: IORef GLFWState -> [Callback] -> IO ()
installIdleCallback = IORef GLFWState -> [Callback] -> IO ()
installIdleCallbackGLFW
  runMainLoop :: IORef GLFWState -> IO ()
runMainLoop = IORef GLFWState -> IO ()
runMainLoopGLFW
  postRedisplay :: IORef GLFWState -> IO ()
postRedisplay = IORef GLFWState -> IO ()
postRedisplayGLFW
  getWindowDimensions :: IORef GLFWState -> IO (Int, Int)
getWindowDimensions IORef GLFWState
ref = IORef GLFWState -> IO Window
windowHandle IORef GLFWState
ref IO Window -> (Window -> IO (Int, Int)) -> IO (Int, Int)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Window
win -> Window -> IO (Int, Int)
GLFW.getWindowSize Window
win
  getScreenSize :: IORef GLFWState -> IO (Int, Int)
getScreenSize = IORef GLFWState -> IO (Int, Int)
getScreenSizeGLFW
  openFileDialog :: IORef GLFWState -> FileDialog -> IO (Maybe [String])
openFileDialog = IORef GLFWState -> FileDialog -> IO (Maybe [String])
openFileDialogGLFW
  elapsedTime :: IORef GLFWState -> IO Double
elapsedTime IORef GLFWState
_ =
    IO (Maybe Double)
GLFW.getTime IO (Maybe Double) -> (Maybe Double -> IO Double) -> IO Double
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe Double
mt -> case Maybe Double
mt of
      Maybe Double
Nothing -> String -> IO Double
forall a. HasCallStack => String -> a
error String
"GLFW.getTime returned Nothing. Is GLFW initialized?"
      Just Double
t -> Double -> IO Double
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Double
t
  sleep :: IORef GLFWState -> Double -> IO ()
sleep IORef GLFWState
_ Double
sec = Int -> IO ()
threadDelay (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
sec Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000000.0)) -- GLFW.sleep sec)
  setCursor :: IORef GLFWState -> CursorShape -> IO ()
setCursor = IORef GLFWState -> CursorShape -> IO ()
setCursorGLFW


-- Initialise -----------------------------------------------------------------

-- | Initialise the GLFW backend.
initializeGLFW :: IORef GLFWState -> Bool -> IO ()
initializeGLFW :: IORef GLFWState -> Bool -> IO ()
initializeGLFW IORef GLFWState
_ Bool
debug =
  do
    let simpleErrorCallback :: a -> a -> IO ()
simpleErrorCallback a
e a
s =
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"GLFW backend: ", a -> String
forall a. Show a => a -> String
show a
e, a -> String
forall a. Show a => a -> String
show a
s]
    Maybe ErrorCallback -> IO ()
GLFW.setErrorCallback (ErrorCallback -> Maybe ErrorCallback
forall a. a -> Maybe a
Just ErrorCallback
forall {a} {a}. (Show a, Show a) => a -> a -> IO ()
simpleErrorCallback)

    Bool
_ <- IO Bool
GLFW.init
    Version
glfwVersion <- IO Version
GLFW.getVersion

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"  glfwVersion        = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Show a => a -> String
show Version
glfwVersion


-- Exit -----------------------------------------------------------------------

-- | Tell the GLFW backend to close the window and exit.
exitGLFW :: IORef GLFWState -> IO ()
exitGLFW :: IORef GLFWState -> IO ()
exitGLFW IORef GLFWState
ref = do
  Window
win <- IORef GLFWState -> IO Window
windowHandle IORef GLFWState
ref
  Window -> Bool -> IO ()
GLFW.setWindowShouldClose Window
win Bool
True


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

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

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

      -- Check if cursor is already cached
      case CursorShape -> Map CursorShape Cursor -> Maybe Cursor
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CursorShape
shape (GLFWState -> Map CursorShape Cursor
cursorCache GLFWState
state) of
        Just Cursor
cursor -> do
          Window -> Cursor -> IO ()
GLFW.setCursor Window
win Cursor
cursor
        Maybe Cursor
Nothing -> do
          -- Create and cache the cursor
          let stdCursor :: StandardCursorShape
stdCursor = CursorShape -> StandardCursorShape
cursorShapeToGLFW CursorShape
shape
          Cursor
cursor <- StandardCursorShape -> IO Cursor
GLFW.createStandardCursor StandardCursorShape
stdCursor
          -- Cache the cursor for future use
          IORef GLFWState -> (GLFWState -> GLFWState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef GLFWState
stateRef ((GLFWState -> GLFWState) -> IO ())
-> (GLFWState -> GLFWState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GLFWState
s ->
            GLFWState
s{cursorCache = Map.insert shape cursor (cursorCache s)}
          Window -> Cursor -> IO ()
GLFW.setCursor Window
win Cursor
cursor


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


-- Open Window ----------------------------------------------------------------

-- | Open a new window.
openWindowGLFW ::
  IORef GLFWState ->
  Display ->
  IO ()
openWindowGLFW :: IORef GLFWState -> Display -> IO ()
openWindowGLFW IORef GLFWState
ref (InWindow Text
title (Int
sizeX, Int
sizeY) (Int, Int)
pos) =
  do
    Maybe Window
win <-
      Int
-> Int
-> String
-> Maybe Monitor
-> Maybe Window
-> IO (Maybe Window)
GLFW.createWindow
        Int
sizeX
        Int
sizeY
        (Text -> String
T.unpack Text
title)
        Maybe Monitor
forall a. Maybe a
Nothing
        Maybe Window
forall a. Maybe a
Nothing

    case Maybe Window
win of
      Maybe Window
Nothing ->
        String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"GLFW.createWindow failed to create a "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sizeX
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"x"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sizeY
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" window."
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Check that your GPU drivers support OpenGL."
      Just Window
w -> do
        IORef GLFWState -> (GLFWState -> GLFWState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef GLFWState
ref (\GLFWState
s -> GLFWState
s{optWinHdl = win})
        (Int -> Int -> IO ()) -> (Int, Int) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Window -> Int -> Int -> IO ()
GLFW.setWindowPos Window
w) (Int, Int)
pos
        Maybe Window -> IO ()
GLFW.makeContextCurrent Maybe Window
win

        -- Try to enable sync-to-vertical-refresh by setting the number
        -- of buffer swaps per vertical refresh to 1.
        Int -> IO ()
GLFW.swapInterval Int
1
openWindowGLFW IORef GLFWState
ref Display
FullScreen =
  do
    Maybe Monitor
mon <- IO (Maybe Monitor)
GLFW.getPrimaryMonitor
    case Maybe Monitor
mon of
      Maybe Monitor
Nothing ->
        String -> IO ()
forall a. HasCallStack => String -> a
error String
"GLFW.getPrimaryMonitor returned Nothing. No monitor detected."
      Just Monitor
m -> do
        Maybe VideoMode
vmode <- Monitor -> IO (Maybe VideoMode)
GLFW.getVideoMode Monitor
m
        case Maybe VideoMode
vmode of
          Maybe VideoMode
Nothing ->
            String -> IO ()
forall a. HasCallStack => String -> a
error String
"GLFW.getVideoMode returned Nothing for primary monitor."
          Just VideoMode
vm -> do
            let sizeX :: Int
sizeX = VideoMode -> Int
GLFW.videoModeWidth VideoMode
vm
            let sizeY :: Int
sizeY = VideoMode -> Int
GLFW.videoModeHeight VideoMode
vm

            Maybe Window
win <-
              Int
-> Int
-> String
-> Maybe Monitor
-> Maybe Window
-> IO (Maybe Window)
GLFW.createWindow
                Int
sizeX
                Int
sizeY
                String
""
                Maybe Monitor
mon
                Maybe Window
forall a. Maybe a
Nothing

            case Maybe Window
win of
              Maybe Window
Nothing ->
                String -> IO ()
forall a. HasCallStack => String -> a
error String
"GLFW.createWindow failed to create a fullscreen window."
              Just Window
w -> do
                IORef GLFWState -> (GLFWState -> GLFWState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef GLFWState
ref (\GLFWState
s -> GLFWState
s{optWinHdl = win})
                Maybe Window -> IO ()
GLFW.makeContextCurrent Maybe Window
win

                -- Try to enable sync-to-vertical-refresh by setting the number
                -- of buffer swaps per vertical refresh to 1.
                Int -> IO ()
GLFW.swapInterval Int
1
                Window -> CursorInputMode -> IO ()
GLFW.setCursorInputMode Window
w CursorInputMode
GLFW.CursorInputMode'Normal


windowHandle :: IORef GLFWState -> IO GLFW.Window
windowHandle :: IORef GLFWState -> IO Window
windowHandle IORef GLFWState
ref =
  do
    GLFWState
s <- IORef GLFWState -> IO GLFWState
forall a. IORef a -> IO a
readIORef IORef GLFWState
ref
    Window -> IO Window
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Window -> IO Window) -> Window -> IO Window
forall a b. (a -> b) -> a -> b
$ GLFWState -> Window
winHdl GLFWState
s


getScreenSizeGLFW :: IORef GLFWState -> IO (Int, Int)
getScreenSizeGLFW :: IORef GLFWState -> IO (Int, Int)
getScreenSizeGLFW IORef GLFWState
_state = do
  Maybe Monitor
monitor <- IO (Maybe Monitor)
GLFW.getPrimaryMonitor
  case Maybe Monitor
monitor of
    Maybe Monitor
Nothing ->
      String -> IO (Int, Int)
forall a. HasCallStack => String -> a
error String
"GLFW.getPrimaryMonitor returned Nothing. No monitor detected."
    Just Monitor
m -> do
      Maybe VideoMode
vmode <- Monitor -> IO (Maybe VideoMode)
GLFW.getVideoMode Monitor
m
      case Maybe VideoMode
vmode of
        Maybe VideoMode
Nothing ->
          String -> IO (Int, Int)
forall a. HasCallStack => String -> a
error String
"GLFW.getVideoMode returned Nothing for primary monitor."
        Just VideoMode
vm -> do
          let sizeX :: Int
sizeX = VideoMode -> Int
GLFW.videoModeWidth VideoMode
vm
          let sizeY :: Int
sizeY = VideoMode -> Int
GLFW.videoModeHeight VideoMode
vm
          (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
sizeX, Int
sizeY)


-- | Open a file dialog. Return `Nothing` if the user cancels the dialog.
openFileDialogGLFW :: IORef GLFWState -> FileDialog -> IO (Maybe [FilePath])
openFileDialogGLFW :: IORef GLFWState -> FileDialog -> IO (Maybe [String])
openFileDialogGLFW IORef GLFWState
_state FileDialog
fileDialog = do
  case FileDialog
fileDialog.selectionMode of
    SelectionMode
SingleDirectorySelect -> do
      Maybe Text
dirPathMb <-
        Text -> Text -> IO (Maybe Text)
TinyFileDialogs.selectFolderDialog
          FileDialog
fileDialog.title
          FileDialog
fileDialog.defaultPath

      Maybe [String] -> IO (Maybe [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text
dirPathMb Maybe Text -> (Text -> [String]) -> Maybe [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> String
T.unpack (Text -> String) -> (String -> [String]) -> Text -> [String]
forall a b c. (a -> b) -> (b -> c) -> a -> c
forall (arr :: * -> * -> *) a b c.
Arrow arr =>
arr a b -> arr b c -> arr a c
>>> String -> [String]
forall a. a -> [a]
singleton)
    SelectionMode
_ -> do
      Maybe [Text]
filePathsMb <-
        Text -> Text -> [Text] -> Text -> Bool -> IO (Maybe [Text])
TinyFileDialogs.openFileDialog
          FileDialog
fileDialog.title
          FileDialog
fileDialog.defaultPath
          FileDialog
fileDialog.filterPatterns
          FileDialog
fileDialog.filterDescription
          (FileDialog
fileDialog.selectionMode SelectionMode -> SelectionMode -> Bool
forall a. Eq a => a -> a -> Bool
== SelectionMode
MultiFileSelect)

      Maybe [String] -> IO (Maybe [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [String] -> IO (Maybe [String]))
-> Maybe [String] -> IO (Maybe [String])
forall a b. (a -> b) -> a -> b
$ Maybe [Text]
filePathsMb Maybe [Text] -> ([Text] -> [String]) -> Maybe [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ([Text] -> (Text -> String) -> [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Text -> String
T.unpack)


-- Dump State -----------------------------------------------------------------

-- | Print out the internal GLFW state.
dumpStateGLFW :: IORef GLFWState -> IO ()
dumpStateGLFW :: IORef GLFWState -> IO ()
dumpStateGLFW IORef GLFWState
ref =
  do
    Window
win <- IORef GLFWState -> IO Window
windowHandle IORef GLFWState
ref
    (Int
ww, Int
wh) <- Window -> IO (Int, Int)
GLFW.getWindowSize Window
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"
    -}

    String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"* dumpGlfwState\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" windowWidth  = "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ww
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" windowHeight = "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
wh
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"


-- Display Callback -----------------------------------------------------------

-- | Callback for when GLFW needs us to redraw the contents of the window.
installDisplayCallbackGLFW ::
  IORef GLFWState -> [Callback] -> IO ()
installDisplayCallbackGLFW :: IORef GLFWState -> [Callback] -> IO ()
installDisplayCallbackGLFW IORef GLFWState
stateRef [Callback]
callbacks =
  IORef GLFWState -> (GLFWState -> GLFWState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef GLFWState
stateRef ((GLFWState -> GLFWState) -> IO ())
-> (GLFWState -> GLFWState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GLFWState
s ->
    GLFWState
s
      { display = callbackDisplay stateRef callbacks
      }


callbackDisplay ::
  IORef GLFWState ->
  [Callback] ->
  IO ()
callbackDisplay :: IORef GLFWState -> [Callback] -> IO ()
callbackDisplay IORef GLFWState
stateRef [Callback]
callbacks = do
  -- clear the display
  [ClearBuffer] -> IO ()
GL.clear [ClearBuffer
GL.ColorBuffer, ClearBuffer
GL.DepthBuffer]
  Color4 GLfloat -> IO ()
forall a. Color a => a -> IO ()
GL.color (Color4 GLfloat -> IO ()) -> Color4 GLfloat -> IO ()
forall a b. (a -> b) -> a -> b
$ GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat
forall a. a -> a -> a -> a -> Color4 a
GL.Color4 GLfloat
0 GLfloat
0 GLfloat
0 (GLfloat
1 :: GL.GLfloat)

  -- set the OpenGL viewport to account for any HiDPI discrepancy
  (Int
width, Int
height) <- IORef GLFWState -> IO Window
windowHandle IORef GLFWState
stateRef IO Window -> (Window -> IO (Int, Int)) -> IO (Int, Int)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Window -> IO (Int, Int)
GLFW.getFramebufferSize
  StateVar (Position, Size)
GL.viewport
    StateVar (Position, Size) -> (Position, Size) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar (Position, Size) -> (Position, Size) -> m ()
$= ( GLint -> GLint -> Position
GL.Position GLint
0 GLint
0
       , GLint -> GLint -> Size
GL.Size (Int -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width) (Int -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height)
       )

  -- get the display callbacks from the chain
  let funs :: [IO ()]
funs = [IORef GLFWState -> IO ()
DisplayCallback
f IORef GLFWState
stateRef | (Display DisplayCallback
f) <- [Callback]
callbacks]
  [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
funs


-- Close Callback -------------------------------------------------------------

{-| Callback for when the user closes the window.
  We can do some cleanup here.
-}
installWindowCloseCallbackGLFW ::
  IORef GLFWState -> IO ()
installWindowCloseCallbackGLFW :: IORef GLFWState -> IO ()
installWindowCloseCallbackGLFW IORef GLFWState
ref =
  do
    Window
win <- IORef GLFWState -> IO Window
windowHandle IORef GLFWState
ref
    Window -> Maybe WindowCloseCallback -> IO ()
GLFW.setWindowCloseCallback Window
win (WindowCloseCallback -> Maybe WindowCloseCallback
forall a. a -> Maybe a
Just WindowCloseCallback
winClosed)
  where
    winClosed :: GLFW.WindowCloseCallback
    winClosed :: WindowCloseCallback
winClosed Window
_win = do
      () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- Reshape --------------------------------------------------------------------

-- | Callback for when the user reshapes the window.
installReshapeCallbackGLFW ::
  IORef GLFWState -> [Callback] -> IO ()
installReshapeCallbackGLFW :: IORef GLFWState -> [Callback] -> IO ()
installReshapeCallbackGLFW IORef GLFWState
stateRef [Callback]
callbacks =
  do
    Window
win <- IORef GLFWState -> IO Window
windowHandle IORef GLFWState
stateRef
    Window -> Maybe (Window -> Int -> Int -> IO ()) -> IO ()
GLFW.setWindowSizeCallback Window
win ((Window -> Int -> Int -> IO ())
-> Maybe (Window -> Int -> Int -> IO ())
forall a. a -> Maybe a
Just ((Window -> Int -> Int -> IO ())
 -> Maybe (Window -> Int -> Int -> IO ()))
-> (Window -> Int -> Int -> IO ())
-> Maybe (Window -> Int -> Int -> IO ())
forall a b. (a -> b) -> a -> b
$ IORef GLFWState -> [Callback] -> Window -> Int -> Int -> IO ()
callbackReshape IORef GLFWState
stateRef [Callback]
callbacks)


callbackReshape ::
  IORef GLFWState ->
  [Callback] ->
  GLFW.WindowSizeCallback -- = Window -> Int -> Int -> IO ()
callbackReshape :: IORef GLFWState -> [Callback] -> Window -> Int -> Int -> IO ()
callbackReshape IORef GLFWState
stateRef [Callback]
callbacks Window
_win Int
sizeX Int
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.
  (((Int, Int) -> IO ()) -> IO ()) -> [(Int, Int) -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    (\(Int, Int) -> IO ()
f -> (Int, Int) -> IO ()
f (Int
sizeX, Int
sizeY))
    ([IORef GLFWState -> (Int, Int) -> IO ()
ReshapeCallback
f IORef GLFWState
stateRef | Reshape ReshapeCallback
f <- [Callback]
callbacks])


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

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


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

  -- Run idle callbacks to advance simulations/animations
  IORef GLFWState -> [Callback] -> IO ()
callbackIdle IORef GLFWState
stateRef [Callback]
callbacks

  -- Redraw and present the frame
  IORef GLFWState -> [Callback] -> IO ()
callbackDisplay IORef GLFWState
stateRef [Callback]
callbacks
  WindowCloseCallback
GLFW.swapBuffers Window
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 :: IORef GLFWState -> [Callback] -> IO ()
installKeyMouseCallbackGLFW IORef GLFWState
stateRef [Callback]
callbacks =
  do
    Window
win <- IORef GLFWState -> IO Window
windowHandle IORef GLFWState
stateRef
    Window -> Maybe KeyCallback -> IO ()
GLFW.setKeyCallback Window
win (KeyCallback -> Maybe KeyCallback
forall a. a -> Maybe a
Just (KeyCallback -> Maybe KeyCallback)
-> KeyCallback -> Maybe KeyCallback
forall a b. (a -> b) -> a -> b
$ IORef GLFWState -> [Callback] -> KeyCallback
callbackKeyboard IORef GLFWState
stateRef [Callback]
callbacks)
    Window -> Maybe CharCallback -> IO ()
GLFW.setCharCallback Window
win (CharCallback -> Maybe CharCallback
forall a. a -> Maybe a
Just (CharCallback -> Maybe CharCallback)
-> CharCallback -> Maybe CharCallback
forall a b. (a -> b) -> a -> b
$ IORef GLFWState -> [Callback] -> CharCallback
callbackChar IORef GLFWState
stateRef [Callback]
callbacks)
    Window -> Maybe MouseButtonCallback -> IO ()
GLFW.setMouseButtonCallback Window
win (MouseButtonCallback -> Maybe MouseButtonCallback
forall a. a -> Maybe a
Just (MouseButtonCallback -> Maybe MouseButtonCallback)
-> MouseButtonCallback -> Maybe MouseButtonCallback
forall a b. (a -> b) -> a -> b
$ IORef GLFWState -> [Callback] -> MouseButtonCallback
callbackMouseButton IORef GLFWState
stateRef [Callback]
callbacks)
    Window -> Maybe ScrollCallback -> IO ()
GLFW.setScrollCallback Window
win (ScrollCallback -> Maybe ScrollCallback
forall a. a -> Maybe a
Just (ScrollCallback -> Maybe ScrollCallback)
-> ScrollCallback -> Maybe ScrollCallback
forall a b. (a -> b) -> a -> b
$ IORef GLFWState -> [Callback] -> ScrollCallback
callbackMouseWheel IORef GLFWState
stateRef [Callback]
callbacks)
    Window -> Maybe DropCallback -> IO ()
GLFW.setDropCallback Window
win (DropCallback -> Maybe DropCallback
forall a. a -> Maybe a
Just (DropCallback -> Maybe DropCallback)
-> DropCallback -> Maybe DropCallback
forall a b. (a -> b) -> a -> b
$ IORef GLFWState -> [Callback] -> DropCallback
callbackDrop IORef GLFWState
stateRef [Callback]
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 :: IORef GLFWState -> [Callback] -> KeyCallback
callbackKeyboard IORef GLFWState
_stateRef [Callback]
_callbacks Window
_win Key
_key Int
_scancode KeyState
GLFW.KeyState'Repeating ModifierKeys
_modifiers =
  () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
callbackKeyboard IORef GLFWState
stateRef [Callback]
callbacks Window
_win Key
key Int
_scancode KeyState
keystateglfw ModifierKeys
_modifiers =
  do
    let keystate :: Bool
keystate = KeyState
keystateglfw KeyState -> KeyState -> Bool
forall a. Eq a => a -> a -> Bool
== KeyState
GLFW.KeyState'Pressed
    (Bool
modsSet, GLFWState Modifiers
mods (Int, Int)
pos Int
_ Bool
_ IO ()
_ IO ()
_ Maybe Window
_ Map CursorShape Cursor
_) <-
      IORef GLFWState -> Key -> Bool -> IO (Bool, GLFWState)
setModifiers IORef GLFWState
stateRef Key
key Bool
keystate
    let key' :: Key
key' = Key -> Key
forall a. GLFWKey a => a -> Key
fromGLFW Key
key
    let keystate' :: KeyState
keystate' = if Bool
keystate then KeyState
Down else KeyState
Up
    let isCharKey :: Key -> Bool
isCharKey (Char Char
_) = Bool
True
        isCharKey Key
_ = Bool
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 :: Bool
shouldProcess = Bool -> Bool
not Bool
keystate Bool -> Bool -> Bool
|| Bool -> Bool
not (Key -> Bool
isCharacterKey Key
key)

    -- Call the Brillo KeyMouse actions with the new state.
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
modsSet Bool -> Bool -> Bool
|| Key -> Bool
isCharKey Key
key' Bool -> Bool -> Bool
&& Bool
keystate Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
shouldProcess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      ((Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()) -> IO ())
-> [Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
        (\Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
f -> Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
f Key
key' KeyState
keystate' Modifiers
mods (Int, Int)
pos)
        ([IORef GLFWState
-> Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
KeyboardMouseCallback
f IORef GLFWState
stateRef | KeyMouse KeyboardMouseCallback
f <- [Callback]
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 -> Bool
isCharacterKey Key
key = case Key
key of
  -- Alphabetic keys
  Key
GLFW.Key'A -> Bool
True
  Key
GLFW.Key'B -> Bool
True
  Key
GLFW.Key'C -> Bool
True
  Key
GLFW.Key'D -> Bool
True
  Key
GLFW.Key'E -> Bool
True
  Key
GLFW.Key'F -> Bool
True
  Key
GLFW.Key'G -> Bool
True
  Key
GLFW.Key'H -> Bool
True
  Key
GLFW.Key'I -> Bool
True
  Key
GLFW.Key'J -> Bool
True
  Key
GLFW.Key'K -> Bool
True
  Key
GLFW.Key'L -> Bool
True
  Key
GLFW.Key'M -> Bool
True
  Key
GLFW.Key'N -> Bool
True
  Key
GLFW.Key'O -> Bool
True
  Key
GLFW.Key'P -> Bool
True
  Key
GLFW.Key'Q -> Bool
True
  Key
GLFW.Key'R -> Bool
True
  Key
GLFW.Key'S -> Bool
True
  Key
GLFW.Key'T -> Bool
True
  Key
GLFW.Key'U -> Bool
True
  Key
GLFW.Key'V -> Bool
True
  Key
GLFW.Key'W -> Bool
True
  Key
GLFW.Key'X -> Bool
True
  Key
GLFW.Key'Y -> Bool
True
  Key
GLFW.Key'Z -> Bool
True
  -- Number keys
  Key
GLFW.Key'0 -> Bool
True
  Key
GLFW.Key'1 -> Bool
True
  Key
GLFW.Key'2 -> Bool
True
  Key
GLFW.Key'3 -> Bool
True
  Key
GLFW.Key'4 -> Bool
True
  Key
GLFW.Key'5 -> Bool
True
  Key
GLFW.Key'6 -> Bool
True
  Key
GLFW.Key'7 -> Bool
True
  Key
GLFW.Key'8 -> Bool
True
  Key
GLFW.Key'9 -> Bool
True
  -- Printable symbols
  Key
GLFW.Key'Space -> Bool
True
  Key
GLFW.Key'Apostrophe -> Bool
True
  Key
GLFW.Key'Comma -> Bool
True
  Key
GLFW.Key'Minus -> Bool
True
  Key
GLFW.Key'Period -> Bool
True
  Key
GLFW.Key'Slash -> Bool
True
  Key
GLFW.Key'Semicolon -> Bool
True
  Key
GLFW.Key'Equal -> Bool
True
  Key
GLFW.Key'LeftBracket -> Bool
True
  Key
GLFW.Key'Backslash -> Bool
True
  Key
GLFW.Key'RightBracket -> Bool
True
  Key
GLFW.Key'GraveAccent -> Bool
True
  -- All other keys (function keys, arrows, etc.) don't generate char events
  Key
_ -> Bool
False


setModifiers ::
  IORef GLFWState ->
  GLFW.Key ->
  Bool ->
  IO (Bool, GLFWState)
setModifiers :: IORef GLFWState -> Key -> Bool -> IO (Bool, GLFWState)
setModifiers IORef GLFWState
stateRef Key
key Bool
pressed =
  do
    GLFWState
glfwState <- IORef GLFWState -> IO GLFWState
forall a. IORef a -> IO a
readIORef IORef GLFWState
stateRef
    let mods :: Modifiers
mods = GLFWState -> Modifiers
modifiers GLFWState
glfwState
    let mods' :: Modifiers
mods' = case Key
key of
          Key
GLFW.Key'LeftShift -> Modifiers
mods{shift = if pressed then Down else Up}
          Key
GLFW.Key'LeftControl -> Modifiers
mods{ctrl = if pressed then Down else Up}
          Key
GLFW.Key'LeftAlt -> Modifiers
mods{alt = if pressed then Down else Up}
          Key
_ -> Modifiers
mods

    if Modifiers
mods' Modifiers -> Modifiers -> Bool
forall a. Eq a => a -> a -> Bool
/= Modifiers
mods
      then do
        let glfwState' :: GLFWState
glfwState' = GLFWState
glfwState{modifiers = mods'}
        IORef GLFWState -> GLFWState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef GLFWState
stateRef GLFWState
glfwState'
        (Bool, GLFWState) -> IO (Bool, GLFWState)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, GLFWState
glfwState')
      else (Bool, GLFWState) -> IO (Bool, GLFWState)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, GLFWState
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 :: IORef GLFWState -> [Callback] -> CharCallback
callbackChar IORef GLFWState
stateRef [Callback]
callbacks Window
_win Char
char -- keystate
  =
  do
    (GLFWState Modifiers
mods (Int, Int)
pos Int
_ Bool
_ IO ()
_ IO ()
_ Maybe Window
_ Map CursorShape Cursor
_) <- IORef GLFWState -> IO GLFWState
forall a. IORef a -> IO a
readIORef IORef GLFWState
stateRef
    let key' :: Key
key' = Char -> Key
charToSpecial Char
char
    -- TODO: is this correct? GLFW does not provide the keystate
    -- in a character callback, here we asume that its pressed
    let keystate :: Bool
keystate = Bool
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' :: KeyState
keystate' = if Bool
keystate then KeyState
Down else KeyState
Up

    -- Call all the Brillo KeyMouse actions with the new state.
    ((Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()) -> IO ())
-> [Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
      (\Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
f -> Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
f Key
key' KeyState
keystate' Modifiers
mods (Int, Int)
pos)
      ([IORef GLFWState
-> Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
KeyboardMouseCallback
f IORef GLFWState
stateRef | KeyMouse KeyboardMouseCallback
f <- [Callback]
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 :: IORef GLFWState -> [Callback] -> MouseButtonCallback
callbackMouseButton IORef GLFWState
stateRef [Callback]
callbacks Window
_win MouseButton
key MouseButtonState
keystate ModifierKeys
_modifier =
  do
    (GLFWState Modifiers
mods (Int, Int)
pos Int
_ Bool
_ IO ()
_ IO ()
_ Maybe Window
_ Map CursorShape Cursor
_) <- IORef GLFWState -> IO GLFWState
forall a. IORef a -> IO a
readIORef IORef GLFWState
stateRef
    let key' :: Key
key' = MouseButton -> Key
forall a. GLFWKey a => a -> Key
fromGLFW MouseButton
key
    let keystate' :: KeyState
keystate' = if MouseButtonState
keystate MouseButtonState -> MouseButtonState -> Bool
forall a. Eq a => a -> a -> Bool
== MouseButtonState
GLFW.MouseButtonState'Pressed then KeyState
Down else KeyState
Up

    -- Call all the Brillo KeyMouse actions with the new state.
    ((Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()) -> IO ())
-> [Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
      (\Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
f -> Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
f Key
key' KeyState
keystate' Modifiers
mods (Int, Int)
pos)
      ([IORef GLFWState
-> Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
KeyboardMouseCallback
f IORef GLFWState
stateRef | KeyMouse KeyboardMouseCallback
f <- [Callback]
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 :: IORef GLFWState -> [Callback] -> ScrollCallback
callbackMouseWheel IORef GLFWState
stateRef [Callback]
callbacks Window
_win Double
x Double
_y =
  do
    (Key
key, KeyState
keystate) <- IORef GLFWState -> Int -> IO (Key, KeyState)
setMouseWheel IORef GLFWState
stateRef (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
x)
    (GLFWState Modifiers
mods (Int, Int)
pos Int
_ Bool
_ IO ()
_ IO ()
_ Maybe Window
_ Map CursorShape Cursor
_) <- IORef GLFWState -> IO GLFWState
forall a. IORef a -> IO a
readIORef IORef GLFWState
stateRef

    -- Call all the Brillo KeyMouse actions with the new state.
    ((Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()) -> IO ())
-> [Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
      (\Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
f -> Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
f Key
key KeyState
keystate Modifiers
mods (Int, Int)
pos)
      ([IORef GLFWState
-> Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
KeyboardMouseCallback
f IORef GLFWState
stateRef | KeyMouse KeyboardMouseCallback
f <- [Callback]
callbacks])


setMouseWheel ::
  IORef GLFWState ->
  Int ->
  IO (Key, KeyState)
setMouseWheel :: IORef GLFWState -> Int -> IO (Key, KeyState)
setMouseWheel IORef GLFWState
stateRef Int
w =
  do
    GLFWState
glfwState <- IORef GLFWState -> IO GLFWState
forall a. IORef a -> IO a
readIORef IORef GLFWState
stateRef
    IORef GLFWState -> GLFWState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef GLFWState
stateRef (GLFWState -> IO ()) -> GLFWState -> IO ()
forall a b. (a -> b) -> a -> b
$ GLFWState
glfwState{mouseWheelPos = w}
    case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
w (GLFWState -> Int
mouseWheelPos GLFWState
glfwState) of
      Ordering
LT -> (Key, KeyState) -> IO (Key, KeyState)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MouseButton -> Key
MouseButton MouseButton
WheelDown, KeyState
Down)
      Ordering
GT -> (Key, KeyState) -> IO (Key, KeyState)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MouseButton -> Key
MouseButton MouseButton
WheelUp, KeyState
Down)
      Ordering
EQ -> (Key, KeyState) -> IO (Key, KeyState)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SpecialKey -> Key
SpecialKey SpecialKey
KeyUnknown, KeyState
Up)


-- | GLFW calls this when the user drops files/directories onto the window
callbackDrop ::
  IORef GLFWState ->
  [Callback] ->
  GLFW.DropCallback
callbackDrop :: IORef GLFWState -> [Callback] -> DropCallback
callbackDrop IORef GLFWState
stateRef [Callback]
callbacks Window
_win [String]
paths = do
  (([String] -> IO ()) -> IO ()) -> [[String] -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    (\[String] -> IO ()
f -> [String] -> IO ()
f [String]
paths)
    ([IORef GLFWState -> [String] -> IO ()
DropCallback
f IORef GLFWState
stateRef | Drop DropCallback
f <- [Callback]
callbacks])


-- Motion Callback ------------------------------------------------------------

-- | Callback for when the user moves the mouse.
installMotionCallbackGLFW ::
  IORef GLFWState ->
  [Callback] ->
  IO ()
installMotionCallbackGLFW :: IORef GLFWState -> [Callback] -> IO ()
installMotionCallbackGLFW IORef GLFWState
stateRef [Callback]
callbacks =
  do
    Window
win <- IORef GLFWState -> IO Window
windowHandle IORef GLFWState
stateRef
    Window -> Maybe ScrollCallback -> IO ()
GLFW.setCursorPosCallback Window
win (ScrollCallback -> Maybe ScrollCallback
forall a. a -> Maybe a
Just (ScrollCallback -> Maybe ScrollCallback)
-> ScrollCallback -> Maybe ScrollCallback
forall a b. (a -> b) -> a -> b
$ IORef GLFWState -> [Callback] -> ScrollCallback
callbackMotion IORef GLFWState
stateRef [Callback]
callbacks)


-- Drop Paths Callback ---------------------------------------------------------

-- | Callback for when the user drops files/directories onto the window.
installDropCallbackGLFW ::
  IORef GLFWState ->
  [Callback] ->
  IO ()
installDropCallbackGLFW :: IORef GLFWState -> [Callback] -> IO ()
installDropCallbackGLFW IORef GLFWState
stateRef [Callback]
callbacks = do
  Window
win <- IORef GLFWState -> IO Window
windowHandle IORef GLFWState
stateRef
  Window -> Maybe DropCallback -> IO ()
GLFW.setDropCallback Window
win (DropCallback -> Maybe DropCallback
forall a. a -> Maybe a
Just (DropCallback -> Maybe DropCallback)
-> DropCallback -> Maybe DropCallback
forall a b. (a -> b) -> a -> b
$ IORef GLFWState -> [Callback] -> DropCallback
callbackDrop IORef GLFWState
stateRef [Callback]
callbacks)


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

callbackMotion ::
  IORef GLFWState ->
  [Callback] ->
  GLFW.CursorPosCallback
callbackMotion :: IORef GLFWState -> [Callback] -> ScrollCallback
callbackMotion IORef GLFWState
stateRef [Callback]
callbacks Window
_win Double
x Double
y =
  do
    (Int, Int)
pos <- IORef GLFWState -> Int -> Int -> IO (Int, Int)
setMousePos IORef GLFWState
stateRef (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
x) (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
y)

    -- Call all the Brillo Motion actions with the new state.
    (((Int, Int) -> IO ()) -> IO ()) -> [(Int, Int) -> IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
      (\(Int, Int) -> IO ()
f -> (Int, Int) -> IO ()
f (Int, Int)
pos)
      ([IORef GLFWState -> (Int, Int) -> IO ()
ReshapeCallback
f IORef GLFWState
stateRef | Motion ReshapeCallback
f <- [Callback]
callbacks])


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

    IORef GLFWState -> (GLFWState -> GLFWState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef GLFWState
stateRef ((GLFWState -> GLFWState) -> IO ())
-> (GLFWState -> GLFWState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GLFWState
s ->
      GLFWState
s
        { mousePosition = pos
        }

    (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int, Int)
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 :: IORef GLFWState -> [Callback] -> IO ()
installIdleCallbackGLFW IORef GLFWState
stateRef [Callback]
callbacks =
  IORef GLFWState -> (GLFWState -> GLFWState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef GLFWState
stateRef ((GLFWState -> GLFWState) -> IO ())
-> (GLFWState -> GLFWState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GLFWState
s ->
    GLFWState
s
      { idle = callbackIdle stateRef callbacks
      }


callbackIdle ::
  IORef GLFWState ->
  [Callback] ->
  IO ()
callbackIdle :: IORef GLFWState -> [Callback] -> IO ()
callbackIdle IORef GLFWState
stateRef [Callback]
callbacks =
  [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$
    [IORef GLFWState -> IO ()
DisplayCallback
f IORef GLFWState
stateRef | Idle DisplayCallback
f <- [Callback]
callbacks]


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

runMainLoopGLFW :: IORef GLFWState -> IO ()
runMainLoopGLFW :: IORef GLFWState -> IO ()
runMainLoopGLFW IORef GLFWState
stateRef = do
  IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
X.catch IO ()
go SomeException -> IO ()
handleException
  WindowCloseCallback
GLFW.destroyWindow WindowCloseCallback -> IO Window -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef GLFWState -> IO Window
windowHandle IORef GLFWState
stateRef
  IO ()
GLFW.terminate
  where
    handleException :: X.SomeException -> IO ()
    handleException :: SomeException -> IO ()
handleException = SomeException -> IO ()
forall a. Show a => a -> IO ()
print

    clearDirtyFlag :: IO ()
    clearDirtyFlag :: IO ()
clearDirtyFlag =
      IORef GLFWState -> (GLFWState -> GLFWState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef'
        IORef GLFWState
stateRef
        (\GLFWState
state -> GLFWState
state{dirtyScreen = False})

    display' :: IO ()
    display' :: IO ()
display' = IORef GLFWState -> IO GLFWState
forall a. IORef a -> IO a
readIORef IORef GLFWState
stateRef IO GLFWState -> (GLFWState -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GLFWState -> IO ()
display

    idle' :: IO ()
    idle' :: IO ()
idle' = IORef GLFWState -> IO GLFWState
forall a. IORef a -> IO a
readIORef IORef GLFWState
stateRef IO GLFWState -> (GLFWState -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GLFWState -> IO ()
idle

    swapBuffers' :: IO ()
    swapBuffers' :: IO ()
swapBuffers' = IORef GLFWState -> IO Window
windowHandle IORef GLFWState
stateRef IO Window -> WindowCloseCallback -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WindowCloseCallback
GLFW.swapBuffers

    windowShouldClose :: IO Bool
    windowShouldClose :: IO Bool
windowShouldClose = IORef GLFWState -> IO Window
windowHandle IORef GLFWState
stateRef IO Window -> (Window -> IO Bool) -> IO Bool
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Window -> IO Bool
GLFW.windowShouldClose

    unlessM :: (Monad m) => m Bool -> m () -> m ()
    unlessM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM m Bool
testAction m ()
action = do
      Bool
sentinel <- m Bool
testAction
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
sentinel m ()
action

    go :: IO ()
    go :: IO ()
go = do
      -- Perform drawing, clear the dirty flag, do idle processing
      IO ()
display'
      IO ()
clearDirtyFlag
      IO ()
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.
      IO ()
swapBuffers'

      -- Poll for GLFW events; quit if necessary.
      IO ()
GLFW.pollEvents
      IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM IO Bool
windowShouldClose IO ()
go


-- Redisplay ------------------------------------------------------------------
postRedisplayGLFW ::
  IORef GLFWState ->
  IO ()
postRedisplayGLFW :: IORef GLFWState -> IO ()
postRedisplayGLFW IORef GLFWState
stateRef =
  IORef GLFWState -> (GLFWState -> GLFWState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef GLFWState
stateRef ((GLFWState -> GLFWState) -> IO ())
-> (GLFWState -> GLFWState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GLFWState
s ->
    GLFWState
s
      { dirtyScreen = True
      }


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


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


instance GLFWKey GLFW.MouseButton where
  fromGLFW :: MouseButton -> Key
fromGLFW MouseButton
mouse =
    case MouseButton
mouse of
      MouseButton
GLFW.MouseButton'1 -> MouseButton -> Key
MouseButton MouseButton
LeftButton
      MouseButton
GLFW.MouseButton'2 -> MouseButton -> Key
MouseButton MouseButton
RightButton
      MouseButton
GLFW.MouseButton'3 -> MouseButton -> Key
MouseButton MouseButton
MiddleButton
      MouseButton
GLFW.MouseButton'4 -> MouseButton -> Key
MouseButton (MouseButton -> Key) -> MouseButton -> Key
forall a b. (a -> b) -> a -> b
$ Int -> MouseButton
AdditionalButton Int
4
      MouseButton
GLFW.MouseButton'5 -> MouseButton -> Key
MouseButton (MouseButton -> Key) -> MouseButton -> Key
forall a b. (a -> b) -> a -> b
$ Int -> MouseButton
AdditionalButton Int
5
      MouseButton
GLFW.MouseButton'6 -> MouseButton -> Key
MouseButton (MouseButton -> Key) -> MouseButton -> Key
forall a b. (a -> b) -> a -> b
$ Int -> MouseButton
AdditionalButton Int
6
      MouseButton
GLFW.MouseButton'7 -> MouseButton -> Key
MouseButton (MouseButton -> Key) -> MouseButton -> Key
forall a b. (a -> b) -> a -> b
$ Int -> MouseButton
AdditionalButton Int
7
      MouseButton
GLFW.MouseButton'8 -> MouseButton -> Key
MouseButton (MouseButton -> Key) -> MouseButton -> Key
forall a b. (a -> b) -> a -> b
$ Int -> MouseButton
AdditionalButton Int
8