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

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

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

import Brillo.Internals.Interface.Backend.Types


-- | State of the GLFW backend library.
data GLFWState
  = GLFWState
  { 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
  }


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


-- | 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
  installKeyMouseCallback :: IORef GLFWState -> [Callback] -> IO ()
installKeyMouseCallback = IORef GLFWState -> [Callback] -> IO ()
installKeyMouseCallbackGLFW
  installMotionCallback :: IORef GLFWState -> [Callback] -> IO ()
installMotionCallback = IORef GLFWState -> [Callback] -> IO ()
installMotionCallbackGLFW
  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
  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 -> Double -> IO Double
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> IO Double) -> Double -> IO Double
forall a b. (a -> b) -> a -> b
$ Maybe Double -> Double
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Double
mt)
  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)


-- 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 ()
putStr (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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"


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


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

-- | Open a new window.
openWindowGLFW
  :: IORef GLFWState
  -> Display
  -> IO ()
openWindowGLFW :: IORef GLFWState -> Display -> IO ()
openWindowGLFW IORef GLFWState
ref (InWindow String
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
        String
title
        Maybe Monitor
forall a. Maybe a
Nothing
        Maybe Window
forall a. Maybe a
Nothing

    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 (Maybe Window -> Window
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Window
win)) (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
    Maybe VideoMode
vmode <- Monitor -> IO (Maybe VideoMode)
GLFW.getVideoMode (Maybe Monitor -> Monitor
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Monitor
mon)

    let sizeX :: Int
sizeX = VideoMode -> Int
GLFW.videoModeWidth (Maybe VideoMode -> VideoMode
forall a. HasCallStack => Maybe a -> a
fromJust Maybe VideoMode
vmode)
    let sizeY :: Int
sizeY = VideoMode -> Int
GLFW.videoModeHeight (Maybe VideoMode -> VideoMode
forall a. HasCallStack => Maybe a -> a
fromJust Maybe VideoMode
vmode)

    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

    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
    -- GLFW.enableMouseCursor
    Window -> CursorInputMode -> IO ()
GLFW.setCursorInputMode (Maybe Window -> Window
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Window
win) 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
  Maybe VideoMode
vmode <- Monitor -> IO (Maybe VideoMode)
GLFW.getVideoMode (Maybe Monitor -> Monitor
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Monitor
monitor)

  let sizeX :: Int
sizeX = VideoMode -> Int
GLFW.videoModeWidth (Maybe VideoMode -> VideoMode
forall a. HasCallStack => Maybe a -> a
fromJust Maybe VideoMode
vmode)
  let sizeY :: Int
sizeY = VideoMode -> Int
GLFW.videoModeHeight (Maybe VideoMode -> VideoMode
forall a. HasCallStack => Maybe a -> a
fromJust Maybe VideoMode
vmode)

  (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
sizeX, Int
sizeY)


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

    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- 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
glfwState [Callback]
callbacks Window
_win Int
sizeX Int
sizeY =
  [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
$
    (((Int, Int) -> IO ()) -> IO ())
-> [(Int, Int) -> IO ()] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map
      (\(Int, Int) -> IO ()
f -> (Int, Int) -> IO ()
f (Int
sizeX, Int
sizeY))
      [IORef GLFWState -> (Int, Int) -> IO ()
ReshapeCallback
f IORef GLFWState
glfwState | Reshape ReshapeCallback
f <- [Callback]
callbacks]


-- KeyMouse -----------------------------------------------------------------------

{-| Callbacks for when the user presses a key or moves / clicks the mouse.
  This is a bit verbose because we have to do impedence matching between
  GLFW's event system, and the one use by Brillo which was originally
  based on GLUT. The main problem is that GLUT only provides a single callback
  slot for character keys, arrow keys, mouse buttons and mouse wheel movement,
  while GLFW provides a single slot for each.
-}
installKeyMouseCallbackGLFW
  :: IORef GLFWState
  -> [Callback]
  -> IO ()
installKeyMouseCallbackGLFW :: 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)


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

    -- 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) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      [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
$
        ((Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()) -> IO ())
-> [Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map
          (\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]


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
_) <- 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.
    [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
$
      ((Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()) -> IO ())
-> [Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map
        (\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
_) <- 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.
    [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
$
      ((Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()) -> IO ())
-> [Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map
        (\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
_) <- IORef GLFWState -> IO GLFWState
forall a. IORef a -> IO a
readIORef IORef GLFWState
stateRef

    -- Call all the Brillo KeyMouse actions with the new state.
    [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
$
      ((Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()) -> IO ())
-> [Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map
        (\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)


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


-- 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.
    [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
$
      (((Int, Int) -> IO ()) -> IO ())
-> [(Int, Int) -> IO ()] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map
        (\(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