gloss-1.13.0.1: Graphics/Gloss/Internals/Interface/Backend/GLFW.hs
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE CPP #-}
-- | Support for using GLFW as the window manager backend.
module Graphics.Gloss.Internals.Interface.Backend.GLFW
(GLFWState)
where
import Data.IORef
import Data.Char (toLower)
import Data.Maybe (fromJust)
import Control.Concurrent
import Control.Monad
import Graphics.Gloss.Data.Display
-- import Graphics.UI.GLFW (WindowValue(..))
import qualified Graphics.UI.GLFW as GLFW
import qualified Graphics.Rendering.OpenGL as GL
import qualified Control.Exception as X
-- [Note: FreeGlut]
-- ~~~~~~~~~~~~~~~~
-- We use GLUT for font rendering.
-- On freeglut-based installations (usually linux) we need to explicitly
-- initialize GLUT before we can use any of it's functions.
--
--- We also need to deinitialize (exit) GLUT when we close the GLFW
-- window, otherwise opening a gloss window again from GHCi will crash.
-- For the OS X and Windows version of GLUT there are no such restrictions.
--
-- We assume also assume that only linux installations use freeglut.
--
#ifdef linux_HOST_OS
import qualified Graphics.UI.GLUT as GLUT
#endif
import Graphics.Gloss.Internals.Interface.Backend.Types
-- | State of the GLFW backend library.
data GLFWState
= GLFWState
{ -- | Status of Ctrl, Alt or Shift (Up or Down?)
modifiers :: Modifiers
-- | Latest mouse position
, mousePosition :: (Int,Int)
-- | Latest mousewheel position
, mouseWheelPos :: Int
-- | Does the screen need to be redrawn?
, dirtyScreen :: Bool
-- | Action that draws on the screen
, display :: IO ()
-- | Action perforrmed when idling
, idle :: IO ()
-- | The Window Handle
, winHdl :: GLFW.Window
}
-- | Initial GLFW state.
glfwStateInit :: GLFWState
glfwStateInit
= GLFWState
{ modifiers = Modifiers Up Up Up
, mousePosition = (0, 0)
, mouseWheelPos = 0
, dirtyScreen = True
, display = return ()
, idle = return () }
instance Backend GLFWState where
initBackendState = glfwStateInit
initializeBackend = initializeGLFW
exitBackend = exitGLFW
openWindow = openWindowGLFW
dumpBackendState = dumpStateGLFW
installDisplayCallback = installDisplayCallbackGLFW
installWindowCloseCallback = installWindowCloseCallbackGLFW
installReshapeCallback = installReshapeCallbackGLFW
installKeyMouseCallback = installKeyMouseCallbackGLFW
installMotionCallback = installMotionCallbackGLFW
installIdleCallback = installIdleCallbackGLFW
runMainLoop = runMainLoopGLFW
postRedisplay = postRedisplayGLFW
getWindowDimensions = (\ref -> windowHandle ref >>= \win -> GLFW.getWindowSize win)
elapsedTime = (\_ -> GLFW.getTime >>= \mt -> return $ fromJust mt)
sleep = (\_ sec -> threadDelay (floor (sec * fromIntegral 1000000))) --GLFW.sleep sec)
-- Initialise -----------------------------------------------------------------
-- | Initialise the GLFW backend.
initializeGLFW :: IORef GLFWState -> Bool-> IO ()
initializeGLFW _ debug
= do
_ <- GLFW.init
glfwVersion <- GLFW.getVersion
#ifdef linux_HOST_OS
-- See [Note: FreeGlut] for why we need this.
(_progName, _args) <- GLUT.getArgsAndInitialize
#endif
when debug
$ putStr $ " glfwVersion = " ++ show glfwVersion ++ "\n"
-- Exit -----------------------------------------------------------------------
-- | Tell the GLFW backend to close the window and exit.
exitGLFW :: IORef GLFWState -> IO ()
exitGLFW ref
= do
#ifdef linux_HOST_OS
-- See [Note: FreeGlut] on why we exit GLUT for Linux
GLUT.exit
#endif
win <- windowHandle ref
GLFW.destroyWindow win
-- Open Window ----------------------------------------------------------------
-- | Open a new window.
openWindowGLFW
:: IORef GLFWState
-> Display
-> IO ()
openWindowGLFW ref (InWindow title (sizeX, sizeY) pos)
= do win <- GLFW.createWindow
sizeX
sizeY
title
Nothing
Nothing
modifyIORef' ref (\s -> s { winHdl = fromJust win})
uncurry (GLFW.setWindowPos (fromJust win)) pos
-- Try to enable sync-to-vertical-refresh by setting the number
-- of buffer swaps per vertical refresh to 1.
GLFW.swapInterval 1
openWindowGLFW ref FullScreen
= do mon <- GLFW.getPrimaryMonitor
vmode <- GLFW.getVideoMode (fromJust mon)
let sizeX = GLFW.videoModeWidth (fromJust vmode)
let sizeY = GLFW.videoModeHeight (fromJust vmode)
win <- GLFW.createWindow
sizeX
sizeY
""
mon
Nothing
modifyIORef' ref (\s -> s { winHdl = fromJust win})
-- Try to enable sync-to-vertical-refresh by setting the number
-- of buffer swaps per vertical refresh to 1.
GLFW.swapInterval 1
--GLFW.enableMouseCursor
GLFW.setCursorInputMode (fromJust win) GLFW.CursorInputMode'Normal
windowHandle :: IORef GLFWState -> IO GLFW.Window
windowHandle ref
= do s <- readIORef ref
return $ winHdl s
-- Dump State -----------------------------------------------------------------
-- | Print out the internal GLFW state.
dumpStateGLFW :: IORef GLFWState -> IO ()
dumpStateGLFW ref
= do win <- windowHandle ref
(ww,wh) <- GLFW.getWindowSize win
-- GLFW-b does not provide a general function to query windowHints
-- could be added by adding additional getWindowHint which
-- uses glfwGetWindowAttrib behind the scenes as has been done
-- already for e.g. getWindowVisible which uses glfwGetWindowAttrib
{-
r <- GLFW.getWindowHint NumRedBits
g <- GLFW.getWindowHint NumGreenBits
b <- GLFW.getWindowHint NumBlueBits
a <- GLFW.getWindowHint NumAlphaBits
let rgbaBD = [r,g,b,a]
depthBD <- GLFW.getWindowHint NumDepthBits
ra <- GLFW.getWindowHint NumAccumRedBits
ga <- GLFW.getWindowHint NumAccumGreenBits
ba <- GLFW.getWindowHint NumAccumBlueBits
aa <- GLFW.getWindowHint NumAccumAlphaBits
let accumBD = [ra,ga,ba,aa]
stencilBD <- GLFW.getWindowHint NumStencilBits
auxBuffers <- GLFW.getWindowHint NumAuxBuffers
fsaaSamples <- GLFW.getWindowHint NumFsaaSamples
putStr $ "* dumpGlfwState\n"
++ " windowWidth = " ++ show ww ++ "\n"
++ " windowHeight = " ++ show wh ++ "\n"
++ " depth rgba = " ++ show rgbaBD ++ "\n"
++ " depth = " ++ show depthBD ++ "\n"
++ " accum = " ++ show accumBD ++ "\n"
++ " stencil = " ++ show stencilBD ++ "\n"
++ " aux Buffers = " ++ show auxBuffers ++ "\n"
++ " FSAA Samples = " ++ show fsaaSamples ++ "\n"
++ "\n"
-}
putStr $ "* dumpGlfwState\n"
++ " windowWidth = " ++ show ww ++ "\n"
++ " windowHeight = " ++ show wh ++ "\n"
++ "\n"
-- Display Callback -----------------------------------------------------------
-- | Callback for when GLFW needs us to redraw the contents of the window.
installDisplayCallbackGLFW
:: IORef GLFWState -> [Callback] -> IO ()
installDisplayCallbackGLFW stateRef callbacks
= modifyIORef' stateRef $ \s -> s
{ display = callbackDisplay stateRef callbacks }
callbackDisplay
:: IORef GLFWState -> [Callback]
-> IO ()
callbackDisplay stateRef callbacks
= do -- clear the display
GL.clear [GL.ColorBuffer, GL.DepthBuffer]
GL.color $ GL.Color4 0 0 0 (1 :: GL.GLfloat)
-- get the display callbacks from the chain
let funs = [f stateRef | (Display f) <- callbacks]
sequence_ funs
return ()
-- Close Callback -------------------------------------------------------------
-- | Callback for when the user closes the window.
-- We can do some cleanup here.
installWindowCloseCallbackGLFW
:: IORef GLFWState -> IO ()
installWindowCloseCallbackGLFW ref
= do win <- windowHandle ref
GLFW.setWindowCloseCallback win (Just winClosed)
where
winClosed :: GLFW.WindowCloseCallback
winClosed win = do
#ifdef linux_HOST_OS
-- See [Note: FreeGlut] for why we need this.
GLUT.exit
#endif
return ()
-- Reshape --------------------------------------------------------------------
-- | Callback for when the user reshapes the window.
installReshapeCallbackGLFW
:: IORef GLFWState -> [Callback] -> IO ()
installReshapeCallbackGLFW stateRef callbacks
= do win <- windowHandle stateRef
GLFW.setWindowSizeCallback win (Just $ callbackReshape stateRef callbacks)
callbackReshape
:: IORef GLFWState -> [Callback]
-> GLFW.WindowSizeCallback -- = Window -> Int -> Int -> IO ()
callbackReshape glfwState callbacks win sizeX sizeY
= sequence_
$ map (\f -> f (sizeX, sizeY))
[f glfwState | Reshape f <- callbacks]
-- KeyMouse -----------------------------------------------------------------------
-- | Callbacks for when the user presses a key or moves / clicks the mouse.
-- This is a bit verbose because we have to do impedence matching between
-- GLFW's event system, and the one use by Gloss which was originally
-- based on GLUT. The main problem is that GLUT only provides a single callback
-- slot for character keys, arrow keys, mouse buttons and mouse wheel movement,
-- while GLFW provides a single slot for each.
--
installKeyMouseCallbackGLFW
:: IORef GLFWState -> [Callback]
-> IO ()
installKeyMouseCallbackGLFW stateRef callbacks
= do win <- windowHandle stateRef
GLFW.setKeyCallback win (Just $ callbackKeyboard stateRef callbacks)
GLFW.setCharCallback win (Just $ callbackChar stateRef callbacks)
GLFW.setMouseButtonCallback win (Just $ callbackMouseButton stateRef callbacks)
GLFW.setScrollCallback win (Just $ callbackMouseWheel stateRef callbacks)
-- GLFW calls this on a non-character keyboard action.
callbackKeyboard
:: IORef GLFWState -> [Callback]
-> GLFW.KeyCallback -- = Window -> Key -> Int -> KeyState -> ModifierKeys -> IO ()
-- -> GLFW.Key -> Bool
-- -> IO ()
callbackKeyboard stateRef callbacks win key scancode keystateglfw modifiers
= do let keystate = keystateglfw == GLFW.KeyState'Pressed
(modsSet, GLFWState mods pos _ _ _ _ _)
<- setModifiers stateRef key keystate
let key' = fromGLFW key
let keystate' = if keystate then Down else Up
let isCharKey (Char _) = True
isCharKey _ = False
-- Call the Gloss KeyMouse actions with the new state.
unless (modsSet || isCharKey key' && keystate)
$ sequence_
$ map (\f -> f key' keystate' mods pos)
[f stateRef | KeyMouse f <- callbacks]
setModifiers
:: IORef GLFWState
-> GLFW.Key -> Bool
-> IO (Bool, GLFWState)
setModifiers stateRef key pressed
= do glfwState <- readIORef stateRef
let mods = modifiers glfwState
let mods' = case key of
GLFW.Key'LeftShift -> mods {shift = if pressed then Down else Up}
GLFW.Key'LeftControl -> mods {ctrl = if pressed then Down else Up}
GLFW.Key'LeftAlt -> mods {alt = if pressed then Down else Up}
_ -> mods
if (mods' /= mods)
then do
let glfwState' = glfwState {modifiers = mods'}
writeIORef stateRef glfwState'
return (True, glfwState')
else return (False, glfwState)
-- GLFW calls this on a when the user presses or releases a character key.
callbackChar
:: IORef GLFWState -> [Callback]
-> GLFW.CharCallback
-- Window -> Char -> IO ()
-- -> Char -> Bool -> IO ()
callbackChar stateRef callbacks win char -- keystate
= do (GLFWState mods pos _ _ _ _ _) <- readIORef stateRef
let key' = charToSpecial char
-- TODO: is this correct? GLFW does not provide the keystate
-- in a character callback, here we asume that its pressed
let keystate = True
-- Only key presses of characters are passed to this callback,
-- character key releases are caught by the 'keyCallback'. This is an
-- intentional feature of GLFW. What this means that a key press of
-- the '>' char (on a US Intl keyboard) is captured by this callback,
-- but a release is captured as a '.' with the shift-modifier in the
-- keyCallback.
let keystate' = if keystate then Down else Up
-- Call all the Gloss KeyMouse actions with the new state.
sequence_
$ map (\f -> f key' keystate' mods pos)
[f stateRef | KeyMouse f <- callbacks]
-- GLFW calls on this when the user clicks or releases a mouse button.
callbackMouseButton
:: IORef GLFWState -> [Callback]
-> GLFW.MouseButtonCallback -- = Window -> MouseButton -> MouseButtonState -> ModifierKeys -> IO ()
callbackMouseButton stateRef callbacks win key keystate modifier
= do (GLFWState mods pos _ _ _ _ _) <- readIORef stateRef
let key' = fromGLFW key
let keystate' = if keystate == GLFW.MouseButtonState'Pressed then Down else Up
-- Call all the Gloss KeyMouse actions with the new state.
sequence_
$ map (\f -> f key' keystate' mods pos)
[f stateRef | KeyMouse f <- callbacks]
-- GLFW calls on this when the user moves the mouse wheel.
callbackMouseWheel
:: IORef GLFWState -> [Callback]
-> GLFW.ScrollCallback
-- -> Int
-- -> IO ()
-- ScrollCallback = Window -> Double -> Double -> IO ()
callbackMouseWheel stateRef callbacks win x y
= do (key, keystate) <- setMouseWheel stateRef (floor x)
(GLFWState mods pos _ _ _ _ _) <- readIORef stateRef
-- Call all the Gloss KeyMouse actions with the new state.
sequence_
$ map (\f -> f key keystate mods pos)
[f stateRef | KeyMouse f <- callbacks]
setMouseWheel
:: IORef GLFWState
-> Int
-> IO (Key, KeyState)
setMouseWheel stateRef w
= do glfwState <- readIORef stateRef
writeIORef stateRef $ glfwState {mouseWheelPos = w}
case compare w (mouseWheelPos glfwState) of
LT -> return (MouseButton WheelDown , Down)
GT -> return (MouseButton WheelUp , Down)
EQ -> return (SpecialKey KeyUnknown, Up )
-- Motion Callback ------------------------------------------------------------
-- | Callback for when the user moves the mouse.
installMotionCallbackGLFW
:: IORef GLFWState -> [Callback]
-> IO ()
installMotionCallbackGLFW stateRef callbacks
= do win <- windowHandle stateRef
GLFW.setCursorPosCallback win (Just $ callbackMotion stateRef callbacks)
--CursorPosCallback = Window -> Double -> Double -> IO ()
callbackMotion
:: IORef GLFWState -> [Callback]
-> GLFW.CursorPosCallback
callbackMotion stateRef callbacks win x y
= do pos <- setMousePos stateRef (floor x) (floor y)
-- Call all the Gloss Motion actions with the new state.
sequence_
$ map (\f -> f pos)
[f stateRef | Motion f <- callbacks]
setMousePos
:: IORef GLFWState
-> Int -> Int
-> IO (Int, Int)
setMousePos stateRef x y
= do let pos = (x,y)
modifyIORef' stateRef $ \s -> s
{ mousePosition = pos }
return pos
-- Idle Callback --------------------------------------------------------------
-- | Callback for when GLFW has finished its jobs and it's time for us to do
-- something for our application.
installIdleCallbackGLFW
:: IORef GLFWState -> [Callback]
-> IO ()
installIdleCallbackGLFW stateRef callbacks
= modifyIORef' stateRef $ \s -> s
{ idle = callbackIdle stateRef callbacks }
callbackIdle
:: IORef GLFWState -> [Callback]
-> IO ()
callbackIdle stateRef callbacks
= sequence_
$ [f stateRef | Idle f <- callbacks]
-- Main Loop ------------------------------------------------------------------
runMainLoopGLFW
:: IORef GLFWState
-> IO ()
runMainLoopGLFW stateRef
= X.catch go exit
where
exit :: X.SomeException -> IO ()
exit e = print e >> exitGLFW stateRef
go :: IO ()
go
=
do win <- windowHandle stateRef
windowIsOpen <- GLFW.windowShouldClose win
when windowIsOpen
$ do GLFW.pollEvents
dirty <- fmap dirtyScreen $ readIORef stateRef
when dirty
$ do s <- readIORef stateRef
display s
GLFW.swapBuffers win
modifyIORef' stateRef $ \s -> s
{ dirtyScreen = False }
(readIORef stateRef) >>= (\s -> idle s)
threadDelay 1000
runMainLoopGLFW stateRef
-- Redisplay ------------------------------------------------------------------
postRedisplayGLFW
:: IORef GLFWState
-> IO ()
postRedisplayGLFW stateRef
= modifyIORef' stateRef $ \s -> s
{ dirtyScreen = True }
-- Key Code Conversion --------------------------------------------------------
class GLFWKey a where
fromGLFW :: a -> Key
instance GLFWKey GLFW.Key where
fromGLFW key
= case key of
GLFW.Key'A -> charToSpecial 'a'
GLFW.Key'B -> charToSpecial 'b'
GLFW.Key'C -> charToSpecial 'c'
GLFW.Key'D -> charToSpecial 'd'
GLFW.Key'E -> charToSpecial 'e'
GLFW.Key'F -> charToSpecial 'f'
GLFW.Key'G -> charToSpecial 'g'
GLFW.Key'H -> charToSpecial 'h'
GLFW.Key'I -> charToSpecial 'i'
GLFW.Key'J -> charToSpecial 'j'
GLFW.Key'K -> charToSpecial 'k'
GLFW.Key'L -> charToSpecial 'l'
GLFW.Key'M -> charToSpecial 'm'
GLFW.Key'N -> charToSpecial 'n'
GLFW.Key'O -> charToSpecial 'o'
GLFW.Key'P -> charToSpecial 'p'
GLFW.Key'Q -> charToSpecial 'q'
GLFW.Key'R -> charToSpecial 'r'
GLFW.Key'S -> charToSpecial 's'
GLFW.Key'T -> charToSpecial 't'
GLFW.Key'U -> charToSpecial 'u'
GLFW.Key'V -> charToSpecial 'v'
GLFW.Key'W -> charToSpecial 'w'
GLFW.Key'X -> charToSpecial 'x'
GLFW.Key'Y -> charToSpecial 'y'
GLFW.Key'Z -> charToSpecial 'z'
GLFW.Key'Space -> SpecialKey KeySpace
GLFW.Key'Escape -> SpecialKey KeyEsc
GLFW.Key'F1 -> SpecialKey KeyF1
GLFW.Key'F2 -> SpecialKey KeyF2
GLFW.Key'F3 -> SpecialKey KeyF3
GLFW.Key'F4 -> SpecialKey KeyF4
GLFW.Key'F5 -> SpecialKey KeyF5
GLFW.Key'F6 -> SpecialKey KeyF6
GLFW.Key'F7 -> SpecialKey KeyF7
GLFW.Key'F8 -> SpecialKey KeyF8
GLFW.Key'F9 -> SpecialKey KeyF9
GLFW.Key'F10 -> SpecialKey KeyF10
GLFW.Key'F11 -> SpecialKey KeyF11
GLFW.Key'F12 -> SpecialKey KeyF12
GLFW.Key'F13 -> SpecialKey KeyF13
GLFW.Key'F14 -> SpecialKey KeyF14
GLFW.Key'F15 -> SpecialKey KeyF15
GLFW.Key'F16 -> SpecialKey KeyF16
GLFW.Key'F17 -> SpecialKey KeyF17
GLFW.Key'F18 -> SpecialKey KeyF18
GLFW.Key'F19 -> SpecialKey KeyF19
GLFW.Key'F20 -> SpecialKey KeyF20
GLFW.Key'F21 -> SpecialKey KeyF21
GLFW.Key'F22 -> SpecialKey KeyF22
GLFW.Key'F23 -> SpecialKey KeyF23
GLFW.Key'F24 -> SpecialKey KeyF24
GLFW.Key'F25 -> SpecialKey KeyF25
GLFW.Key'Up -> SpecialKey KeyUp
GLFW.Key'Down -> SpecialKey KeyDown
GLFW.Key'Left -> SpecialKey KeyLeft
GLFW.Key'Right -> SpecialKey KeyRight
GLFW.Key'Tab -> SpecialKey KeyTab
GLFW.Key'Enter -> SpecialKey KeyEnter
GLFW.Key'Backspace -> SpecialKey KeyBackspace
GLFW.Key'Insert -> SpecialKey KeyInsert
GLFW.Key'Delete -> SpecialKey KeyDelete
GLFW.Key'PageUp -> SpecialKey KeyPageUp
GLFW.Key'PageDown -> SpecialKey KeyPageDown
GLFW.Key'Home -> SpecialKey KeyHome
GLFW.Key'End -> SpecialKey KeyEnd
GLFW.Key'Pad0 -> SpecialKey KeyPad0
GLFW.Key'Pad1 -> SpecialKey KeyPad1
GLFW.Key'Pad2 -> SpecialKey KeyPad2
GLFW.Key'Pad3 -> SpecialKey KeyPad3
GLFW.Key'Pad4 -> SpecialKey KeyPad4
GLFW.Key'Pad5 -> SpecialKey KeyPad5
GLFW.Key'Pad6 -> SpecialKey KeyPad6
GLFW.Key'Pad7 -> SpecialKey KeyPad7
GLFW.Key'Pad8 -> SpecialKey KeyPad8
GLFW.Key'Pad9 -> SpecialKey KeyPad9
GLFW.Key'PadDivide -> SpecialKey KeyPadDivide
GLFW.Key'PadMultiply -> SpecialKey KeyPadMultiply
GLFW.Key'PadSubtract -> SpecialKey KeyPadSubtract
GLFW.Key'PadAdd -> SpecialKey KeyPadAdd
GLFW.Key'PadDecimal -> SpecialKey KeyPadDecimal
GLFW.Key'PadEqual -> Char '='
GLFW.Key'PadEnter -> SpecialKey KeyPadEnter
_ -> SpecialKey KeyUnknown
-- | Convert char keys to special keys to work around a bug in
-- GLFW 2.7. On OS X, GLFW sometimes registers special keys as char keys,
-- so we convert them back here.
-- GLFW 2.7 is current as of Nov 2011, and is shipped with the Hackage
-- binding GLFW-b 0.2.*
charToSpecial :: Char -> Key
charToSpecial c = case (fromEnum c) of
32 -> SpecialKey KeySpace
63232 -> SpecialKey KeyUp
63233 -> SpecialKey KeyDown
63234 -> SpecialKey KeyLeft
63235 -> SpecialKey KeyRight
63236 -> SpecialKey KeyF1
63237 -> SpecialKey KeyF2
63238 -> SpecialKey KeyF3
63239 -> SpecialKey KeyF4
63240 -> SpecialKey KeyF5
63241 -> SpecialKey KeyF6
63242 -> SpecialKey KeyF7
63243 -> SpecialKey KeyF8
63244 -> SpecialKey KeyF9
63245 -> SpecialKey KeyF10
63246 -> SpecialKey KeyF11
63247 -> SpecialKey KeyF12
63248 -> SpecialKey KeyF13
63272 -> SpecialKey KeyDelete
63273 -> SpecialKey KeyHome
63275 -> SpecialKey KeyEnd
63276 -> SpecialKey KeyPageUp
63277 -> SpecialKey KeyPageDown
_ -> Char c
instance GLFWKey GLFW.MouseButton where
fromGLFW mouse
= case mouse of
GLFW.MouseButton'1 -> MouseButton LeftButton
GLFW.MouseButton'2 -> MouseButton RightButton
GLFW.MouseButton'3 -> MouseButton MiddleButton
GLFW.MouseButton'4 -> MouseButton $ AdditionalButton 4
GLFW.MouseButton'5 -> MouseButton $ AdditionalButton 5
GLFW.MouseButton'6 -> MouseButton $ AdditionalButton 6
GLFW.MouseButton'7 -> MouseButton $ AdditionalButton 7
GLFW.MouseButton'8 -> MouseButton $ AdditionalButton 8