diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,16 @@ +2.1.0 +===== + +* Introduce `initializeAll` and deprecate `InitEverything`. To fix this deprecation + warning, change `initialize [InitEverything]` to `initializeAll`. +* `surfaceColorKey`, `surfaceFillRect` and `surfaceFillRects` now all operate on + on RGBA `V4 Word8` values. They all implicitly map and unmap (using `SDL_MapRGBA` + and `SDL_GetRGBA` respectively). +* `SDL.mapRGB` is now deprecated, as this conversion is always done for you. + If you still need this routine, use `SDL.Raw.mapRGB`. +* Fix a runtime crash when reading the current BlendMode of a texture. Thanks to + @seppeljordan for discovering and fixing this bug. + 2.0.0 ===== * Introduce a set of comprehensive high-level bindings to SDL. These bindings diff --git a/examples/AudioExample.hs b/examples/AudioExample.hs --- a/examples/AudioExample.hs +++ b/examples/AudioExample.hs @@ -15,7 +15,7 @@ let t = fromIntegral n / 48000 :: Double freq = 440 * 4 in round (fromIntegral (maxBound `div` 2 :: Int16) * sin (t * freq))) - [0 ..] + [0 :: Integer ..] audioCB :: IORef [Int16] -> AudioFormat sampleType -> IOVector sampleType -> IO () audioCB samples format buffer = @@ -32,7 +32,7 @@ main :: IO () main = - do initialize [InitEverything] + do initializeAll samples <- newIORef sinSamples (device,_) <- openAudioDevice diff --git a/examples/OpenGLExample.hs b/examples/OpenGLExample.hs new file mode 100644 --- /dev/null +++ b/examples/OpenGLExample.hs @@ -0,0 +1,139 @@ +--port of https://github.com/bergey/haskell-OpenGL-examples + +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module OpenGLExample where + +import Control.Monad +import Foreign.C.Types +import Linear +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as V +import System.Exit (exitFailure) +import System.IO + +import SDL (($=)) +import qualified SDL +import qualified Graphics.Rendering.OpenGL as GL + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +screenWidth, screenHeight :: CInt +(screenWidth, screenHeight) = (640, 480) + +main :: IO () +main = do + SDL.initialize [SDL.InitVideo] + SDL.HintRenderScaleQuality $= SDL.ScaleLinear + do renderQuality <- SDL.get SDL.HintRenderScaleQuality + when (renderQuality /= SDL.ScaleLinear) $ + putStrLn "Warning: Linear texture filtering not enabled!" + + window <- + SDL.createWindow + "SDL / OpenGL Example" + SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight, + SDL.windowOpenGL = Just SDL.defaultOpenGL} + SDL.showWindow window + + _ <- SDL.glCreateContext(window) + (prog, attrib) <- initResources + + let loop = do + let collectEvents = do + e <- SDL.pollEvent + case e of + Nothing -> return [] + Just e' -> (e' :) <$> collectEvents + events <- collectEvents + let quit = any (== SDL.QuitEvent) $ map SDL.eventPayload events + + GL.clear [GL.ColorBuffer] + draw prog attrib + SDL.glSwapWindow window + + unless quit (loop) + + loop + + SDL.destroyWindow window + SDL.quit + +initResources :: IO (GL.Program, GL.AttribLocation) +initResources = do + -- compile vertex shader + vs <- GL.createShader GL.VertexShader + GL.shaderSourceBS vs $= vsSource + GL.compileShader vs + vsOK <- GL.get $ GL.compileStatus vs + unless vsOK $ do + hPutStrLn stderr "Error in vertex shader\n" + exitFailure + + -- Do it again for the fragment shader + fs <- GL.createShader GL.FragmentShader + GL.shaderSourceBS fs $= fsSource + GL.compileShader fs + fsOK <- GL.get $ GL.compileStatus fs + unless fsOK $ do + hPutStrLn stderr "Error in fragment shader\n" + exitFailure + + program <- GL.createProgram + GL.attachShader program vs + GL.attachShader program fs + GL.attribLocation program "coord2d" $= GL.AttribLocation 0 + GL.linkProgram program + linkOK <- GL.get $ GL.linkStatus program + GL.validateProgram program + status <- GL.get $ GL.validateStatus program + unless (linkOK && status) $ do + hPutStrLn stderr "GL.linkProgram error" + plog <- GL.get $ GL.programInfoLog program + putStrLn plog + exitFailure + GL.currentProgram $= Just program + + return (program, GL.AttribLocation 0) + +draw :: GL.Program -> GL.AttribLocation -> IO () +draw program attrib = do + GL.clearColor $= GL.Color4 1 1 1 1 + GL.clear [GL.ColorBuffer] + GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral screenWidth) (fromIntegral screenHeight)) + + GL.currentProgram $= Just program + GL.vertexAttribArray attrib $= GL.Enabled + V.unsafeWith vertices $ \ptr -> + GL.vertexAttribPointer attrib $= + (GL.ToFloat, GL.VertexArrayDescriptor 2 GL.Float 0 ptr) + GL.drawArrays GL.Triangles 0 3 -- 3 is the number of vertices + GL.vertexAttribArray attrib $= GL.Disabled + +vsSource, fsSource :: BS.ByteString +vsSource = BS.intercalate "\n" + [ + "attribute vec2 coord2d; " + , "" + , "void main(void) { " + , " gl_Position = vec4(coord2d, 0.0, 1.0); " + , "}" + ] + +fsSource = BS.intercalate "\n" + [ + "" + , "#version 120" + , "void main(void) {" + , "gl_FragColor = vec4((gl_FragCoord.x/640), (gl_FragCoord.y/480), 0, 1);" + , "}" + ] + +vertices :: V.Vector Float +vertices = V.fromList [ 0.0, 0.8 + , -0.8, -0.8 + , 0.8, -0.8 + ] + diff --git a/examples/lazyfoo/Lesson01.hs b/examples/lazyfoo/Lesson01.hs --- a/examples/lazyfoo/Lesson01.hs +++ b/examples/lazyfoo/Lesson01.hs @@ -17,8 +17,7 @@ SDL.showWindow window screenSurface <- SDL.getWindowSurface window - screenSurfaceFormat <- SDL.surfaceFormat screenSurface - white <- SDL.mapRGB screenSurfaceFormat (V3 maxBound maxBound maxBound) + let white = V4 maxBound maxBound maxBound maxBound SDL.surfaceFillRect screenSurface Nothing white SDL.updateWindowSurface window diff --git a/examples/lazyfoo/Lesson10.hs b/examples/lazyfoo/Lesson10.hs --- a/examples/lazyfoo/Lesson10.hs +++ b/examples/lazyfoo/Lesson10.hs @@ -24,8 +24,7 @@ loadTexture r filePath = do surface <- getDataFileName filePath >>= SDL.loadBMP size <- SDL.surfaceDimensions surface - format <- SDL.surfaceFormat surface - key <- SDL.mapRGB format (V3 0 maxBound maxBound) + let key = V4 0 maxBound maxBound maxBound SDL.surfaceColorKey surface $= Just key t <- SDL.createTextureFromSurface r surface SDL.freeSurface surface diff --git a/examples/lazyfoo/Lesson11.hs b/examples/lazyfoo/Lesson11.hs --- a/examples/lazyfoo/Lesson11.hs +++ b/examples/lazyfoo/Lesson11.hs @@ -25,8 +25,7 @@ loadTexture r filePath = do surface <- getDataFileName filePath >>= SDL.loadBMP size <- SDL.surfaceDimensions surface - format <- SDL.surfaceFormat surface - key <- SDL.mapRGB format (V3 0 maxBound maxBound) + let key = V4 0 maxBound maxBound maxBound SDL.surfaceColorKey surface $= Just key t <- SDL.createTextureFromSurface r surface SDL.freeSurface surface diff --git a/examples/lazyfoo/Lesson12.hs b/examples/lazyfoo/Lesson12.hs --- a/examples/lazyfoo/Lesson12.hs +++ b/examples/lazyfoo/Lesson12.hs @@ -29,8 +29,7 @@ loadTexture r filePath = do surface <- getDataFileName filePath >>= SDL.loadBMP size <- SDL.surfaceDimensions surface - format <- SDL.surfaceFormat surface - key <- SDL.mapRGB format (V3 0 maxBound maxBound) + let key = V4 0 maxBound maxBound maxBound SDL.surfaceColorKey surface $= Just key t <- SDL.createTextureFromSurface r surface SDL.freeSurface surface diff --git a/examples/lazyfoo/Lesson13.hs b/examples/lazyfoo/Lesson13.hs --- a/examples/lazyfoo/Lesson13.hs +++ b/examples/lazyfoo/Lesson13.hs @@ -29,8 +29,7 @@ loadTexture r filePath = do surface <- getDataFileName filePath >>= SDL.loadBMP size <- SDL.surfaceDimensions surface - format <- SDL.surfaceFormat surface - key <- SDL.mapRGB format (V3 0 maxBound maxBound) + let key = V4 0 maxBound maxBound maxBound SDL.surfaceColorKey surface $= Just key t <- SDL.createTextureFromSurface r surface SDL.freeSurface surface diff --git a/examples/lazyfoo/Lesson14.hs b/examples/lazyfoo/Lesson14.hs --- a/examples/lazyfoo/Lesson14.hs +++ b/examples/lazyfoo/Lesson14.hs @@ -29,8 +29,7 @@ loadTexture r filePath = do surface <- getDataFileName filePath >>= SDL.loadBMP size <- SDL.surfaceDimensions surface - format <- SDL.surfaceFormat surface - key <- SDL.mapRGB format (V3 0 maxBound maxBound) + let key = V4 0 maxBound maxBound maxBound SDL.surfaceColorKey surface $= Just key t <- SDL.createTextureFromSurface r surface SDL.freeSurface surface diff --git a/examples/lazyfoo/Lesson15.hs b/examples/lazyfoo/Lesson15.hs --- a/examples/lazyfoo/Lesson15.hs +++ b/examples/lazyfoo/Lesson15.hs @@ -1,11 +1,10 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} module Lazyfoo.Lesson15 (main) where -import Control.Applicative import Control.Monad -import Data.Foldable import Data.Monoid import Data.Maybe import Foreign.C.Types @@ -16,6 +15,11 @@ import Paths_sdl2 (getDataFileName) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Foldable +#endif + screenWidth, screenHeight :: CInt (screenWidth, screenHeight) = (640, 480) @@ -25,8 +29,7 @@ loadTexture r filePath = do surface <- getDataFileName filePath >>= SDL.loadBMP size <- SDL.surfaceDimensions surface - format <- SDL.surfaceFormat surface - key <- SDL.mapRGB format (V3 0 maxBound maxBound) + let key = V4 0 maxBound maxBound maxBound SDL.surfaceColorKey surface $= Just key t <- SDL.createTextureFromSurface r surface SDL.freeSurface surface diff --git a/examples/lazyfoo/Lesson17.hs b/examples/lazyfoo/Lesson17.hs --- a/examples/lazyfoo/Lesson17.hs +++ b/examples/lazyfoo/Lesson17.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} @@ -5,7 +6,6 @@ module Lazyfoo.Lesson17 (main) where import Prelude hiding (foldl1) -import Control.Applicative import Control.Monad import Data.Foldable import Data.Monoid @@ -18,6 +18,10 @@ import Paths_sdl2 (getDataFileName) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + screenWidth, screenHeight :: CInt (screenWidth, screenHeight) = (640, 480) @@ -27,8 +31,7 @@ loadTexture r filePath = do surface <- getDataFileName filePath >>= SDL.loadBMP size <- SDL.surfaceDimensions surface - format <- SDL.surfaceFormat surface - key <- SDL.mapRGB format (V3 0 maxBound maxBound) + let key = V4 0 maxBound maxBound maxBound SDL.surfaceColorKey surface $= Just key t <- SDL.createTextureFromSurface r surface SDL.freeSurface surface diff --git a/examples/lazyfoo/Lesson18.hs b/examples/lazyfoo/Lesson18.hs --- a/examples/lazyfoo/Lesson18.hs +++ b/examples/lazyfoo/Lesson18.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} @@ -5,7 +6,6 @@ module Lazyfoo.Lesson18 (main) where import Prelude hiding (any, mapM_) -import Control.Applicative import Control.Monad hiding (mapM_) import Data.Foldable import Data.Maybe @@ -17,6 +17,10 @@ import Paths_sdl2 (getDataFileName) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + screenWidth, screenHeight :: CInt (screenWidth, screenHeight) = (640, 480) @@ -26,8 +30,7 @@ loadTexture r filePath = do surface <- getDataFileName filePath >>= SDL.loadBMP size <- SDL.surfaceDimensions surface - format <- SDL.surfaceFormat surface - key <- SDL.mapRGB format (V3 0 maxBound maxBound) + let key = V4 0 maxBound maxBound maxBound SDL.surfaceColorKey surface $= Just key t <- SDL.createTextureFromSurface r surface SDL.freeSurface surface diff --git a/examples/lazyfoo/Lesson19.hs b/examples/lazyfoo/Lesson19.hs --- a/examples/lazyfoo/Lesson19.hs +++ b/examples/lazyfoo/Lesson19.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} @@ -5,9 +6,7 @@ module Lazyfoo.Lesson19 (main) where import Prelude hiding (any, mapM_) -import Control.Applicative import Control.Monad hiding (mapM_) -import Data.Foldable import Data.Int import Data.Maybe import Data.Monoid @@ -20,6 +19,11 @@ import Paths_sdl2 (getDataFileName) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Foldable +#endif + screenWidth, screenHeight :: CInt (screenWidth, screenHeight) = (640, 480) @@ -32,8 +36,7 @@ loadTexture r filePath = do surface <- getDataFileName filePath >>= SDL.loadBMP size <- SDL.surfaceDimensions surface - format <- SDL.surfaceFormat surface - key <- SDL.mapRGB format (V3 0 maxBound maxBound) + let key = V4 0 maxBound maxBound maxBound SDL.surfaceColorKey surface $= Just key t <- SDL.createTextureFromSurface r surface SDL.freeSurface surface diff --git a/examples/lazyfoo/Lesson20.hs b/examples/lazyfoo/Lesson20.hs --- a/examples/lazyfoo/Lesson20.hs +++ b/examples/lazyfoo/Lesson20.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} @@ -5,20 +6,24 @@ module Lazyfoo.Lesson20 (main) where import Prelude hiding (any, mapM_) -import Control.Applicative import Control.Monad hiding (mapM_) -import Data.Foldable import Data.Maybe import Data.Monoid import Foreign.C.Types import Linear import Linear.Affine import SDL (($=)) +import SDL.Haptic import qualified SDL import qualified Data.Vector as V import Paths_sdl2 (getDataFileName) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Foldable +#endif + screenWidth, screenHeight :: CInt (screenWidth, screenHeight) = (640, 480) @@ -28,8 +33,7 @@ loadTexture r filePath = do surface <- getDataFileName filePath >>= SDL.loadBMP size <- SDL.surfaceDimensions surface - format <- SDL.surfaceFormat surface - key <- SDL.mapRGB format (V3 0 maxBound maxBound) + let key = V4 0 maxBound maxBound maxBound SDL.colorKey surface $= Just key t <- SDL.createTextureFromSurface r surface SDL.freeSurface surface diff --git a/examples/twinklebear/Lesson01.hs b/examples/twinklebear/Lesson01.hs --- a/examples/twinklebear/Lesson01.hs +++ b/examples/twinklebear/Lesson01.hs @@ -11,7 +11,7 @@ main :: IO () main = do - SDL.initialize [ SDL.InitEverything ] + SDL.initializeAll let winConfig = SDL.defaultWindow { SDL.windowPosition = SDL.Absolute (P (V2 100 100)) , SDL.windowInitialSize = V2 640 480 } diff --git a/examples/twinklebear/Lesson02.hs b/examples/twinklebear/Lesson02.hs --- a/examples/twinklebear/Lesson02.hs +++ b/examples/twinklebear/Lesson02.hs @@ -51,7 +51,7 @@ main :: IO () main = do - SDL.initialize [ SDL.InitEverything ] + SDL.initializeAll let winConfig = SDL.defaultWindow { SDL.windowInitialSize = V2 screenWidth screenHeight } rdrConfig = SDL.defaultRenderer { SDL.rendererType = SDL.AcceleratedRenderer } diff --git a/sdl2.cabal b/sdl2.cabal --- a/sdl2.cabal +++ b/sdl2.cabal @@ -1,5 +1,5 @@ name: sdl2 -version: 2.0.0 +version: 2.1.0 synopsis: Both high- and low-level bindings to the SDL library (version 2.0.3). description: This package contains bindings to the SDL 2 library, in both high- and @@ -110,7 +110,7 @@ base >= 4.7 && < 5, bytestring >= 0.10.4.0 && < 0.11, exceptions >= 0.4 && < 0.9, - linear >= 1.10.1.2 && < 1.20, + linear >= 1.10.1.2 && < 1.21, StateVar >= 1.1.0.0 && < 1.2, text >= 1.1.0.0 && < 1.3, transformers >= 0.2 && < 0.5, @@ -121,7 +121,7 @@ executable lazyfoo-lesson-01 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -132,7 +132,7 @@ executable lazyfoo-lesson-02 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -143,7 +143,7 @@ executable lazyfoo-lesson-03 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -154,7 +154,7 @@ executable lazyfoo-lesson-04 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -165,7 +165,7 @@ executable lazyfoo-lesson-05 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -176,7 +176,7 @@ executable lazyfoo-lesson-07 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -187,7 +187,7 @@ executable lazyfoo-lesson-08 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -198,7 +198,7 @@ executable lazyfoo-lesson-09 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -209,7 +209,7 @@ executable lazyfoo-lesson-10 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -220,7 +220,7 @@ executable lazyfoo-lesson-11 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.13, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -231,7 +231,7 @@ executable lazyfoo-lesson-12 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.13, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -242,7 +242,7 @@ executable lazyfoo-lesson-13 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.13, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -253,7 +253,7 @@ executable lazyfoo-lesson-14 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.13, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -264,7 +264,7 @@ executable lazyfoo-lesson-15 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.13, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -275,7 +275,7 @@ executable lazyfoo-lesson-17 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.13, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -286,7 +286,7 @@ executable lazyfoo-lesson-18 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.13, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -297,7 +297,7 @@ executable lazyfoo-lesson-19 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.13, linear >= 1.10.1.2 && < 1.20, vector >= 0.10.9.0 && < 0.12, sdl2 + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, vector >= 0.10.9.0 && < 0.12, sdl2 else buildable: False @@ -308,7 +308,7 @@ executable lazyfoo-lesson-20 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.13, linear >= 1.10.1.2 && < 1.20, vector >= 0.10.9.0 && < 0.12, sdl2 + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, vector >= 0.10.9.0 && < 0.12, sdl2 else buildable: False @@ -322,7 +322,7 @@ executable lazyfoo-lesson-43 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.13, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -333,7 +333,7 @@ executable twinklebear-lesson-01 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.13, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -344,7 +344,7 @@ executable twinklebear-lesson-02 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.13, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -355,7 +355,7 @@ executable twinklebear-lesson-04 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.13, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -366,7 +366,7 @@ executable twinklebear-lesson-04a if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.13, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -377,7 +377,7 @@ executable twinklebear-lesson-05 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.13, linear >= 1.10.1.2 && < 1.20, sdl2 + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, sdl2 else buildable: False @@ -388,7 +388,7 @@ executable audio-example if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.13, linear >= 1.10.1.2 && < 1.20, sdl2, vector + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, sdl2, vector else buildable: False @@ -396,3 +396,15 @@ main-is: AudioExample.hs default-language: Haskell2010 ghc-options: -Wall -main-is AudioExample -threaded + + +executable opengl-example + if flag(examples) + build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.14, linear >= 1.10.1.2 && < 1.21, sdl2, bytestring, OpenGL, vector + else + buildable: False + + hs-source-dirs: examples + main-is: OpenGLExample.hs + default-language: Haskell2010 + ghc-options: -Wall -main-is OpenGLExample diff --git a/src/SDL.hs b/src/SDL.hs --- a/src/SDL.hs +++ b/src/SDL.hs @@ -94,7 +94,7 @@ let eventIsQPress event = case 'eventPayload' event of 'KeyboardEvent' keyboardEvent -> - 'keyboardEventKeyMotion' keyboardEvent == 'KeyDown' && + 'keyboardEventKeyMotion' keyboardEvent == 'Pressed' && 'keysymKeycode' ('keyboardEventKeysym' keyboardEvent) == 'KeycodeQ' _ -> False qPressed = not (null (filter eventIsQPress events)) @@ -104,7 +104,7 @@ to clear the screen to blue: @ - 'rendererDrawColor' renderer '$=' V4 0 0 1 1 + 'rendererDrawColor' renderer '$=' V4 0 0 255 255 'clear' renderer 'present' renderer @ @@ -118,7 +118,13 @@ To recap, here is our full application @ + +\{\-\# LANGUAGE OverloadedStrings \#\-\} +module "Main" where + import "SDL" +import "Linear" (V4(..)) +import "Control.Monad" (unless) main :: IO () main = do @@ -133,11 +139,11 @@ let eventIsQPress event = case 'eventPayload' event of 'KeyboardEvent' keyboardEvent -> - 'keyboardEventKeyMotion' keyboardEvent == 'KeyDown' && + 'keyboardEventKeyMotion' keyboardEvent == 'Pressed' && 'keysymKeycode' ('keyboardEventKeysym' keyboardEvent) == 'KeycodeQ' _ -> False qPressed = not (null (filter eventIsQPress events)) - 'rendererDrawColor' renderer '$=' V4 0 0 1 1 + 'rendererDrawColor' renderer '$=' V4 0 0 255 255 'clear' renderer 'present' renderer unless qPressed (appLoop renderer) diff --git a/src/SDL/Init.hs b/src/SDL/Init.hs --- a/src/SDL/Init.hs +++ b/src/SDL/Init.hs @@ -7,6 +7,7 @@ module SDL.Init ( initialize + , initializeAll , InitFlag(..) , quit , version @@ -28,6 +29,7 @@ import Data.Foldable #endif +{-# DEPRECATED InitEverything "Instead of initialize [InitEverything], use initializeAll" #-} data InitFlag = InitTimer | InitAudio @@ -59,6 +61,10 @@ initialize flags = throwIfNeg_ "SDL.Init.init" "SDL_Init" $ Raw.init (foldFlags toNumber flags) + +-- | Equivalent to @'initialize' ['minBound' .. 'maxBound']@. +initializeAll :: (Functor m, MonadIO m) => m () +initializeAll = initialize [minBound .. maxBound] -- | Quit and shutdown SDL, freeing any resources that may have been in use. -- Do not call any SDL functions after you've called this function, unless diff --git a/src/SDL/Raw/Basic.hs b/src/SDL/Raw/Basic.hs --- a/src/SDL/Raw/Basic.hs +++ b/src/SDL/Raw/Basic.hs @@ -32,7 +32,7 @@ logWarn, -- * Assertions - -- | Use HaskellFFIs own assertion primitives rather than SDLFFIs. + -- | Use Haskell's own assertion primitives rather than SDL's. -- * Querying SDL Version getRevision, diff --git a/src/SDL/Video.hs b/src/SDL/Video.hs --- a/src/SDL/Video.hs +++ b/src/SDL/Video.hs @@ -158,7 +158,7 @@ -- , 'windowOpenGL' = Nothing -- , 'windowPosition' = 'Wherever' -- , 'windowResizable' = False --- , 'windowSize' = V2 800 600 +-- , 'windowInitialSize' = V2 800 600 -- } -- @ defaultWindow :: WindowConfig diff --git a/src/SDL/Video/Renderer.hs b/src/SDL/Video/Renderer.hs --- a/src/SDL/Video/Renderer.hs +++ b/src/SDL/Video/Renderer.hs @@ -338,12 +338,13 @@ surfaceFillRect :: MonadIO m => Surface -- ^ The 'Surface' that is the drawing target. -> Maybe (Rectangle CInt) -- ^ The rectangle to fill, or 'Nothing' to fill the entire surface. - -> Word32 -- ^ The color to fill with. This should be a pixel of the format used by the surface, and can be generated by 'mapRGB' or 'mapRGBA'. If the color value contains an alpha component then the destination is simply filled with that alpha information, no blending takes place. + -> V4 Word8 -- ^ The color to fill with. If the color value contains an alpha component then the destination is simply filled with that alpha information, no blending takes place. This colour will be implictly mapped to the closest approximation that matches the surface's pixel format. -> m () -surfaceFillRect (Surface s _) rect col = liftIO $ +surfaceFillRect (Surface s _) rect (V4 r g b a) = liftIO $ throwIfNeg_ "SDL.Video.fillRect" "SDL_FillRect" $ - maybeWith with rect $ \rectPtr -> - Raw.fillRect s (castPtr rectPtr) col + maybeWith with rect $ \rectPtr -> do + format <- liftIO (Raw.surfaceFormat <$> peek s) + Raw.mapRGBA format r g b a >>= Raw.fillRect s (castPtr rectPtr) -- | Perform a fast fill of a set of rectangles with a specific color. -- @@ -353,15 +354,16 @@ surfaceFillRects :: MonadIO m => Surface -- ^ The 'Surface' that is the drawing target. -> SV.Vector (Rectangle CInt) -- ^ A 'SV.Vector' of 'Rectangle's to be filled. - -> Word32 -- ^ The color to fill with. This should be a pixel of the format used by the surface, and can be generated by 'mapRGB' or 'mapRGBA'. If the color value contains an alpha component then the destination is simply filled with that alpha information, no blending takes place. + -> V4 Word8 -- ^ The color to fill with. If the color value contains an alpha component then the destination is simply filled with that alpha information, no blending takes place. This colour will be implictly mapped to the closest approximation that matches the surface's pixel format. -> m () -surfaceFillRects (Surface s _) rects col = liftIO $ do +surfaceFillRects (Surface s _) rects (V4 r g b a) = liftIO $ do throwIfNeg_ "SDL.Video.fillRects" "SDL_FillRects" $ - SV.unsafeWith rects $ \rp -> + SV.unsafeWith rects $ \rp -> do + format <- liftIO (Raw.surfaceFormat <$> peek s) Raw.fillRects s (castPtr rp) (fromIntegral (SV.length rects)) - col + =<< Raw.mapRGBA format r g b a -- | Free an RGB surface. -- @@ -402,6 +404,8 @@ -> m Word32 mapRGB (SurfacePixelFormat fmt) (V3 r g b) = Raw.mapRGB fmt r g b +{-# DEPRECATED mapRGB "mapRGB is no longer needed, as it called implictly. If you still need this, use SDL.Raw.mapRGB" #-} + -- It's possible we could use unsafePerformIO here, but I'm not -- sure. surface->{w,h} are immutable, but do we need to guarantee that pointers -- aren't reused by *different* surfaces. @@ -534,7 +538,7 @@ fromNumber n = case n of Raw.SDL_BLENDMODE_ADD -> BlendAdditive Raw.SDL_BLENDMODE_BLEND -> BlendAlphaBlend - Raw.SDL_BLENDMODE_ADD -> BlendAdditive + Raw.SDL_BLENDMODE_NONE -> BlendNone Raw.SDL_BLENDMODE_MOD -> BlendMod _ -> error $ "fromNumber: unknown blend mode: " ++ show n @@ -812,14 +816,23 @@ -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -- -- See @@ and @@ for C documentation. -surfaceColorKey :: Surface -> StateVar (Maybe Word32) +surfaceColorKey :: Surface -> StateVar (Maybe (V4 Word8)) surfaceColorKey (Surface s _) = makeStateVar getColorKey setColorKey where getColorKey = liftIO $ alloca $ \keyPtr -> do ret <- Raw.getColorKey s keyPtr - if ret == -1 then return Nothing else fmap Just (peek keyPtr) + if ret == -1 + then return Nothing + else do format <- liftIO (Raw.surfaceFormat <$> peek s) + mapped <- peek keyPtr + alloca $ \r -> + alloca $ \g -> + alloca $ \b -> + alloca $ \a -> + do Raw.getRGBA mapped format r g b a + Just <$> (V4 <$> peek r <*> peek g <*> peek b <*> peek a) setColorKey key = liftIO $ throwIfNeg_ "SDL.Video.Renderer.setColorKey" "SDL_SetColorKey" $ @@ -835,8 +848,9 @@ else do key' <- peek keyPtr Raw.setColorKey s 0 key' - Just key' -> do - Raw.setColorKey s 1 key' + Just (V4 r g b a) -> do + format <- liftIO (Raw.surfaceFormat <$> peek s) + Raw.mapRGBA format r g b a >>= Raw.setColorKey s 1 -- | Get or set the additional color value multiplied into render copy operations. --