gloss 1.13.1.2 → 1.13.2.1
raw patch · 5 files changed
+146/−92 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- Graphics/Gloss/Interface/Environment.hs +8/−9
- Graphics/Gloss/Internals/Interface/Backend/GLFW.hs +126/−75
- Graphics/Gloss/Internals/Interface/Backend/GLUT.hs +4/−0
- Graphics/Gloss/Internals/Interface/Backend/Types.hs +3/−0
- gloss.cabal +5/−8
Graphics/Gloss/Interface/Environment.hs view
@@ -1,19 +1,18 @@ module Graphics.Gloss.Interface.Environment where-import Graphics.Gloss.Internals.Interface.Backend.GLUT-import qualified Graphics.UI.GLUT as GLUT-import qualified Graphics.Rendering.OpenGL as GL-import Data.IORef +import Data.IORef (newIORef) +import qualified Graphics.Gloss.Internals.Interface.Backend.Types as Backend.Types+import Graphics.Gloss.Internals.Interface.Backend (defaultBackendState)+ -- | Get the size of the screen, in pixels. -- -- This will be the size of the rendered gloss image when -- fullscreen mode is enabled. -- getScreenSize :: IO (Int, Int)-getScreenSize- = do backendStateRef <- newIORef glutStateInit- initializeGLUT backendStateRef False- GL.Size width height <- GLUT.get GLUT.screenSize- return (fromIntegral width, fromIntegral height)+getScreenSize = do+ backendStateRef <- newIORef defaultBackendState+ Backend.Types.initializeBackend backendStateRef False+ Backend.Types.getScreenSize backendStateRef
Graphics/Gloss/Internals/Interface/Backend/GLFW.hs view
@@ -6,13 +6,12 @@ (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 Graphics.Rendering.OpenGL (($=)) import qualified Graphics.Rendering.OpenGL as GL import qualified Control.Exception as X @@ -58,7 +57,7 @@ , idle :: IO () -- | The Window Handle- , winHdl :: GLFW.Window + , optWinHdl :: Maybe GLFW.Window } @@ -71,10 +70,18 @@ , mouseWheelPos = 0 , dirtyScreen = True , display = return ()- , idle = return () }+ , idle = return ()+ , optWinHdl = Nothing } +-- | Fetch the window handle from the state if it has been initialized.+winHdl :: GLFWState -> GLFW.Window+winHdl state =+ case optWinHdl state of+ Just handle -> handle+ Nothing -> error "GLFW backend: requested uninitialized window handle" + instance Backend GLFWState where initBackendState = glfwStateInit initializeBackend = initializeGLFW@@ -90,14 +97,20 @@ runMainLoop = runMainLoopGLFW postRedisplay = postRedisplayGLFW getWindowDimensions = (\ref -> windowHandle ref >>= \win -> GLFW.getWindowSize win)+ getScreenSize = getScreenSizeGLFW elapsedTime = (\_ -> GLFW.getTime >>= \mt -> return $ fromJust mt)- sleep = (\_ sec -> threadDelay (floor (sec * fromIntegral 1000000))) --GLFW.sleep sec)+ sleep = (\_ sec -> threadDelay (floor (sec * 1000000.0))) --GLFW.sleep sec) -- Initialise ----------------------------------------------------------------- -- | Initialise the GLFW backend. initializeGLFW :: IORef GLFWState -> Bool-> IO () initializeGLFW _ debug = do++ let simpleErrorCallback e s =+ putStrLn $ unwords [ "GLFW backend: ", show e, show s ]+ GLFW.setErrorCallback (Just simpleErrorCallback)+ _ <- GLFW.init glfwVersion <- GLFW.getVersion @@ -120,7 +133,7 @@ GLUT.exit #endif win <- windowHandle ref- GLFW.destroyWindow win+ GLFW.setWindowShouldClose win True -- Open Window ----------------------------------------------------------------@@ -131,15 +144,16 @@ -> IO () openWindowGLFW ref (InWindow title (sizeX, sizeY) pos)- = do win <- GLFW.createWindow + = do win <- GLFW.createWindow sizeX sizeY title Nothing- Nothing + Nothing - modifyIORef' ref (\s -> s { winHdl = fromJust win})+ modifyIORef' ref (\s -> s { optWinHdl = win }) uncurry (GLFW.setWindowPos (fromJust win)) pos+ GLFW.makeContextCurrent win -- Try to enable sync-to-vertical-refresh by setting the number -- of buffer swaps per vertical refresh to 1.@@ -152,14 +166,15 @@ let sizeX = GLFW.videoModeWidth (fromJust vmode) let sizeY = GLFW.videoModeHeight (fromJust vmode) - win <- GLFW.createWindow + win <- GLFW.createWindow sizeX sizeY "" mon- Nothing + Nothing - modifyIORef' ref (\s -> s { winHdl = fromJust win})+ modifyIORef' ref (\s -> s { optWinHdl = win})+ GLFW.makeContextCurrent win -- Try to enable sync-to-vertical-refresh by setting the number -- of buffer swaps per vertical refresh to 1.@@ -173,16 +188,28 @@ = do s <- readIORef ref return $ winHdl s ++getScreenSizeGLFW :: IORef GLFWState -> IO (Int,Int)+getScreenSizeGLFW _state = do+ monitor <- GLFW.getPrimaryMonitor+ vmode <- GLFW.getVideoMode (fromJust monitor)++ let sizeX = GLFW.videoModeWidth (fromJust vmode)+ let sizeY = GLFW.videoModeHeight (fromJust vmode)++ pure (sizeX, sizeY)++ -- 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 +-- uses glfwGetWindowAttrib behind the scenes as has been done -- already for e.g. getWindowVisible which uses glfwGetWindowAttrib {- r <- GLFW.getWindowHint NumRedBits@@ -241,6 +268,11 @@ GL.clear [GL.ColorBuffer, GL.DepthBuffer] GL.color $ GL.Color4 0 0 0 (1 :: GL.GLfloat) + -- set the OpenGL viewport to account for any HiDPI discrepancy+ (width, height) <- windowHandle stateRef >>= GLFW.getFramebufferSize+ GL.viewport $= ( GL.Position 0 0+ , GL.Size (fromIntegral width) (fromIntegral height))+ -- get the display callbacks from the chain let funs = [f stateRef | (Display f) <- callbacks] sequence_ funs@@ -259,7 +291,7 @@ GLFW.setWindowCloseCallback win (Just winClosed) where winClosed :: GLFW.WindowCloseCallback- winClosed win = do+ winClosed _win = do #ifdef linux_HOST_OS -- See [Note: FreeGlut] for why we need this. GLUT.exit@@ -279,7 +311,7 @@ :: IORef GLFWState -> [Callback] -> GLFW.WindowSizeCallback -- = Window -> Int -> Int -> IO () -callbackReshape glfwState callbacks win sizeX sizeY+callbackReshape glfwState callbacks _win sizeX sizeY = sequence_ $ map (\f -> f (sizeX, sizeY)) [f glfwState | Reshape f <- callbacks]@@ -312,7 +344,7 @@ -- -> GLFW.Key -> Bool -- -> IO () -callbackKeyboard stateRef callbacks win key scancode keystateglfw modifiers+callbackKeyboard stateRef callbacks _win key _scancode keystateglfw _modifiers = do let keystate = keystateglfw == GLFW.KeyState'Pressed (modsSet, GLFWState mods pos _ _ _ _ _) <- setModifiers stateRef key keystate@@ -357,12 +389,12 @@ -- Window -> Char -> IO () -- -> Char -> Bool -> IO () -callbackChar stateRef callbacks win char -- keystate+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 + -- TODO: is this correct? GLFW does not provide the keystate -- in a character callback, here we asume that its pressed- let keystate = True + let keystate = True -- Only key presses of characters are passed to this callback, -- character key releases are caught by the 'keyCallback'. This is an@@ -382,8 +414,8 @@ callbackMouseButton :: IORef GLFWState -> [Callback] -> GLFW.MouseButtonCallback -- = Window -> MouseButton -> MouseButtonState -> ModifierKeys -> IO ()- -callbackMouseButton stateRef callbacks win key keystate modifier++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@@ -401,7 +433,7 @@ -- -> Int -- -> IO () -- ScrollCallback = Window -> Double -> Double -> IO ()-callbackMouseWheel stateRef callbacks win x y +callbackMouseWheel stateRef callbacks _win x _y = do (key, keystate) <- setMouseWheel stateRef (floor x) (GLFWState mods pos _ _ _ _ _) <- readIORef stateRef @@ -439,7 +471,7 @@ callbackMotion :: IORef GLFWState -> [Callback] -> GLFW.CursorPosCallback-callbackMotion stateRef callbacks win x y+callbackMotion stateRef callbacks _win x y = do pos <- setMousePos stateRef (floor x) (floor y) -- Call all the Gloss Motion actions with the new state.@@ -481,38 +513,57 @@ -- Main Loop -------------------------------------------------------------------runMainLoopGLFW- :: IORef GLFWState- -> IO () -runMainLoopGLFW stateRef- = X.catch go exit- where- exit :: X.SomeException -> IO ()- exit e = print e >> exitGLFW stateRef+runMainLoopGLFW :: IORef GLFWState -> IO ()+runMainLoopGLFW stateRef = do+ X.catch go handleException+ GLFW.destroyWindow =<< windowHandle stateRef+ GLFW.terminate - go :: IO ()- go- = - do win <- windowHandle stateRef- windowIsOpen <- GLFW.windowShouldClose win- when windowIsOpen- $ do GLFW.pollEvents- dirty <- fmap dirtyScreen $ readIORef stateRef+ where+ handleException :: X.SomeException -> IO ()+ handleException = print - when dirty- $ do s <- readIORef stateRef- display s- GLFW.swapBuffers win+ clearDirtyFlag :: IO ()+ clearDirtyFlag = modifyIORef'+ stateRef+ (\state -> state { dirtyScreen = False }) - modifyIORef' stateRef $ \s -> s- { dirtyScreen = False }+ display' :: IO ()+ display' = readIORef stateRef >>= display - (readIORef stateRef) >>= (\s -> idle s)- threadDelay 1000- runMainLoopGLFW stateRef+ idle' :: IO ()+ idle' = readIORef stateRef >>= idle + swapBuffers' :: IO ()+ swapBuffers' = windowHandle stateRef >>= GLFW.swapBuffers + windowShouldClose :: IO Bool+ windowShouldClose = windowHandle stateRef >>= GLFW.windowShouldClose++ unlessM :: Monad m => m Bool -> m () -> m ()+ unlessM testAction action = do+ sentinel <- testAction+ unless sentinel action++ go :: IO ()+ go = do+ -- Perform drawing, clear the dirty flag, do idle processing+ display'+ clearDirtyFlag+ idle'++ -- Swap buffers. This swaps the GL buffers and will block+ -- until the next v-sync. In GLFW, this effectively pegs the+ -- maximum frame rate to 60fps, but will also stop the+ -- application from consuming 100% CPU.+ swapBuffers'++ -- Poll for GLFW events; quit if necessary.+ GLFW.pollEvents+ unlessM windowShouldClose go++ -- Redisplay ------------------------------------------------------------------ postRedisplayGLFW :: IORef GLFWState@@ -530,31 +581,31 @@ 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'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@@ -613,7 +664,7 @@ GLFW.Key'PadDecimal -> SpecialKey KeyPadDecimal GLFW.Key'PadEqual -> Char '=' GLFW.Key'PadEnter -> SpecialKey KeyPadEnter- _ -> SpecialKey KeyUnknown+ _ -> SpecialKey KeyUnknown -- | Convert char keys to special keys to work around a bug in
Graphics/Gloss/Internals/Interface/Backend/GLUT.hs view
@@ -78,6 +78,10 @@ = do GL.Size sizeX sizeY <- get GLUT.windowSize return (fromEnum sizeX,fromEnum sizeY) + getScreenSize _+ = do GL.Size width height <- get GLUT.screenSize+ return (fromIntegral width, fromIntegral height)+ elapsedTime _ = do t <- get GLUT.elapsedTime return $ (fromIntegral t) / 1000
Graphics/Gloss/Internals/Interface/Backend/Types.hs view
@@ -64,6 +64,9 @@ -- | Function that returns (width,height) of the window in pixels. getWindowDimensions :: IORef a -> IO (Int,Int) + -- | Function that returns (width,height) of a fullscreen window in pixels.+ getScreenSize :: IORef a -> IO (Int,Int)+ -- | Function that reports the time elapsed since the application started. -- (in seconds) elapsedTime :: IORef a -> IO Double
gloss.cabal view
@@ -1,5 +1,5 @@ Name: gloss-Version: 1.13.1.2+Version: 1.13.2.1 License: MIT License-file: LICENSE Author: Ben Lippmeier@@ -35,11 +35,6 @@ Description: Enable the GLFW backend Default: False -Flag ExplicitBackend- Description: Expose versions of 'display' and friends that allow- you to choose what window manager backend to use.- Default: False- Library Build-Depends: base >= 4.8 && < 5@@ -108,11 +103,13 @@ If flag(GLUT) CPP-Options: -DWITHGLUT Other-modules:- Graphics.Gloss.Internals.Interface.Backend.GLUT+ Graphics.Gloss.Internals.Interface.Backend.GLUT + -- NOTE: GLUT is still required for text rendering, and must be initialized+ -- on Linux platforms. Thus, the GLFW backend still requires GLUT. If flag(GLFW) Build-Depends:- GLFW-b >= 1.4.1.0 && < 2+ GLFW-b >= 1.4.1.0 && < 2 CPP-Options: -DWITHGLFW Other-modules: Graphics.Gloss.Internals.Interface.Backend.GLFW