diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,19 @@ +2.1.3 +===== + +* Cabal flag `no-linear` removes dependency on `linear` (and thus, transiently, + `lens`). See `SDL.Vect` for details. +* Remove 'lens' dependency from all examples. +* Add Cabal flag `opengl-example` to separate that target from `examples`, + because it is now the only example with an extra dependency (OpenGL). +* Make `hlint` happy with examples. +* Add `updateTexture` wrapper for native `SDL_UpdateTexture`. +* Expose `glGetDrawableSize` (can differ from window size in some environments). +* Correct `hintToString` output to match SDL hint tokens, rather than the names + of the CPP macros defining them. +* Removed `ghc-options: -Wall` until we drop support for GHC 7.8. (>1300 warnings!) +* Various documentation updates. + 2.1.2.1 ======= diff --git a/examples/AudioExample.hs b/examples/AudioExample.hs --- a/examples/AudioExample.hs +++ b/examples/AudioExample.hs @@ -7,7 +7,7 @@ import Control.Concurrent import Data.Int (Int16) import SDL -import Data.Vector.Storable.Mutable as V +import qualified Data.Vector.Storable.Mutable as V sinSamples :: [Int16] sinSamples = @@ -17,17 +17,17 @@ in round (fromIntegral (maxBound `div` 2 :: Int16) * sin (t * freq))) [0 :: Int16 ..] -audioCB :: IORef [Int16] -> AudioFormat sampleType -> IOVector sampleType -> IO () +audioCB :: IORef [Int16] -> AudioFormat sampleType -> V.IOVector sampleType -> IO () audioCB samples format buffer = case format of Signed16BitLEAudio -> do samples' <- readIORef samples let n = V.length buffer - sequence_ (zipWith (write buffer) - [0 ..] - (Prelude.take n samples')) + zipWithM_ (V.write buffer) + [0 ..] + (take n samples') writeIORef samples - (Prelude.drop n samples') + (drop n samples') _ -> error "Unsupported audio format" main :: IO () diff --git a/examples/OpenGLExample.hs b/examples/OpenGLExample.hs --- a/examples/OpenGLExample.hs +++ b/examples/OpenGLExample.hs @@ -6,7 +6,7 @@ import Control.Monad import Foreign.C.Types -import Linear +import SDL.Vect import qualified Data.ByteString as BS import qualified Data.Vector.Storable as V import System.Exit (exitFailure) @@ -16,10 +16,6 @@ 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) @@ -38,18 +34,18 @@ SDL.windowOpenGL = Just SDL.defaultOpenGL} SDL.showWindow window - _ <- SDL.glCreateContext(window) + _ <- SDL.glCreateContext window (prog, attrib) <- initResources let loop = do events <- SDL.pollEvents - let quit = any (== SDL.QuitEvent) $ map SDL.eventPayload events + let quit = elem SDL.QuitEvent $ map SDL.eventPayload events GL.clear [GL.ColorBuffer] draw prog attrib SDL.glSwapWindow window - unless quit (loop) + unless quit loop loop @@ -131,4 +127,3 @@ , -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 @@ -3,7 +3,7 @@ import Control.Concurrent (threadDelay) import Foreign.C.Types -import Linear +import SDL.Vect import qualified SDL screenWidth, screenHeight :: CInt diff --git a/examples/lazyfoo/Lesson02.hs b/examples/lazyfoo/Lesson02.hs --- a/examples/lazyfoo/Lesson02.hs +++ b/examples/lazyfoo/Lesson02.hs @@ -3,7 +3,7 @@ import Control.Concurrent (threadDelay) import Foreign.C.Types -import Linear +import SDL.Vect import qualified SDL import Paths_sdl2 (getDataFileName) diff --git a/examples/lazyfoo/Lesson03.hs b/examples/lazyfoo/Lesson03.hs --- a/examples/lazyfoo/Lesson03.hs +++ b/examples/lazyfoo/Lesson03.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -6,15 +5,11 @@ import Control.Monad import Foreign.C.Types -import Linear +import SDL.Vect import qualified SDL import Paths_sdl2 (getDataFileName) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - screenWidth, screenHeight :: CInt (screenWidth, screenHeight) = (640, 480) @@ -30,7 +25,7 @@ let loop = do events <- SDL.pollEvents - let quit = any (== SDL.QuitEvent) $ map SDL.eventPayload events + let quit = elem SDL.QuitEvent $ map SDL.eventPayload events SDL.surfaceBlit xOut Nothing screenSurface Nothing SDL.updateWindowSurface window diff --git a/examples/lazyfoo/Lesson04.hs b/examples/lazyfoo/Lesson04.hs --- a/examples/lazyfoo/Lesson04.hs +++ b/examples/lazyfoo/Lesson04.hs @@ -1,17 +1,16 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} module Lazyfoo.Lesson04 (main) where import Prelude hiding (any, mapM_) import Control.Monad hiding (mapM_) -import Data.Foldable +import Data.Foldable hiding (elem) import Data.Maybe import Data.Monoid -import Foreign.C.Types -import Linear +import Foreign.C.Types +import SDL.Vect import qualified SDL import Paths_sdl2 (getDataFileName) @@ -23,7 +22,7 @@ screenWidth, screenHeight :: CInt (screenWidth, screenHeight) = (640, 480) -loadBMP :: FilePath -> IO (SDL.Surface) +loadBMP :: FilePath -> IO SDL.Surface loadBMP path = getDataFileName path >>= SDL.loadBMP main :: IO () @@ -42,7 +41,7 @@ let loop oldSurface = do events <- map SDL.eventPayload <$> SDL.pollEvents - let quit = any (== SDL.QuitEvent) events + let quit = SDL.QuitEvent `elem` events currentSurface = fromMaybe oldSurface $ getLast $ diff --git a/examples/lazyfoo/Lesson05.hs b/examples/lazyfoo/Lesson05.hs --- a/examples/lazyfoo/Lesson05.hs +++ b/examples/lazyfoo/Lesson05.hs @@ -4,7 +4,7 @@ import Control.Monad import Foreign.C.Types -import Linear +import SDL.Vect import qualified SDL import Paths_sdl2 (getDataFileName) @@ -34,7 +34,7 @@ let loop = do events <- SDL.pollEvents - let quit = any (== SDL.QuitEvent) $ map SDL.eventPayload events + let quit = elem SDL.QuitEvent $ map SDL.eventPayload events SDL.surfaceBlitScaled stretchedSurface Nothing screenSurface Nothing SDL.updateWindowSurface window diff --git a/examples/lazyfoo/Lesson07.hs b/examples/lazyfoo/Lesson07.hs --- a/examples/lazyfoo/Lesson07.hs +++ b/examples/lazyfoo/Lesson07.hs @@ -1,19 +1,14 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Lazyfoo.Lesson07 (main) where import Control.Monad import Foreign.C.Types -import Linear +import SDL.Vect import SDL (($=)) import qualified SDL import Paths_sdl2 (getDataFileName) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - screenWidth, screenHeight :: CInt (screenWidth, screenHeight) = (640, 480) @@ -36,10 +31,10 @@ SDL.createRenderer window (-1) - (SDL.RendererConfig - { SDL.rendererType = SDL.AcceleratedRenderer - , SDL.rendererTargetTexture = False - }) + SDL.RendererConfig + { SDL.rendererType = SDL.AcceleratedRenderer + , SDL.rendererTargetTexture = False + } SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound @@ -50,7 +45,7 @@ let loop = do events <- SDL.pollEvents - let quit = any (== SDL.QuitEvent) $ map SDL.eventPayload events + let quit = elem SDL.QuitEvent $ map SDL.eventPayload events SDL.clear renderer SDL.copy renderer texture Nothing Nothing diff --git a/examples/lazyfoo/Lesson08.hs b/examples/lazyfoo/Lesson08.hs --- a/examples/lazyfoo/Lesson08.hs +++ b/examples/lazyfoo/Lesson08.hs @@ -1,19 +1,13 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Lazyfoo.Lesson08 (main) where import Control.Monad import Data.Foldable (for_) import Foreign.C.Types -import Linear -import Linear.Affine +import SDL.Vect import SDL (($=)) import qualified SDL -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - screenWidth, screenHeight :: CInt (screenWidth, screenHeight) = (640, 480) @@ -36,17 +30,17 @@ SDL.createRenderer window (-1) - (SDL.RendererConfig + SDL.RendererConfig { SDL.rendererType = SDL.AcceleratedRenderer , SDL.rendererTargetTexture = False - }) + } SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound let loop = do events <- SDL.pollEvents - let quit = any (== SDL.QuitEvent) $ map SDL.eventPayload events + let quit = elem SDL.QuitEvent $ map SDL.eventPayload events SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound SDL.clear renderer diff --git a/examples/lazyfoo/Lesson09.hs b/examples/lazyfoo/Lesson09.hs --- a/examples/lazyfoo/Lesson09.hs +++ b/examples/lazyfoo/Lesson09.hs @@ -1,20 +1,14 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Lazyfoo.Lesson09 (main) where import Control.Monad import Foreign.C.Types -import Linear -import Linear.Affine +import SDL.Vect import SDL (($=)) import qualified SDL import Paths_sdl2 (getDataFileName) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - screenWidth, screenHeight :: CInt (screenWidth, screenHeight) = (640, 480) @@ -37,10 +31,10 @@ SDL.createRenderer window (-1) - (SDL.RendererConfig - { SDL.rendererType = SDL.AcceleratedRenderer - , SDL.rendererTargetTexture = False - }) + SDL.RendererConfig + { SDL.rendererType = SDL.AcceleratedRenderer + , SDL.rendererTargetTexture = False + } SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound @@ -51,7 +45,7 @@ let loop = do events <- SDL.pollEvents - let quit = any (== SDL.QuitEvent) $ map SDL.eventPayload events + let quit = elem SDL.QuitEvent $ map SDL.eventPayload events SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound SDL.clear renderer diff --git a/examples/lazyfoo/Lesson10.hs b/examples/lazyfoo/Lesson10.hs --- a/examples/lazyfoo/Lesson10.hs +++ b/examples/lazyfoo/Lesson10.hs @@ -1,20 +1,14 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Lazyfoo.Lesson10 (main) where import Control.Monad import Foreign.C.Types -import Linear -import Linear.Affine +import SDL.Vect import SDL (($=)) import qualified SDL import Paths_sdl2 (getDataFileName) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - screenWidth, screenHeight :: CInt (screenWidth, screenHeight) = (640, 480) @@ -53,10 +47,10 @@ SDL.createRenderer window (-1) - (SDL.RendererConfig - { SDL.rendererType = SDL.AcceleratedRenderer - , SDL.rendererTargetTexture = False - }) + SDL.RendererConfig + { SDL.rendererType = SDL.AcceleratedRenderer + , SDL.rendererTargetTexture = False + } SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound @@ -66,7 +60,7 @@ let loop = do events <- SDL.pollEvents - let quit = any (== SDL.QuitEvent) $ map SDL.eventPayload events + let quit = elem SDL.QuitEvent $ map SDL.eventPayload events SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound SDL.clear renderer diff --git a/examples/lazyfoo/Lesson11.hs b/examples/lazyfoo/Lesson11.hs --- a/examples/lazyfoo/Lesson11.hs +++ b/examples/lazyfoo/Lesson11.hs @@ -2,11 +2,9 @@ {-# LANGUAGE OverloadedStrings #-} module Lazyfoo.Lesson11 (main) where -import Control.Lens.Operators import Control.Monad import Foreign.C.Types -import Linear -import Linear.Affine +import SDL.Vect import SDL (($=)) import qualified SDL @@ -55,10 +53,10 @@ SDL.createRenderer window (-1) - (SDL.RendererConfig - { SDL.rendererType = SDL.SoftwareRenderer - , SDL.rendererTargetTexture = False - }) + SDL.RendererConfig + { SDL.rendererType = SDL.SoftwareRenderer + , SDL.rendererTargetTexture = False + } SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound @@ -72,15 +70,15 @@ let loop = do events <- SDL.pollEvents - let quit = any (== SDL.QuitEvent) $ map SDL.eventPayload events + let quit = elem SDL.QuitEvent $ map SDL.eventPayload events SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound SDL.clear renderer renderTexture renderer spriteSheetTexture (P (V2 0 0)) (Just clip1) - renderTexture renderer spriteSheetTexture (P (V2 (screenWidth - spriteSize ^. _x) 0)) (Just clip2) - renderTexture renderer spriteSheetTexture (P (V2 0 (screenHeight - spriteSize ^. _y))) (Just clip3) - renderTexture renderer spriteSheetTexture (P (V2 (screenWidth - spriteSize ^. _x) (screenHeight - spriteSize ^. _y))) (Just clip4) + renderTexture renderer spriteSheetTexture (P (V2 (screenWidth -) (const 0) <*> spriteSize)) (Just clip2) + renderTexture renderer spriteSheetTexture (P (V2 (const 0) (screenHeight -) <*> spriteSize)) (Just clip3) + renderTexture renderer spriteSheetTexture (P (V2 (screenWidth -) (screenHeight -) <*> spriteSize)) (Just clip4) SDL.present renderer diff --git a/examples/lazyfoo/Lesson12.hs b/examples/lazyfoo/Lesson12.hs --- a/examples/lazyfoo/Lesson12.hs +++ b/examples/lazyfoo/Lesson12.hs @@ -2,21 +2,20 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} module Lazyfoo.Lesson12 (main) where import Control.Monad import Data.Monoid import Data.Word import Foreign.C.Types -import Linear -import Linear.Affine +import SDL.Vect import SDL (($=)) import qualified SDL import Paths_sdl2 (getDataFileName) #if !MIN_VERSION_base(4,8,0) -import Control.Applicative import Data.Foldable #endif @@ -62,10 +61,10 @@ SDL.createRenderer window (-1) - (SDL.RendererConfig + SDL.RendererConfig { SDL.rendererType = SDL.SoftwareRenderer , SDL.rendererTargetTexture = False - }) + } SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound diff --git a/examples/lazyfoo/Lesson13.hs b/examples/lazyfoo/Lesson13.hs --- a/examples/lazyfoo/Lesson13.hs +++ b/examples/lazyfoo/Lesson13.hs @@ -2,21 +2,20 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} module Lazyfoo.Lesson13 (main) where import Control.Monad import Data.Monoid import Data.Word import Foreign.C.Types -import Linear -import Linear.Affine +import SDL.Vect import SDL (($=)) import qualified SDL import Paths_sdl2 (getDataFileName) #if !MIN_VERSION_base(4,8,0) -import Control.Applicative import Data.Foldable #endif @@ -65,10 +64,10 @@ SDL.createRenderer window (-1) - (SDL.RendererConfig + SDL.RendererConfig { SDL.rendererType = SDL.UnacceleratedRenderer , SDL.rendererTargetTexture = False - }) + } SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound diff --git a/examples/lazyfoo/Lesson14.hs b/examples/lazyfoo/Lesson14.hs --- a/examples/lazyfoo/Lesson14.hs +++ b/examples/lazyfoo/Lesson14.hs @@ -1,25 +1,15 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} module Lazyfoo.Lesson14 (main) where import Control.Monad -import Data.Monoid import Foreign.C.Types -import Linear -import Linear.Affine +import SDL.Vect import SDL (($=)) import qualified SDL 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) @@ -59,10 +49,10 @@ SDL.createRenderer window (-1) - (SDL.RendererConfig - { SDL.rendererType = SDL.AcceleratedVSyncRenderer - , SDL.rendererTargetTexture = False - }) + SDL.RendererConfig + { SDL.rendererType = SDL.AcceleratedVSyncRenderer + , SDL.rendererTargetTexture = False + } SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound @@ -77,7 +67,7 @@ loop (frame:frames) = do events <- SDL.pollEvents - let quit = any (== SDL.QuitEvent) $ map SDL.eventPayload events + let quit = elem SDL.QuitEvent $ map SDL.eventPayload events SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound SDL.clear renderer diff --git a/examples/lazyfoo/Lesson15.hs b/examples/lazyfoo/Lesson15.hs --- a/examples/lazyfoo/Lesson15.hs +++ b/examples/lazyfoo/Lesson15.hs @@ -2,14 +2,14 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} module Lazyfoo.Lesson15 (main) where import Control.Monad import Data.Monoid import Data.Maybe import Foreign.C.Types -import Linear -import Linear.Affine +import SDL.Vect import SDL (($=)) import qualified SDL @@ -69,10 +69,10 @@ SDL.createRenderer window (-1) - (SDL.RendererConfig + SDL.RendererConfig { SDL.rendererType = SDL.AcceleratedVSyncRenderer , SDL.rendererTargetTexture = False - }) + } SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound diff --git a/examples/lazyfoo/Lesson17.hs b/examples/lazyfoo/Lesson17.hs --- a/examples/lazyfoo/Lesson17.hs +++ b/examples/lazyfoo/Lesson17.hs @@ -1,18 +1,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} module Lazyfoo.Lesson17 (main) where -import Prelude hiding (foldl1) +import Prelude hiding (foldl1, and) import Control.Monad import Data.Foldable import Data.Monoid import Data.Maybe import Foreign.C.Types -import Linear -import Linear.Affine +import SDL.Vect import SDL (($=)) import qualified SDL @@ -59,8 +56,8 @@ handleEvent :: Point V2 CInt -> SDL.EventPayload -> Button -> Button handleEvent mousePos ev (Button buttonPos _) = - let inside = foldl1 (&&) ((>=) <$> mousePos <*> buttonPos) && - foldl1 (&&) ((<=) <$> mousePos <*> buttonPos .+^ buttonSize) + let inside = and ((>=) <$> mousePos <*> buttonPos) && + and ((<=) <$> mousePos <*> buttonPos + P buttonSize) sprite | inside = case ev of SDL.MouseButtonEvent e @@ -103,10 +100,10 @@ SDL.createRenderer window (-1) - (SDL.RendererConfig + SDL.RendererConfig { SDL.rendererType = SDL.AcceleratedVSyncRenderer , SDL.rendererTargetTexture = False - }) + } SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound diff --git a/examples/lazyfoo/Lesson18.hs b/examples/lazyfoo/Lesson18.hs --- a/examples/lazyfoo/Lesson18.hs +++ b/examples/lazyfoo/Lesson18.hs @@ -2,16 +2,14 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Lazyfoo.Lesson18 (main) where import Prelude hiding (any, mapM_) import Control.Monad hiding (mapM_) -import Data.Foldable +import Data.Foldable hiding (elem) import Data.Maybe import Foreign.C.Types -import Linear -import Linear.Affine +import SDL.Vect import SDL (($=)) import qualified SDL @@ -66,10 +64,10 @@ SDL.createRenderer window (-1) - (SDL.RendererConfig - { SDL.rendererType = SDL.AcceleratedVSyncRenderer - , SDL.rendererTargetTexture = False - }) + SDL.RendererConfig + { SDL.rendererType = SDL.AcceleratedVSyncRenderer + , SDL.rendererTargetTexture = False + } SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound @@ -82,7 +80,7 @@ let loop = do events <- map SDL.eventPayload <$> SDL.pollEvents - let quit = any (== SDL.QuitEvent) events + let quit = SDL.QuitEvent `elem` events keyMap <- SDL.getKeyboardState let texture = diff --git a/examples/lazyfoo/Lesson19.hs b/examples/lazyfoo/Lesson19.hs --- a/examples/lazyfoo/Lesson19.hs +++ b/examples/lazyfoo/Lesson19.hs @@ -2,7 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} module Lazyfoo.Lesson19 (main) where import Prelude hiding (any, mapM_) @@ -11,8 +11,7 @@ import Data.Maybe import Data.Monoid import Foreign.C.Types -import Linear -import Linear.Affine +import SDL.Vect import SDL (($=)) import qualified SDL import qualified Data.Vector as V @@ -57,7 +56,7 @@ textureSize :: Texture -> V2 CInt textureSize (Texture _ sz) = sz -getJoystick :: IO (SDL.Joystick) +getJoystick :: IO SDL.Joystick getJoystick = do joysticks <- SDL.availableJoysticks joystick <- if V.length joysticks == 0 @@ -86,10 +85,10 @@ SDL.createRenderer window (-1) - (SDL.RendererConfig + SDL.RendererConfig { SDL.rendererType = SDL.AcceleratedVSyncRenderer , SDL.rendererTargetTexture = False - }) + } SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound @@ -131,7 +130,7 @@ let dir@(xDir, yDir) = fromMaybe (xDir', yDir') newDir phi = if xDir == 0 && yDir == 0 then 0 - else (atan2 yDir xDir) * (180.0 / pi) + else atan2 yDir xDir * (180.0 / pi) renderTexture renderer arrowTexture (P (fmap (`div` 2) (V2 screenWidth screenHeight) - fmap (`div` 2) (textureSize arrowTexture))) Nothing (Just phi) Nothing Nothing diff --git a/examples/lazyfoo/Lesson20.hs b/examples/lazyfoo/Lesson20.hs --- a/examples/lazyfoo/Lesson20.hs +++ b/examples/lazyfoo/Lesson20.hs @@ -2,7 +2,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Lazyfoo.Lesson20 (main) where import Prelude hiding (any, mapM_) @@ -10,8 +9,7 @@ import Data.Maybe import Data.Monoid import Foreign.C.Types -import Linear -import Linear.Affine +import SDL.Vect import SDL (($=)) import SDL.Haptic import qualified SDL @@ -51,7 +49,7 @@ center (fromMaybe (pure False) flips) -getJoystick :: IO (SDL.Joystick) +getJoystick :: IO SDL.Joystick getJoystick = do joysticks <- SDL.availableJoysticks joystick <- if V.length joysticks == 0 @@ -79,10 +77,10 @@ SDL.createRenderer window (-1) - (SDL.RendererConfig + SDL.RendererConfig { SDL.rendererType = SDL.AcceleratedVSyncRenderer , SDL.rendererTargetTexture = False - }) + } SDL.renderDrawColor renderer $= V4 maxBound maxBound maxBound maxBound @@ -100,9 +98,9 @@ SDL.QuitEvent -> (Any True, mempty) SDL.KeyboardEvent e -> if | SDL.keyboardEventKeyMotion e == SDL.Pressed -> - case scancode = SDL.keysymScancode (SDL.keyboardEventKeysym e) of - SDL.ScancodeEscape -> (Any True, mempty) - _ -> mempty + case SDL.keysymScancode (SDL.keyboardEventKeysym e) of + SDL.ScancodeEscape -> (Any True, mempty) + _ -> mempty | otherwise -> mempty SDL.JoyButtonEvent e -> if | SDL.joyButtonEventState e /= 0 -> (mempty, Any True) @@ -110,9 +108,7 @@ _ -> mempty) $ map SDL.eventPayload events - if buttonDown - then SDL.hapticRumblePlay hapticDevice 0.75 500 - else return () + when buttonDown $ SDL.hapticRumblePlay hapticDevice 0.75 500 SDL.renderDrawColor renderer $= V4 maxBound maxBound maxBound maxBound SDL.renderClear renderer @@ -121,7 +117,7 @@ SDL.renderPresent renderer - unless quit $ loop + unless quit loop loop diff --git a/examples/lazyfoo/Lesson43.hs b/examples/lazyfoo/Lesson43.hs --- a/examples/lazyfoo/Lesson43.hs +++ b/examples/lazyfoo/Lesson43.hs @@ -1,17 +1,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Lazyfoo.Lesson43 (main) where import Prelude hiding (any, mapM_) import Control.Monad hiding (mapM_) -import Data.Foldable +import Data.Foldable hiding (elem) import Data.Maybe import Foreign.C.Types -import Linear -import Linear.Affine +import SDL.Vect import SDL (($=)) import qualified SDL @@ -62,10 +59,10 @@ SDL.createRenderer window (-1) - (SDL.RendererConfig - { SDL.rendererType = SDL.AcceleratedVSyncRenderer - , SDL.rendererTargetTexture = False - }) + SDL.RendererConfig + { SDL.rendererType = SDL.AcceleratedVSyncRenderer + , SDL.rendererTargetTexture = False + } SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound @@ -76,7 +73,7 @@ loop theta = do events <- map SDL.eventPayload <$> SDL.pollEvents - let quit = any (== SDL.QuitEvent) events + let quit = SDL.QuitEvent `elem` events setAsRenderTarget renderer (Just targetTexture) diff --git a/examples/twinklebear/Lesson01.hs b/examples/twinklebear/Lesson01.hs --- a/examples/twinklebear/Lesson01.hs +++ b/examples/twinklebear/Lesson01.hs @@ -3,8 +3,7 @@ import Prelude hiding (init) -import Linear -import Linear.Affine ( Point(P) ) +import SDL.Vect import qualified SDL import Paths_sdl2 (getDataFileName) diff --git a/examples/twinklebear/Lesson02.hs b/examples/twinklebear/Lesson02.hs --- a/examples/twinklebear/Lesson02.hs +++ b/examples/twinklebear/Lesson02.hs @@ -5,8 +5,7 @@ import Prelude hiding (init) import Control.Monad import Foreign.C.Types -import Linear -import Linear.Affine ( Point(P) ) +import SDL.Vect import qualified SDL import Paths_sdl2 (getDataFileName) @@ -36,7 +35,7 @@ At p -> p Centered -> let cntr a b = (a - b) `div` 2 in P $ V2 (cntr screenWidth w) (cntr screenHeight h) - extent = (V2 w h) + extent = V2 w h SDL.copy renderer tex Nothing (Just $ SDL.Rectangle pos' extent) diff --git a/examples/twinklebear/Lesson04.hs b/examples/twinklebear/Lesson04.hs --- a/examples/twinklebear/Lesson04.hs +++ b/examples/twinklebear/Lesson04.hs @@ -6,8 +6,7 @@ import Prelude hiding (init) import Control.Monad import Foreign.C.Types -import Linear -import Linear.Affine ( Point(P) ) +import SDL.Vect import qualified SDL import Paths_sdl2 (getDataFileName) @@ -37,7 +36,7 @@ At p -> p Centered -> let cntr a b = (a - b) `div` 2 in P $ V2 (cntr screenWidth w) (cntr screenHeight h) - extent = (V2 w h) + extent = V2 w h SDL.copy renderer tex Nothing (Just $ SDL.Rectangle pos' extent) diff --git a/examples/twinklebear/Lesson04a.hs b/examples/twinklebear/Lesson04a.hs --- a/examples/twinklebear/Lesson04a.hs +++ b/examples/twinklebear/Lesson04a.hs @@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PatternSynonyms #-} module TwinkleBear.Lesson04a (main) where @@ -10,8 +10,7 @@ import Control.Monad import Data.Monoid import Foreign.C.Types -import Linear -import Linear.Affine ( Point(P) ) +import SDL.Vect import qualified SDL import Paths_sdl2 (getDataFileName) @@ -42,7 +41,7 @@ At p -> p Centered -> let cntr a b = (a - b) `div` 2 in P $ V2 (cntr screenWidth w) (cntr screenHeight h) - extent = (V2 w h) + extent = V2 w h SDL.copy renderer tex Nothing (Just $ SDL.Rectangle pos' extent) @@ -84,7 +83,7 @@ unless quit $ loop imgPos' - loop $ (V2 100 100) + loop $ V2 100 100 SDL.destroyTexture image SDL.destroyRenderer renderer diff --git a/examples/twinklebear/Lesson05.hs b/examples/twinklebear/Lesson05.hs --- a/examples/twinklebear/Lesson05.hs +++ b/examples/twinklebear/Lesson05.hs @@ -1,8 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PatternSynonyms #-} module TwinkleBear.Lesson05 (main) where import Prelude hiding (init) @@ -10,8 +10,7 @@ import Control.Monad import Data.Monoid import Foreign.C.Types -import Linear -import Linear.Affine ( Point(P) ) +import SDL.Vect import qualified SDL import Paths_sdl2 (getDataFileName) @@ -46,7 +45,7 @@ At p -> p Centered -> let cntr a b = (a - b) `div` 2 in P $ V2 (cntr screenWidth w) (cntr screenHeight h) - extent = (V2 w h) + extent = V2 w h SDL.copy renderer tex clipRect (Just $ SDL.Rectangle pos' extent) diff --git a/sdl2.cabal b/sdl2.cabal --- a/sdl2.cabal +++ b/sdl2.cabal @@ -1,6 +1,6 @@ name: sdl2 -version: 2.1.2.1 -synopsis: Both high- and low-level bindings to the SDL library (version 2.0.2). +version: 2.1.3 +synopsis: Both high- and low-level bindings to the SDL library (version 2.0.2+). description: This package contains bindings to the SDL 2 library, in both high- and low-level forms: @@ -41,11 +41,20 @@ -- tag: 2.0.0 flag examples - description: Build examples + description: Build examples (except opengl-example) default: False +flag opengl-example + description: Build opengl-example + default: False + +flag no-linear + description: Do not depend on 'linear' library + default: False + manual: True + library - ghc-options: -Wall + -- ghc-options: -Wall exposed-modules: SDL @@ -61,11 +70,13 @@ SDL.Input.Mouse SDL.Power SDL.Time + SDL.Vect SDL.Video SDL.Video.OpenGL SDL.Video.Renderer SDL.Internal.Types + SDL.Internal.Vect SDL.Raw SDL.Raw.Audio @@ -110,205 +121,210 @@ base >= 4.7 && < 5, bytestring >= 0.10.4.0 && < 0.11, exceptions >= 0.4 && < 0.9, - 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.6, vector >= 0.10.9.0 && < 0.12 + if flag(no-linear) + cpp-options: -Dnolinear + else + build-depends: + linear >= 1.10.1.2 && < 1.21 + default-language: Haskell2010 executable lazyfoo-lesson-01 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson01.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson01 + ghc-options: -main-is Lazyfoo.Lesson01 executable lazyfoo-lesson-02 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson02.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson02 + ghc-options: -main-is Lazyfoo.Lesson02 executable lazyfoo-lesson-03 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson03.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson03 + ghc-options: -main-is Lazyfoo.Lesson03 executable lazyfoo-lesson-04 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson04.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson04 + ghc-options: -main-is Lazyfoo.Lesson04 executable lazyfoo-lesson-05 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson05.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson05 + ghc-options: -main-is Lazyfoo.Lesson05 executable lazyfoo-lesson-07 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson07.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson07 + ghc-options: -main-is Lazyfoo.Lesson07 executable lazyfoo-lesson-08 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson08.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson08 + ghc-options: -main-is Lazyfoo.Lesson08 executable lazyfoo-lesson-09 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson09.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson09 + ghc-options: -main-is Lazyfoo.Lesson09 executable lazyfoo-lesson-10 if flag(examples) - build-depends: base >= 4.7 && < 5, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson10.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson10 + ghc-options: -main-is Lazyfoo.Lesson10 executable lazyfoo-lesson-11 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson11.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson11 + ghc-options: -main-is Lazyfoo.Lesson11 executable lazyfoo-lesson-12 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson12.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson12 + ghc-options: -main-is Lazyfoo.Lesson12 executable lazyfoo-lesson-13 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson13.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson13 + ghc-options: -main-is Lazyfoo.Lesson13 executable lazyfoo-lesson-14 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson14.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson14 + ghc-options: -main-is Lazyfoo.Lesson14 executable lazyfoo-lesson-15 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson15.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson15 + ghc-options: -main-is Lazyfoo.Lesson15 executable lazyfoo-lesson-17 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson17.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson17 + ghc-options: -main-is Lazyfoo.Lesson17 executable lazyfoo-lesson-18 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson18.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson18 + ghc-options: -main-is Lazyfoo.Lesson18 executable lazyfoo-lesson-19 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, vector >= 0.10.9.0 && < 0.12, sdl2 + build-depends: base, vector, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson19.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson19 + ghc-options: -main-is Lazyfoo.Lesson19 executable lazyfoo-lesson-20 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, vector >= 0.10.9.0 && < 0.12, sdl2 + build-depends: base, vector, sdl2 else buildable: False @@ -318,93 +334,93 @@ hs-source-dirs: examples/lazyfoo main-is: Lesson20.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson20 + ghc-options: -main-is Lazyfoo.Lesson20 executable lazyfoo-lesson-43 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/lazyfoo main-is: Lesson43.hs default-language: Haskell2010 - ghc-options: -Wall -main-is Lazyfoo.Lesson43 + ghc-options: -main-is Lazyfoo.Lesson43 executable twinklebear-lesson-01 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/twinklebear main-is: Lesson01.hs default-language: Haskell2010 - ghc-options: -Wall -main-is TwinkleBear.Lesson01 + ghc-options: -main-is TwinkleBear.Lesson01 executable twinklebear-lesson-02 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/twinklebear main-is: Lesson02.hs default-language: Haskell2010 - ghc-options: -Wall -main-is TwinkleBear.Lesson02 + ghc-options: -main-is TwinkleBear.Lesson02 executable twinklebear-lesson-04 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/twinklebear main-is: Lesson04.hs default-language: Haskell2010 - ghc-options: -Wall -main-is TwinkleBear.Lesson04 + ghc-options: -main-is TwinkleBear.Lesson04 executable twinklebear-lesson-04a if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/twinklebear main-is: Lesson04a.hs default-language: Haskell2010 - ghc-options: -Wall -main-is TwinkleBear.Lesson04a + ghc-options: -main-is TwinkleBear.Lesson04a executable twinklebear-lesson-05 if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, sdl2 + build-depends: base, sdl2 else buildable: False hs-source-dirs: examples/twinklebear main-is: Lesson05.hs default-language: Haskell2010 - ghc-options: -Wall -main-is TwinkleBear.Lesson05 + ghc-options: -main-is TwinkleBear.Lesson05 executable audio-example if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, sdl2, vector + build-depends: base, vector, sdl2 else buildable: False hs-source-dirs: examples main-is: AudioExample.hs default-language: Haskell2010 - ghc-options: -Wall -main-is AudioExample -threaded + ghc-options: -main-is AudioExample -threaded executable opengl-example - if flag(examples) - build-depends: base >= 4.7 && < 5, lens >= 4.4.0.2 && < 4.15, linear >= 1.10.1.2 && < 1.21, sdl2, bytestring, OpenGL, vector + if flag(opengl-example) + build-depends: base, OpenGL, bytestring, vector, sdl2 else buildable: False hs-source-dirs: examples main-is: OpenGLExample.hs default-language: Haskell2010 - ghc-options: -Wall -main-is OpenGLExample + ghc-options: -main-is OpenGLExample diff --git a/src/SDL.hs b/src/SDL.hs --- a/src/SDL.hs +++ b/src/SDL.hs @@ -23,6 +23,7 @@ , module SDL.Input , module SDL.Power , module SDL.Time + , module SDL.Vect , module SDL.Video -- * Working with State Variables @@ -45,6 +46,7 @@ import SDL.Input import SDL.Power import SDL.Time +import SDL.Vect import SDL.Video {- $gettingStarted diff --git a/src/SDL/Event.hs b/src/SDL/Event.hs --- a/src/SDL/Event.hs +++ b/src/SDL/Event.hs @@ -1,731 +1,730 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} - --- | "SDL.Event" exports an interface for working with the SDL event model. Event handling allows your application to receive input from the user. Internally, SDL stores all the events waiting to be handled in an event queue. Using functions like 'pollEvent' and 'waitEvent' you can observe and handle waiting input events. --- --- The event queue itself is composed of a series of 'Event' values, one for each waiting event. 'Event' values are read from the queue with the 'pollEvent' function and it is then up to the application to process the information stored with them. -module SDL.Event - ( -- * Polling events - pollEvent - , pollEvents - , mapEvents - , pumpEvents - , waitEvent - , waitEventTimeout - -- * Event data - , Event(..) - , EventPayload(..) - -- ** Window events - , WindowShownEventData(..) - , WindowHiddenEventData(..) - , WindowExposedEventData(..) - , WindowMovedEventData(..) - , WindowResizedEventData(..) - , WindowSizeChangedEventData(..) - , WindowMinimizedEventData(..) - , WindowMaximizedEventData(..) - , WindowRestoredEventData(..) - , WindowGainedMouseFocusEventData(..) - , WindowLostMouseFocusEventData(..) - , WindowGainedKeyboardFocusEventData(..) - , WindowLostKeyboardFocusEventData(..) - , WindowClosedEventData(..) - , SysWMEventData(..) - -- ** Keyboard events - , KeyboardEventData(..) - , TextEditingEventData(..) - , TextInputEventData(..) - -- ** Mouse events - , MouseMotionEventData(..) - , MouseButtonEventData(..) - , MouseWheelEventData(..) - -- ** Joystick events - , JoyAxisEventData(..) - , JoyBallEventData(..) - , JoyHatEventData(..) - , JoyButtonEventData(..) - , JoyDeviceEventData(..) - -- ** Controller events - , ControllerAxisEventData(..) - , ControllerButtonEventData(..) - , ControllerDeviceEventData(..) - -- ** User events - , UserEventData(..) - -- ** Touch events - , TouchFingerEventData(..) - -- ** Gesture events - , MultiGestureEventData(..) - , DollarGestureEventData(..) - -- ** Drag and drop events - , DropEventData(..) - -- ** Clipboard events - , ClipboardUpdateEventData(..) - -- ** Unknown events - , UnknownEventData(..) - -- * Auxiliary event data - , InputMotion(..) - , MouseButton(..) - ) where - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Data (Data) -import Data.Maybe (catMaybes) -import Data.Text (Text) -import Data.Typeable -import Foreign -import Foreign.C -import GHC.Generics (Generic) -import Linear -import Linear.Affine (Point(P)) -import SDL.Input.Keyboard -import SDL.Input.Mouse -import SDL.Internal.Numbered -import SDL.Internal.Types (Window(Window)) -import qualified Data.ByteString.Char8 as BSC8 -import qualified Data.Text.Encoding as Text -import qualified SDL.Exception as SDLEx -import qualified SDL.Raw as Raw - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - --- | A single SDL event. This event occured at 'eventTimestamp' and carries data under 'eventPayload'. -data Event = Event - { eventTimestamp :: Word32 - -- ^ The time the event occured. - , eventPayload :: EventPayload - -- ^ Data pertaining to this event. - } deriving (Eq, Ord, Generic, Show, Typeable) - --- | An enumeration of all possible SDL event types. This data type pairs up event types with --- their payload, where possible. -data EventPayload - = WindowShownEvent WindowShownEventData - | WindowHiddenEvent WindowHiddenEventData - | WindowExposedEvent WindowExposedEventData - | WindowMovedEvent WindowMovedEventData - | WindowResizedEvent WindowResizedEventData - | WindowSizeChangedEvent WindowSizeChangedEventData - | WindowMinimizedEvent WindowMinimizedEventData - | WindowMaximizedEvent WindowMaximizedEventData - | WindowRestoredEvent WindowRestoredEventData - | WindowGainedMouseFocusEvent WindowGainedMouseFocusEventData - | WindowLostMouseFocusEvent WindowLostMouseFocusEventData - | WindowGainedKeyboardFocusEvent WindowGainedKeyboardFocusEventData - | WindowLostKeyboardFocusEvent WindowLostKeyboardFocusEventData - | WindowClosedEvent WindowClosedEventData - | KeyboardEvent KeyboardEventData - | TextEditingEvent TextEditingEventData - | TextInputEvent TextInputEventData - | MouseMotionEvent MouseMotionEventData - | MouseButtonEvent MouseButtonEventData - | MouseWheelEvent MouseWheelEventData - | JoyAxisEvent JoyAxisEventData - | JoyBallEvent JoyBallEventData - | JoyHatEvent JoyHatEventData - | JoyButtonEvent JoyButtonEventData - | JoyDeviceEvent JoyDeviceEventData - | ControllerAxisEvent ControllerAxisEventData - | ControllerButtonEvent ControllerButtonEventData - | ControllerDeviceEvent ControllerDeviceEventData - | QuitEvent - | UserEvent UserEventData - | SysWMEvent SysWMEventData - | TouchFingerEvent TouchFingerEventData - | MultiGestureEvent MultiGestureEventData - | DollarGestureEvent DollarGestureEventData - | DropEvent DropEventData - | ClipboardUpdateEvent ClipboardUpdateEventData - | UnknownEvent UnknownEventData - deriving (Eq, Ord, Generic, Show, Typeable) - --- | A window has been shown. -data WindowShownEventData = - WindowShownEventData {windowShownEventWindow :: Window - -- ^ The associated 'Window'. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | A window has been hidden. -data WindowHiddenEventData = - WindowHiddenEventData {windowHiddenEventWindow :: Window - -- ^ The associated 'Window'. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | A part of a window has been exposed - where exposure means to become visible (for example, an overlapping window no longer overlaps with the window). -data WindowExposedEventData = - WindowExposedEventData {windowExposedEventWindow :: Window - -- ^ The associated 'Window'. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | A 'Window' has been moved. -data WindowMovedEventData = - WindowMovedEventData {windowMovedEventWindow :: Window - -- ^ The associated 'Window'. - ,windowMovedEventPosition :: Point V2 Int32 - -- ^ The new position of the 'Window'. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | Window has been resized. This is event is always preceded by 'WindowSizeChangedEvent'. -data WindowResizedEventData = - WindowResizedEventData {windowResizedEventWindow :: Window - -- ^ The associated 'Window'. - ,windowResizedEventSize :: V2 Int32 - -- ^ The new size of the 'Window'. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | The window size has changed, either as a result of an API call or through the system or user changing the window size; this event is followed by 'WindowResizedEvent' if the size was changed by an external event, i.e. the user or the window manager. -data WindowSizeChangedEventData = - WindowSizeChangedEventData {windowSizeChangedEventWindow :: Window - -- ^ The associated 'Window'. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | The window has been minimized. -data WindowMinimizedEventData = - WindowMinimizedEventData {windowMinimizedEventWindow :: Window - -- ^ The associated 'Window'. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | The window has been maximized. -data WindowMaximizedEventData = - WindowMaximizedEventData {windowMaximizedEventWindow :: Window - -- ^ The associated 'Window'. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | The window has been restored to normal size and position. -data WindowRestoredEventData = - WindowRestoredEventData {windowRestoredEventWindow :: Window - -- ^ The associated 'Window'. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | The window has gained mouse focus. -data WindowGainedMouseFocusEventData = - WindowGainedMouseFocusEventData {windowGainedMouseFocusEventWindow :: Window - -- ^ The associated 'Window'. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | The window has lost mouse focus. -data WindowLostMouseFocusEventData = - WindowLostMouseFocusEventData {windowLostMouseFocusEventWindow :: Window - -- ^ The associated 'Window'. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | The window has gained keyboard focus. -data WindowGainedKeyboardFocusEventData = - WindowGainedKeyboardFocusEventData {windowGainedKeyboardFocusEventWindow :: Window - -- ^ The associated 'Window'. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | The window has lost keyboard focus. -data WindowLostKeyboardFocusEventData = - WindowLostKeyboardFocusEventData {windowLostKeyboardFocusEventWindow :: Window - -- ^ The associated 'Window'. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | The window manager requests that the window be closed. -data WindowClosedEventData = - WindowClosedEventData {windowClosedEventWindow :: Window - -- ^ The associated 'Window'. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | A keyboard key has been pressed or released. -data KeyboardEventData = - KeyboardEventData {keyboardEventWindow :: Window - -- ^ The associated 'Window'. - ,keyboardEventKeyMotion :: InputMotion - -- ^ Whether the key was pressed or released. - ,keyboardEventRepeat :: Bool - -- ^ 'True' if this is a repeating key press from the user holding the key down. - ,keyboardEventKeysym :: Keysym - -- ^ A description of the key that this event pertains to. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | Keyboard text editing event information. -data TextEditingEventData = - TextEditingEventData {textEditingEventWindow :: Window - -- ^ The associated 'Window'. - ,textEditingEventText :: Text - -- ^ The editing text. - ,textEditingEventStart :: Int32 - -- ^ The location to begin editing from. - ,textEditingEventLength :: Int32 - -- ^ The number of characters to edit from the start point. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | Keyboard text input event information. -data TextInputEventData = - TextInputEventData {textInputEventWindow :: Window - -- ^ The associated 'Window'. - ,textInputEventText :: Text - -- ^ The input text. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | A mouse or pointer device was moved. -data MouseMotionEventData = - MouseMotionEventData {mouseMotionEventWindow :: Window - -- ^ The associated 'Window'. - ,mouseMotionEventWhich :: MouseDevice - -- ^ The 'MouseDevice' that was moved. - ,mouseMotionEventState :: [MouseButton] - -- ^ A collection of 'MouseButton's that are currently held down. - ,mouseMotionEventPos :: Point V2 Int32 - -- ^ The new position of the mouse. - ,mouseMotionEventRelMotion :: V2 Int32 - -- ^ The relative mouse motion of the mouse. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | A mouse or pointer device button was pressed or released. -data MouseButtonEventData = - MouseButtonEventData {mouseButtonEventWindow :: Window - -- ^ The associated 'Window'. - ,mouseButtonEventMotion :: InputMotion - -- ^ Whether the button was pressed or released. - ,mouseButtonEventWhich :: MouseDevice - -- ^ The 'MouseDevice' whose button was pressed or released. - ,mouseButtonEventButton :: MouseButton - -- ^ The button that was pressed or released. - ,mouseButtonEventClicks :: Word8 - -- ^ The amount of clicks. 1 for a single-click, 2 for a double-click, etc. - ,mouseButtonEventPos :: Point V2 Int32 - -- ^ The coordinates of the mouse click. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | Mouse wheel event information. -data MouseWheelEventData = - MouseWheelEventData {mouseWheelEventWindow :: Window - -- ^ The associated 'Window'. - ,mouseWheelEventWhich :: MouseDevice - -- ^ The 'MouseDevice' whose wheel was scrolled. - ,mouseWheelEventPos :: V2 Int32 - -- ^ The amount scrolled. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | Joystick axis motion event information -data JoyAxisEventData = - JoyAxisEventData {joyAxisEventWhich :: Raw.JoystickID - -- ^ The instance id of the joystick that reported the event. - ,joyAxisEventAxis :: Word8 - -- ^ The index of the axis that changed. - ,joyAxisEventValue :: Int16 - -- ^ The current position of the axis, ranging between -32768 and 32767. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | Joystick trackball motion event information. -data JoyBallEventData = - JoyBallEventData {joyBallEventWhich :: Raw.JoystickID - -- ^ The instance id of the joystick that reported the event. - ,joyBallEventBall :: Word8 - -- ^ The index of the trackball that changed. - ,joyBallEventRelMotion :: V2 Int16 - -- ^ The relative motion of the trackball. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | Joystick hat position change event information -data JoyHatEventData = - JoyHatEventData {joyHatEventWhich :: Raw.JoystickID - -- ^ The instance id of the joystick that reported the event. - ,joyHatEventHat :: Word8 - -- ^ The index of the hat that changed. - ,joyHatEventValue :: Word8 - -- ^ The new position of the hat. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | Joystick button event information. -data JoyButtonEventData = - JoyButtonEventData {joyButtonEventWhich :: Raw.JoystickID - -- ^ The instance id of the joystick that reported the event. - ,joyButtonEventButton :: Word8 - -- ^ The index of the button that changed. - ,joyButtonEventState :: Word8 - -- ^ The state of the button. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | Joystick device event information. -data JoyDeviceEventData = - JoyDeviceEventData {joyDeviceEventWhich :: Int32 - -- ^ The instance id of the joystick that reported the event. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | Game controller axis motion event information. -data ControllerAxisEventData = - ControllerAxisEventData {controllerAxisEventWhich :: Raw.JoystickID - -- ^ The joystick instance ID that reported the event. - ,controllerAxisEventAxis :: Word8 - -- ^ The index of the axis. - ,controllerAxisEventValue :: Int16 - -- ^ The axis value ranging between -32768 and 32767. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | Game controller button event information -data ControllerButtonEventData = - ControllerButtonEventData {controllerButtonEventWhich :: Raw.JoystickID - -- ^ The joystick instance ID that reported the event. - ,controllerButtonEventButton :: Word8 - -- ^ The controller button. - ,controllerButtonEventState :: Word8 - -- ^ The state of the button. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | Controller device event information -data ControllerDeviceEventData = - ControllerDeviceEventData {controllerDeviceEventWhich :: Int32 - -- ^ The joystick instance ID that reported the event. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | Event data for application-defined events. -data UserEventData = - UserEventData {userEventWindow :: Window - -- ^ The associated 'Window'. - ,userEventCode :: Int32 - -- ^ User defined event code. - ,userEventData1 :: Ptr () - -- ^ User defined data pointer. - ,userEventData2 :: Ptr () - -- ^ User defined data pointer. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | A video driver dependent system event -data SysWMEventData = - SysWMEventData {sysWMEventMsg :: Raw.SysWMmsg} - deriving (Eq,Ord,Generic,Show,Typeable) - --- | Finger touch event information. -data TouchFingerEventData = - TouchFingerEventData {touchFingerEventTouchID :: Raw.TouchID - -- ^ The touch device index. - ,touchFingerEventFingerID :: Raw.FingerID - -- ^ The finger index. - ,touchFingerEventPos :: Point V2 CFloat - -- ^ The location of the touch event, normalized between 0 and 1. - ,touchFingerEventRelMotion :: V2 CFloat - -- ^ The distance moved, normalized between -1 and 1. - ,touchFingerEventPressure :: CFloat - -- ^ The quantity of the pressure applied, normalized between 0 and 1. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | Multiple finger gesture event information -data MultiGestureEventData = - MultiGestureEventData {multiGestureEventTouchID :: Raw.TouchID - -- ^ The touch device index. - ,multiGestureEventDTheta :: CFloat - -- ^ The amount that the fingers rotated during this motion. - ,multiGestureEventDDist :: CFloat - -- ^ The amount that the fingers pinched during this motion. - ,multiGestureEventPos :: Point V2 CFloat - -- ^ The normalized center of the gesture. - ,multiGestureEventNumFingers :: Word16 - -- ^ The number of fingers used in this gesture. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | Complex gesture event information. -data DollarGestureEventData = - DollarGestureEventData {dollarGestureEventTouchID :: Raw.TouchID - -- ^ The touch device index. - ,dollarGestureEventGestureID :: Raw.GestureID - -- ^ The unique id of the closest gesture to the performed stroke. - ,dollarGestureEventNumFingers :: Word32 - -- ^ The number of fingers used to draw the stroke. - ,dollarGestureEventError :: CFloat - -- ^ The difference between the gesture template and the actual performed gesture (lower errors correspond to closer matches). - ,dollarGestureEventPos :: Point V2 CFloat - -- ^ The normalized center of the gesture. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | An event used to request a file open by the system -data DropEventData = - DropEventData {dropEventFile :: CString - -- ^ The file name. - } - deriving (Eq,Ord,Generic,Show,Typeable) - --- | The clipboard changed. -data ClipboardUpdateEventData = - ClipboardUpdateEventData - deriving (Eq,Ord,Generic,Show,Typeable) - --- | SDL reported an unknown event type. -data UnknownEventData = - UnknownEventData {unknownEventType :: Word32 - -- ^ The unknown event code. - } - deriving (Eq,Ord,Generic,Show,Typeable) - -data InputMotion = Released | Pressed - deriving (Bounded, Enum, Eq, Ord, Read, Data, Generic, Show, Typeable) - -ccharStringToText :: [CChar] -> Text -ccharStringToText = Text.decodeUtf8 . BSC8.pack . map castCCharToChar - -fromRawKeysym :: Raw.Keysym -> Keysym -fromRawKeysym (Raw.Keysym scancode keycode modifier) = - Keysym scancode' keycode' modifier' - where scancode' = fromNumber scancode - keycode' = fromNumber keycode - modifier' = fromNumber (fromIntegral modifier) - -convertRaw :: Raw.Event -> IO Event -convertRaw (Raw.WindowEvent t ts a b c d) = - do w' <- fmap Window (Raw.getWindowFromID a) - return (Event ts - (case b of - Raw.SDL_WINDOWEVENT_SHOWN -> - WindowShownEvent (WindowShownEventData w') - Raw.SDL_WINDOWEVENT_HIDDEN -> - WindowHiddenEvent (WindowHiddenEventData w') - Raw.SDL_WINDOWEVENT_EXPOSED -> - WindowExposedEvent (WindowExposedEventData w') - Raw.SDL_WINDOWEVENT_MOVED -> - WindowMovedEvent - (WindowMovedEventData w' - (P (V2 c d))) - Raw.SDL_WINDOWEVENT_RESIZED -> - WindowResizedEvent - (WindowResizedEventData w' - (V2 c d)) - Raw.SDL_WINDOWEVENT_SIZE_CHANGED -> - WindowSizeChangedEvent (WindowSizeChangedEventData w') - Raw.SDL_WINDOWEVENT_MINIMIZED -> - WindowMinimizedEvent (WindowMinimizedEventData w') - Raw.SDL_WINDOWEVENT_MAXIMIZED -> - WindowMaximizedEvent (WindowMaximizedEventData w') - Raw.SDL_WINDOWEVENT_RESTORED -> - WindowRestoredEvent (WindowRestoredEventData w') - Raw.SDL_WINDOWEVENT_ENTER -> - WindowGainedMouseFocusEvent (WindowGainedMouseFocusEventData w') - Raw.SDL_WINDOWEVENT_LEAVE -> - WindowLostMouseFocusEvent (WindowLostMouseFocusEventData w') - Raw.SDL_WINDOWEVENT_FOCUS_GAINED -> - WindowGainedKeyboardFocusEvent (WindowGainedKeyboardFocusEventData w') - Raw.SDL_WINDOWEVENT_FOCUS_LOST -> - WindowLostKeyboardFocusEvent (WindowLostKeyboardFocusEventData w') - Raw.SDL_WINDOWEVENT_CLOSE -> - WindowClosedEvent (WindowClosedEventData w') - _ -> - UnknownEvent (UnknownEventData t))) -convertRaw (Raw.KeyboardEvent Raw.SDL_KEYDOWN ts a _ c d) = - do w' <- fmap Window (Raw.getWindowFromID a) - return (Event ts - (KeyboardEvent - (KeyboardEventData w' - Pressed - (c /= 0) - (fromRawKeysym d)))) -convertRaw (Raw.KeyboardEvent Raw.SDL_KEYUP ts a _ c d) = - do w' <- fmap Window (Raw.getWindowFromID a) - return (Event ts - (KeyboardEvent - (KeyboardEventData w' - Released - (c /= 0) - (fromRawKeysym d)))) -convertRaw (Raw.KeyboardEvent _ _ _ _ _ _) = error "convertRaw: Unknown keyboard motion" -convertRaw (Raw.TextEditingEvent _ ts a b c d) = - do w' <- fmap Window (Raw.getWindowFromID a) - return (Event ts - (TextEditingEvent - (TextEditingEventData w' - (ccharStringToText b) - c - d))) -convertRaw (Raw.TextInputEvent _ ts a b) = - do w' <- fmap Window (Raw.getWindowFromID a) - return (Event ts - (TextInputEvent - (TextInputEventData w' - (ccharStringToText b)))) -convertRaw (Raw.MouseMotionEvent _ ts a b c d e f g) = - do w' <- fmap Window (Raw.getWindowFromID a) - let buttons = - catMaybes [(Raw.SDL_BUTTON_LMASK `test` c) ButtonLeft - ,(Raw.SDL_BUTTON_RMASK `test` c) ButtonRight - ,(Raw.SDL_BUTTON_MMASK `test` c) ButtonMiddle - ,(Raw.SDL_BUTTON_X1MASK `test` c) ButtonX1 - ,(Raw.SDL_BUTTON_X2MASK `test` c) ButtonX2] - return (Event ts - (MouseMotionEvent - (MouseMotionEventData w' - (fromNumber b) - buttons - (P (V2 d e)) - (V2 f g)))) - where mask `test` x = - if mask .&. x /= 0 - then Just - else const Nothing -convertRaw (Raw.MouseButtonEvent t ts a b c _ e f g) = - do w' <- fmap Window (Raw.getWindowFromID a) - let motion - | t == Raw.SDL_MOUSEBUTTONUP = Released - | t == Raw.SDL_MOUSEBUTTONDOWN = Pressed - | otherwise = error "convertRaw: Unexpected mouse button motion" - button - | c == Raw.SDL_BUTTON_LEFT = ButtonLeft - | c == Raw.SDL_BUTTON_MIDDLE = ButtonMiddle - | c == Raw.SDL_BUTTON_RIGHT = ButtonRight - | c == Raw.SDL_BUTTON_X1 = ButtonX1 - | c == Raw.SDL_BUTTON_X2 = ButtonX2 - | otherwise = ButtonExtra $ fromIntegral c - return (Event ts - (MouseButtonEvent - (MouseButtonEventData w' - motion - (fromNumber b) - button - e - (P (V2 f g))))) -convertRaw (Raw.MouseWheelEvent _ ts a b c d) = - do w' <- fmap Window (Raw.getWindowFromID a) - return (Event ts - (MouseWheelEvent - (MouseWheelEventData w' - (fromNumber b) - (V2 c d)))) -convertRaw (Raw.JoyAxisEvent _ ts a b c) = - return (Event ts (JoyAxisEvent (JoyAxisEventData a b c))) -convertRaw (Raw.JoyBallEvent _ ts a b c d) = - return (Event ts - (JoyBallEvent - (JoyBallEventData a - b - (V2 c d)))) -convertRaw (Raw.JoyHatEvent _ ts a b c) = - return (Event ts (JoyHatEvent (JoyHatEventData a b c))) -convertRaw (Raw.JoyButtonEvent _ ts a b c) = - return (Event ts (JoyButtonEvent (JoyButtonEventData a b c))) -convertRaw (Raw.JoyDeviceEvent _ ts a) = - return (Event ts (JoyDeviceEvent (JoyDeviceEventData a))) -convertRaw (Raw.ControllerAxisEvent _ ts a b c) = - return (Event ts (ControllerAxisEvent (ControllerAxisEventData a b c))) -convertRaw (Raw.ControllerButtonEvent _ ts a b c) = - return (Event ts (ControllerButtonEvent (ControllerButtonEventData a b c))) -convertRaw (Raw.ControllerDeviceEvent _ ts a) = - return (Event ts (ControllerDeviceEvent (ControllerDeviceEventData a))) -convertRaw (Raw.QuitEvent _ ts) = - return (Event ts QuitEvent) -convertRaw (Raw.UserEvent _ ts a b c d) = - do w' <- fmap Window (Raw.getWindowFromID a) - return (Event ts (UserEvent (UserEventData w' b c d))) -convertRaw (Raw.SysWMEvent _ ts a) = - return (Event ts (SysWMEvent (SysWMEventData a))) -convertRaw (Raw.TouchFingerEvent _ ts a b c d e f g) = - return (Event ts - (TouchFingerEvent - (TouchFingerEventData a - b - (P (V2 c d)) - (V2 e f) - g))) -convertRaw (Raw.MultiGestureEvent _ ts a b c d e f) = - return (Event ts - (MultiGestureEvent - (MultiGestureEventData a - b - c - (P (V2 d e)) - f))) -convertRaw (Raw.DollarGestureEvent _ ts a b c d e f) = - return (Event ts - (DollarGestureEvent - (DollarGestureEventData a - b - c - d - (P (V2 e f))))) -convertRaw (Raw.DropEvent _ ts a) = - return (Event ts (DropEvent (DropEventData a))) -convertRaw (Raw.ClipboardUpdateEvent _ ts) = - return (Event ts (ClipboardUpdateEvent ClipboardUpdateEventData)) -convertRaw (Raw.UnknownEvent t ts) = - return (Event ts (UnknownEvent (UnknownEventData t))) - --- | Poll for currently pending events. You can only call this function in the thread that set the video mode. -pollEvent :: MonadIO m => m (Maybe Event) -pollEvent = liftIO $ alloca $ \e -> do - n <- Raw.pollEvent e - if n == 0 - then return Nothing - else fmap Just (peek e >>= convertRaw) - --- | Clear the event queue by polling for all pending events. -pollEvents :: (Functor m, MonadIO m) => m [Event] -pollEvents = - do e <- pollEvent - case e of - Nothing -> return [] - Just e' -> (e' :) <$> pollEvents - --- | Run a monadic computation, accumulating over all known 'Event's. --- --- This can be useful when used with a state monad, allowing you to fold all events together. -mapEvents :: MonadIO m => (Event -> m ()) -> m () -mapEvents h = do - event' <- pollEvent - case event' of - Just event -> h event >> mapEvents h - Nothing -> return () - --- | Wait indefinitely for the next available event. -waitEvent :: MonadIO m => m Event -waitEvent = liftIO $ alloca $ \e -> do - SDLEx.throwIfNeg_ "SDL.Events.waitEvent" "SDL_WaitEvent" $ - Raw.waitEvent e - peek e >>= convertRaw - --- | Wait until the specified timeout for the next available amount. -waitEventTimeout :: MonadIO m - => CInt -- ^ The maximum amount of time to wait, in milliseconds. - -> m (Maybe Event) -waitEventTimeout timeout = liftIO $ alloca $ \e -> do - n <- Raw.waitEventTimeout e timeout - if n == 0 - then return Nothing - else fmap Just (peek e >>= convertRaw) - --- | Pump the event loop, gathering events from the input devices. --- --- This function updates the event queue and internal input device state. --- --- This should only be run in the thread that initialized the video subsystem, and for extra safety, you should consider only doing those things on the main thread in any case. --- --- 'pumpEvents' gathers all the pending input information from devices and places it in the event queue. Without calls to 'pumpEvents' no events would ever be placed on the queue. Often the need for calls to 'pumpEvents' is hidden from the user since 'pollEvent' and 'waitEvent' implicitly call 'pumpEvents'. However, if you are not polling or waiting for events (e.g. you are filtering them), then you must call 'pumpEvents' to force an event queue update. --- --- See @@ for C documentation. -pumpEvents :: MonadIO m => m () -pumpEvents = Raw.pumpEvents +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | "SDL.Event" exports an interface for working with the SDL event model. Event handling allows your application to receive input from the user. Internally, SDL stores all the events waiting to be handled in an event queue. Using functions like 'pollEvent' and 'waitEvent' you can observe and handle waiting input events. +-- +-- The event queue itself is composed of a series of 'Event' values, one for each waiting event. 'Event' values are read from the queue with the 'pollEvent' function and it is then up to the application to process the information stored with them. +module SDL.Event + ( -- * Polling events + pollEvent + , pollEvents + , mapEvents + , pumpEvents + , waitEvent + , waitEventTimeout + -- * Event data + , Event(..) + , EventPayload(..) + -- ** Window events + , WindowShownEventData(..) + , WindowHiddenEventData(..) + , WindowExposedEventData(..) + , WindowMovedEventData(..) + , WindowResizedEventData(..) + , WindowSizeChangedEventData(..) + , WindowMinimizedEventData(..) + , WindowMaximizedEventData(..) + , WindowRestoredEventData(..) + , WindowGainedMouseFocusEventData(..) + , WindowLostMouseFocusEventData(..) + , WindowGainedKeyboardFocusEventData(..) + , WindowLostKeyboardFocusEventData(..) + , WindowClosedEventData(..) + , SysWMEventData(..) + -- ** Keyboard events + , KeyboardEventData(..) + , TextEditingEventData(..) + , TextInputEventData(..) + -- ** Mouse events + , MouseMotionEventData(..) + , MouseButtonEventData(..) + , MouseWheelEventData(..) + -- ** Joystick events + , JoyAxisEventData(..) + , JoyBallEventData(..) + , JoyHatEventData(..) + , JoyButtonEventData(..) + , JoyDeviceEventData(..) + -- ** Controller events + , ControllerAxisEventData(..) + , ControllerButtonEventData(..) + , ControllerDeviceEventData(..) + -- ** User events + , UserEventData(..) + -- ** Touch events + , TouchFingerEventData(..) + -- ** Gesture events + , MultiGestureEventData(..) + , DollarGestureEventData(..) + -- ** Drag and drop events + , DropEventData(..) + -- ** Clipboard events + , ClipboardUpdateEventData(..) + -- ** Unknown events + , UnknownEventData(..) + -- * Auxiliary event data + , InputMotion(..) + , MouseButton(..) + ) where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Data (Data) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Typeable +import Foreign +import Foreign.C +import GHC.Generics (Generic) +import SDL.Vect +import SDL.Input.Keyboard +import SDL.Input.Mouse +import SDL.Internal.Numbered +import SDL.Internal.Types (Window(Window)) +import qualified Data.ByteString.Char8 as BSC8 +import qualified Data.Text.Encoding as Text +import qualified SDL.Exception as SDLEx +import qualified SDL.Raw as Raw + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +-- | A single SDL event. This event occured at 'eventTimestamp' and carries data under 'eventPayload'. +data Event = Event + { eventTimestamp :: Word32 + -- ^ The time the event occured. + , eventPayload :: EventPayload + -- ^ Data pertaining to this event. + } deriving (Eq, Ord, Generic, Show, Typeable) + +-- | An enumeration of all possible SDL event types. This data type pairs up event types with +-- their payload, where possible. +data EventPayload + = WindowShownEvent WindowShownEventData + | WindowHiddenEvent WindowHiddenEventData + | WindowExposedEvent WindowExposedEventData + | WindowMovedEvent WindowMovedEventData + | WindowResizedEvent WindowResizedEventData + | WindowSizeChangedEvent WindowSizeChangedEventData + | WindowMinimizedEvent WindowMinimizedEventData + | WindowMaximizedEvent WindowMaximizedEventData + | WindowRestoredEvent WindowRestoredEventData + | WindowGainedMouseFocusEvent WindowGainedMouseFocusEventData + | WindowLostMouseFocusEvent WindowLostMouseFocusEventData + | WindowGainedKeyboardFocusEvent WindowGainedKeyboardFocusEventData + | WindowLostKeyboardFocusEvent WindowLostKeyboardFocusEventData + | WindowClosedEvent WindowClosedEventData + | KeyboardEvent KeyboardEventData + | TextEditingEvent TextEditingEventData + | TextInputEvent TextInputEventData + | MouseMotionEvent MouseMotionEventData + | MouseButtonEvent MouseButtonEventData + | MouseWheelEvent MouseWheelEventData + | JoyAxisEvent JoyAxisEventData + | JoyBallEvent JoyBallEventData + | JoyHatEvent JoyHatEventData + | JoyButtonEvent JoyButtonEventData + | JoyDeviceEvent JoyDeviceEventData + | ControllerAxisEvent ControllerAxisEventData + | ControllerButtonEvent ControllerButtonEventData + | ControllerDeviceEvent ControllerDeviceEventData + | QuitEvent + | UserEvent UserEventData + | SysWMEvent SysWMEventData + | TouchFingerEvent TouchFingerEventData + | MultiGestureEvent MultiGestureEventData + | DollarGestureEvent DollarGestureEventData + | DropEvent DropEventData + | ClipboardUpdateEvent ClipboardUpdateEventData + | UnknownEvent UnknownEventData + deriving (Eq, Ord, Generic, Show, Typeable) + +-- | A window has been shown. +data WindowShownEventData = + WindowShownEventData {windowShownEventWindow :: Window + -- ^ The associated 'Window'. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | A window has been hidden. +data WindowHiddenEventData = + WindowHiddenEventData {windowHiddenEventWindow :: Window + -- ^ The associated 'Window'. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | A part of a window has been exposed - where exposure means to become visible (for example, an overlapping window no longer overlaps with the window). +data WindowExposedEventData = + WindowExposedEventData {windowExposedEventWindow :: Window + -- ^ The associated 'Window'. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | A 'Window' has been moved. +data WindowMovedEventData = + WindowMovedEventData {windowMovedEventWindow :: Window + -- ^ The associated 'Window'. + ,windowMovedEventPosition :: Point V2 Int32 + -- ^ The new position of the 'Window'. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | Window has been resized. This is event is always preceded by 'WindowSizeChangedEvent'. +data WindowResizedEventData = + WindowResizedEventData {windowResizedEventWindow :: Window + -- ^ The associated 'Window'. + ,windowResizedEventSize :: V2 Int32 + -- ^ The new size of the 'Window'. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | The window size has changed, either as a result of an API call or through the system or user changing the window size; this event is followed by 'WindowResizedEvent' if the size was changed by an external event, i.e. the user or the window manager. +data WindowSizeChangedEventData = + WindowSizeChangedEventData {windowSizeChangedEventWindow :: Window + -- ^ The associated 'Window'. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | The window has been minimized. +data WindowMinimizedEventData = + WindowMinimizedEventData {windowMinimizedEventWindow :: Window + -- ^ The associated 'Window'. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | The window has been maximized. +data WindowMaximizedEventData = + WindowMaximizedEventData {windowMaximizedEventWindow :: Window + -- ^ The associated 'Window'. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | The window has been restored to normal size and position. +data WindowRestoredEventData = + WindowRestoredEventData {windowRestoredEventWindow :: Window + -- ^ The associated 'Window'. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | The window has gained mouse focus. +data WindowGainedMouseFocusEventData = + WindowGainedMouseFocusEventData {windowGainedMouseFocusEventWindow :: Window + -- ^ The associated 'Window'. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | The window has lost mouse focus. +data WindowLostMouseFocusEventData = + WindowLostMouseFocusEventData {windowLostMouseFocusEventWindow :: Window + -- ^ The associated 'Window'. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | The window has gained keyboard focus. +data WindowGainedKeyboardFocusEventData = + WindowGainedKeyboardFocusEventData {windowGainedKeyboardFocusEventWindow :: Window + -- ^ The associated 'Window'. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | The window has lost keyboard focus. +data WindowLostKeyboardFocusEventData = + WindowLostKeyboardFocusEventData {windowLostKeyboardFocusEventWindow :: Window + -- ^ The associated 'Window'. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | The window manager requests that the window be closed. +data WindowClosedEventData = + WindowClosedEventData {windowClosedEventWindow :: Window + -- ^ The associated 'Window'. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | A keyboard key has been pressed or released. +data KeyboardEventData = + KeyboardEventData {keyboardEventWindow :: Window + -- ^ The associated 'Window'. + ,keyboardEventKeyMotion :: InputMotion + -- ^ Whether the key was pressed or released. + ,keyboardEventRepeat :: Bool + -- ^ 'True' if this is a repeating key press from the user holding the key down. + ,keyboardEventKeysym :: Keysym + -- ^ A description of the key that this event pertains to. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | Keyboard text editing event information. +data TextEditingEventData = + TextEditingEventData {textEditingEventWindow :: Window + -- ^ The associated 'Window'. + ,textEditingEventText :: Text + -- ^ The editing text. + ,textEditingEventStart :: Int32 + -- ^ The location to begin editing from. + ,textEditingEventLength :: Int32 + -- ^ The number of characters to edit from the start point. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | Keyboard text input event information. +data TextInputEventData = + TextInputEventData {textInputEventWindow :: Window + -- ^ The associated 'Window'. + ,textInputEventText :: Text + -- ^ The input text. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | A mouse or pointer device was moved. +data MouseMotionEventData = + MouseMotionEventData {mouseMotionEventWindow :: Window + -- ^ The associated 'Window'. + ,mouseMotionEventWhich :: MouseDevice + -- ^ The 'MouseDevice' that was moved. + ,mouseMotionEventState :: [MouseButton] + -- ^ A collection of 'MouseButton's that are currently held down. + ,mouseMotionEventPos :: Point V2 Int32 + -- ^ The new position of the mouse. + ,mouseMotionEventRelMotion :: V2 Int32 + -- ^ The relative mouse motion of the mouse. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | A mouse or pointer device button was pressed or released. +data MouseButtonEventData = + MouseButtonEventData {mouseButtonEventWindow :: Window + -- ^ The associated 'Window'. + ,mouseButtonEventMotion :: InputMotion + -- ^ Whether the button was pressed or released. + ,mouseButtonEventWhich :: MouseDevice + -- ^ The 'MouseDevice' whose button was pressed or released. + ,mouseButtonEventButton :: MouseButton + -- ^ The button that was pressed or released. + ,mouseButtonEventClicks :: Word8 + -- ^ The amount of clicks. 1 for a single-click, 2 for a double-click, etc. + ,mouseButtonEventPos :: Point V2 Int32 + -- ^ The coordinates of the mouse click. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | Mouse wheel event information. +data MouseWheelEventData = + MouseWheelEventData {mouseWheelEventWindow :: Window + -- ^ The associated 'Window'. + ,mouseWheelEventWhich :: MouseDevice + -- ^ The 'MouseDevice' whose wheel was scrolled. + ,mouseWheelEventPos :: V2 Int32 + -- ^ The amount scrolled. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | Joystick axis motion event information +data JoyAxisEventData = + JoyAxisEventData {joyAxisEventWhich :: Raw.JoystickID + -- ^ The instance id of the joystick that reported the event. + ,joyAxisEventAxis :: Word8 + -- ^ The index of the axis that changed. + ,joyAxisEventValue :: Int16 + -- ^ The current position of the axis, ranging between -32768 and 32767. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | Joystick trackball motion event information. +data JoyBallEventData = + JoyBallEventData {joyBallEventWhich :: Raw.JoystickID + -- ^ The instance id of the joystick that reported the event. + ,joyBallEventBall :: Word8 + -- ^ The index of the trackball that changed. + ,joyBallEventRelMotion :: V2 Int16 + -- ^ The relative motion of the trackball. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | Joystick hat position change event information +data JoyHatEventData = + JoyHatEventData {joyHatEventWhich :: Raw.JoystickID + -- ^ The instance id of the joystick that reported the event. + ,joyHatEventHat :: Word8 + -- ^ The index of the hat that changed. + ,joyHatEventValue :: Word8 + -- ^ The new position of the hat. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | Joystick button event information. +data JoyButtonEventData = + JoyButtonEventData {joyButtonEventWhich :: Raw.JoystickID + -- ^ The instance id of the joystick that reported the event. + ,joyButtonEventButton :: Word8 + -- ^ The index of the button that changed. + ,joyButtonEventState :: Word8 + -- ^ The state of the button. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | Joystick device event information. +data JoyDeviceEventData = + JoyDeviceEventData {joyDeviceEventWhich :: Int32 + -- ^ The instance id of the joystick that reported the event. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | Game controller axis motion event information. +data ControllerAxisEventData = + ControllerAxisEventData {controllerAxisEventWhich :: Raw.JoystickID + -- ^ The joystick instance ID that reported the event. + ,controllerAxisEventAxis :: Word8 + -- ^ The index of the axis. + ,controllerAxisEventValue :: Int16 + -- ^ The axis value ranging between -32768 and 32767. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | Game controller button event information +data ControllerButtonEventData = + ControllerButtonEventData {controllerButtonEventWhich :: Raw.JoystickID + -- ^ The joystick instance ID that reported the event. + ,controllerButtonEventButton :: Word8 + -- ^ The controller button. + ,controllerButtonEventState :: Word8 + -- ^ The state of the button. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | Controller device event information +data ControllerDeviceEventData = + ControllerDeviceEventData {controllerDeviceEventWhich :: Int32 + -- ^ The joystick instance ID that reported the event. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | Event data for application-defined events. +data UserEventData = + UserEventData {userEventWindow :: Window + -- ^ The associated 'Window'. + ,userEventCode :: Int32 + -- ^ User defined event code. + ,userEventData1 :: Ptr () + -- ^ User defined data pointer. + ,userEventData2 :: Ptr () + -- ^ User defined data pointer. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | A video driver dependent system event +data SysWMEventData = + SysWMEventData {sysWMEventMsg :: Raw.SysWMmsg} + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | Finger touch event information. +data TouchFingerEventData = + TouchFingerEventData {touchFingerEventTouchID :: Raw.TouchID + -- ^ The touch device index. + ,touchFingerEventFingerID :: Raw.FingerID + -- ^ The finger index. + ,touchFingerEventPos :: Point V2 CFloat + -- ^ The location of the touch event, normalized between 0 and 1. + ,touchFingerEventRelMotion :: V2 CFloat + -- ^ The distance moved, normalized between -1 and 1. + ,touchFingerEventPressure :: CFloat + -- ^ The quantity of the pressure applied, normalized between 0 and 1. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | Multiple finger gesture event information +data MultiGestureEventData = + MultiGestureEventData {multiGestureEventTouchID :: Raw.TouchID + -- ^ The touch device index. + ,multiGestureEventDTheta :: CFloat + -- ^ The amount that the fingers rotated during this motion. + ,multiGestureEventDDist :: CFloat + -- ^ The amount that the fingers pinched during this motion. + ,multiGestureEventPos :: Point V2 CFloat + -- ^ The normalized center of the gesture. + ,multiGestureEventNumFingers :: Word16 + -- ^ The number of fingers used in this gesture. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | Complex gesture event information. +data DollarGestureEventData = + DollarGestureEventData {dollarGestureEventTouchID :: Raw.TouchID + -- ^ The touch device index. + ,dollarGestureEventGestureID :: Raw.GestureID + -- ^ The unique id of the closest gesture to the performed stroke. + ,dollarGestureEventNumFingers :: Word32 + -- ^ The number of fingers used to draw the stroke. + ,dollarGestureEventError :: CFloat + -- ^ The difference between the gesture template and the actual performed gesture (lower errors correspond to closer matches). + ,dollarGestureEventPos :: Point V2 CFloat + -- ^ The normalized center of the gesture. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | An event used to request a file open by the system +data DropEventData = + DropEventData {dropEventFile :: CString + -- ^ The file name. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | The clipboard changed. +data ClipboardUpdateEventData = + ClipboardUpdateEventData + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | SDL reported an unknown event type. +data UnknownEventData = + UnknownEventData {unknownEventType :: Word32 + -- ^ The unknown event code. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +data InputMotion = Released | Pressed + deriving (Bounded, Enum, Eq, Ord, Read, Data, Generic, Show, Typeable) + +ccharStringToText :: [CChar] -> Text +ccharStringToText = Text.decodeUtf8 . BSC8.pack . map castCCharToChar + +fromRawKeysym :: Raw.Keysym -> Keysym +fromRawKeysym (Raw.Keysym scancode keycode modifier) = + Keysym scancode' keycode' modifier' + where scancode' = fromNumber scancode + keycode' = fromNumber keycode + modifier' = fromNumber (fromIntegral modifier) + +convertRaw :: Raw.Event -> IO Event +convertRaw (Raw.WindowEvent t ts a b c d) = + do w' <- fmap Window (Raw.getWindowFromID a) + return (Event ts + (case b of + Raw.SDL_WINDOWEVENT_SHOWN -> + WindowShownEvent (WindowShownEventData w') + Raw.SDL_WINDOWEVENT_HIDDEN -> + WindowHiddenEvent (WindowHiddenEventData w') + Raw.SDL_WINDOWEVENT_EXPOSED -> + WindowExposedEvent (WindowExposedEventData w') + Raw.SDL_WINDOWEVENT_MOVED -> + WindowMovedEvent + (WindowMovedEventData w' + (P (V2 c d))) + Raw.SDL_WINDOWEVENT_RESIZED -> + WindowResizedEvent + (WindowResizedEventData w' + (V2 c d)) + Raw.SDL_WINDOWEVENT_SIZE_CHANGED -> + WindowSizeChangedEvent (WindowSizeChangedEventData w') + Raw.SDL_WINDOWEVENT_MINIMIZED -> + WindowMinimizedEvent (WindowMinimizedEventData w') + Raw.SDL_WINDOWEVENT_MAXIMIZED -> + WindowMaximizedEvent (WindowMaximizedEventData w') + Raw.SDL_WINDOWEVENT_RESTORED -> + WindowRestoredEvent (WindowRestoredEventData w') + Raw.SDL_WINDOWEVENT_ENTER -> + WindowGainedMouseFocusEvent (WindowGainedMouseFocusEventData w') + Raw.SDL_WINDOWEVENT_LEAVE -> + WindowLostMouseFocusEvent (WindowLostMouseFocusEventData w') + Raw.SDL_WINDOWEVENT_FOCUS_GAINED -> + WindowGainedKeyboardFocusEvent (WindowGainedKeyboardFocusEventData w') + Raw.SDL_WINDOWEVENT_FOCUS_LOST -> + WindowLostKeyboardFocusEvent (WindowLostKeyboardFocusEventData w') + Raw.SDL_WINDOWEVENT_CLOSE -> + WindowClosedEvent (WindowClosedEventData w') + _ -> + UnknownEvent (UnknownEventData t))) +convertRaw (Raw.KeyboardEvent Raw.SDL_KEYDOWN ts a _ c d) = + do w' <- fmap Window (Raw.getWindowFromID a) + return (Event ts + (KeyboardEvent + (KeyboardEventData w' + Pressed + (c /= 0) + (fromRawKeysym d)))) +convertRaw (Raw.KeyboardEvent Raw.SDL_KEYUP ts a _ c d) = + do w' <- fmap Window (Raw.getWindowFromID a) + return (Event ts + (KeyboardEvent + (KeyboardEventData w' + Released + (c /= 0) + (fromRawKeysym d)))) +convertRaw (Raw.KeyboardEvent _ _ _ _ _ _) = error "convertRaw: Unknown keyboard motion" +convertRaw (Raw.TextEditingEvent _ ts a b c d) = + do w' <- fmap Window (Raw.getWindowFromID a) + return (Event ts + (TextEditingEvent + (TextEditingEventData w' + (ccharStringToText b) + c + d))) +convertRaw (Raw.TextInputEvent _ ts a b) = + do w' <- fmap Window (Raw.getWindowFromID a) + return (Event ts + (TextInputEvent + (TextInputEventData w' + (ccharStringToText b)))) +convertRaw (Raw.MouseMotionEvent _ ts a b c d e f g) = + do w' <- fmap Window (Raw.getWindowFromID a) + let buttons = + catMaybes [(Raw.SDL_BUTTON_LMASK `test` c) ButtonLeft + ,(Raw.SDL_BUTTON_RMASK `test` c) ButtonRight + ,(Raw.SDL_BUTTON_MMASK `test` c) ButtonMiddle + ,(Raw.SDL_BUTTON_X1MASK `test` c) ButtonX1 + ,(Raw.SDL_BUTTON_X2MASK `test` c) ButtonX2] + return (Event ts + (MouseMotionEvent + (MouseMotionEventData w' + (fromNumber b) + buttons + (P (V2 d e)) + (V2 f g)))) + where mask `test` x = + if mask .&. x /= 0 + then Just + else const Nothing +convertRaw (Raw.MouseButtonEvent t ts a b c _ e f g) = + do w' <- fmap Window (Raw.getWindowFromID a) + let motion + | t == Raw.SDL_MOUSEBUTTONUP = Released + | t == Raw.SDL_MOUSEBUTTONDOWN = Pressed + | otherwise = error "convertRaw: Unexpected mouse button motion" + button + | c == Raw.SDL_BUTTON_LEFT = ButtonLeft + | c == Raw.SDL_BUTTON_MIDDLE = ButtonMiddle + | c == Raw.SDL_BUTTON_RIGHT = ButtonRight + | c == Raw.SDL_BUTTON_X1 = ButtonX1 + | c == Raw.SDL_BUTTON_X2 = ButtonX2 + | otherwise = ButtonExtra $ fromIntegral c + return (Event ts + (MouseButtonEvent + (MouseButtonEventData w' + motion + (fromNumber b) + button + e + (P (V2 f g))))) +convertRaw (Raw.MouseWheelEvent _ ts a b c d) = + do w' <- fmap Window (Raw.getWindowFromID a) + return (Event ts + (MouseWheelEvent + (MouseWheelEventData w' + (fromNumber b) + (V2 c d)))) +convertRaw (Raw.JoyAxisEvent _ ts a b c) = + return (Event ts (JoyAxisEvent (JoyAxisEventData a b c))) +convertRaw (Raw.JoyBallEvent _ ts a b c d) = + return (Event ts + (JoyBallEvent + (JoyBallEventData a + b + (V2 c d)))) +convertRaw (Raw.JoyHatEvent _ ts a b c) = + return (Event ts (JoyHatEvent (JoyHatEventData a b c))) +convertRaw (Raw.JoyButtonEvent _ ts a b c) = + return (Event ts (JoyButtonEvent (JoyButtonEventData a b c))) +convertRaw (Raw.JoyDeviceEvent _ ts a) = + return (Event ts (JoyDeviceEvent (JoyDeviceEventData a))) +convertRaw (Raw.ControllerAxisEvent _ ts a b c) = + return (Event ts (ControllerAxisEvent (ControllerAxisEventData a b c))) +convertRaw (Raw.ControllerButtonEvent _ ts a b c) = + return (Event ts (ControllerButtonEvent (ControllerButtonEventData a b c))) +convertRaw (Raw.ControllerDeviceEvent _ ts a) = + return (Event ts (ControllerDeviceEvent (ControllerDeviceEventData a))) +convertRaw (Raw.QuitEvent _ ts) = + return (Event ts QuitEvent) +convertRaw (Raw.UserEvent _ ts a b c d) = + do w' <- fmap Window (Raw.getWindowFromID a) + return (Event ts (UserEvent (UserEventData w' b c d))) +convertRaw (Raw.SysWMEvent _ ts a) = + return (Event ts (SysWMEvent (SysWMEventData a))) +convertRaw (Raw.TouchFingerEvent _ ts a b c d e f g) = + return (Event ts + (TouchFingerEvent + (TouchFingerEventData a + b + (P (V2 c d)) + (V2 e f) + g))) +convertRaw (Raw.MultiGestureEvent _ ts a b c d e f) = + return (Event ts + (MultiGestureEvent + (MultiGestureEventData a + b + c + (P (V2 d e)) + f))) +convertRaw (Raw.DollarGestureEvent _ ts a b c d e f) = + return (Event ts + (DollarGestureEvent + (DollarGestureEventData a + b + c + d + (P (V2 e f))))) +convertRaw (Raw.DropEvent _ ts a) = + return (Event ts (DropEvent (DropEventData a))) +convertRaw (Raw.ClipboardUpdateEvent _ ts) = + return (Event ts (ClipboardUpdateEvent ClipboardUpdateEventData)) +convertRaw (Raw.UnknownEvent t ts) = + return (Event ts (UnknownEvent (UnknownEventData t))) + +-- | Poll for currently pending events. You can only call this function in the thread that set the video mode. +pollEvent :: MonadIO m => m (Maybe Event) +pollEvent = liftIO $ alloca $ \e -> do + n <- Raw.pollEvent e + if n == 0 + then return Nothing + else fmap Just (peek e >>= convertRaw) + +-- | Clear the event queue by polling for all pending events. +pollEvents :: (Functor m, MonadIO m) => m [Event] +pollEvents = + do e <- pollEvent + case e of + Nothing -> return [] + Just e' -> (e' :) <$> pollEvents + +-- | Run a monadic computation, accumulating over all known 'Event's. +-- +-- This can be useful when used with a state monad, allowing you to fold all events together. +mapEvents :: MonadIO m => (Event -> m ()) -> m () +mapEvents h = do + event' <- pollEvent + case event' of + Just event -> h event >> mapEvents h + Nothing -> return () + +-- | Wait indefinitely for the next available event. +waitEvent :: MonadIO m => m Event +waitEvent = liftIO $ alloca $ \e -> do + SDLEx.throwIfNeg_ "SDL.Events.waitEvent" "SDL_WaitEvent" $ + Raw.waitEvent e + peek e >>= convertRaw + +-- | Wait until the specified timeout for the next available amount. +waitEventTimeout :: MonadIO m + => CInt -- ^ The maximum amount of time to wait, in milliseconds. + -> m (Maybe Event) +waitEventTimeout timeout = liftIO $ alloca $ \e -> do + n <- Raw.waitEventTimeout e timeout + if n == 0 + then return Nothing + else fmap Just (peek e >>= convertRaw) + +-- | Pump the event loop, gathering events from the input devices. +-- +-- This function updates the event queue and internal input device state. +-- +-- This should only be run in the thread that initialized the video subsystem, and for extra safety, you should consider only doing those things on the main thread in any case. +-- +-- 'pumpEvents' gathers all the pending input information from devices and places it in the event queue. Without calls to 'pumpEvents' no events would ever be placed on the queue. Often the need for calls to 'pumpEvents' is hidden from the user since 'pollEvent' and 'waitEvent' implicitly call 'pumpEvents'. However, if you are not polling or waiting for events (e.g. you are filtering them), then you must call 'pumpEvents' to force an event queue update. +-- +-- See @@ for C documentation. +pumpEvents :: MonadIO m => m () +pumpEvents = Raw.pumpEvents diff --git a/src/SDL/Hint.hs b/src/SDL/Hint.hs --- a/src/SDL/Hint.hs +++ b/src/SDL/Hint.hs @@ -1,354 +1,354 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module SDL.Hint ( - -- * Getting and setting hints - Hint(..), - setHintWithPriority, - HintPriority(..), - clearHints, - - -- * Hint Information - -- ** 'HintAccelerometerAsJoystick' - AccelerometerJoystickOptions(..), - - -- ** 'HintFramebufferAcceleration' - FramebufferAccelerationOptions(..), - - -- ** 'HintMacCTRLClick' - MacCTRLClickOptions(..), - - -- ** 'HintMouseRelativeModeWarp' - MouseModeWarpOptions(..), - - -- ** 'HintRenderDriver' - RenderDrivers(..), - - -- ** 'HintRenderOpenGLShaders' - RenderOpenGLShaderOptions(..), - - -- ** 'HintRenderScaleQuality' - RenderScaleQuality(..), - - -- ** 'HintRenderVSync' - RenderVSyncOptions(..), - - -- ** 'HintVideoWinD3DCompiler' - VideoWinD3DCompilerOptions(..) - ) where - -import Control.Exception -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Data (Data) -import Data.Maybe (fromMaybe) -import Data.StateVar -import Data.Typeable -import Foreign.C -import GHC.Generics (Generic) -import SDL.Exception -import qualified SDL.Raw as Raw - --- | A hint that specifies whether the Android\/iOS built-in accelerometer should --- be listed as a joystick device, rather than listing actual joysticks only. --- By default SDL will list real joysticks along with the accelerometer as if it --- were a 3 axis joystick. -data AccelerometerJoystickOptions - = AccelerometerNotJoystick - -- ^ List only real joysticks and accept input from them - | AccelerometerIsJoystick - -- ^ List real joysticks along with the accelerometer as if it were a 3 axis - -- joystick (the default) - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) - --- | A hint that specifies how 3D acceleration is used to accelerate the SDL --- screen surface. By default SDL tries to make a best guess whether to use --- acceleration or not on each platform. -data FramebufferAccelerationOptions - = Disable3D -- ^ Disable 3D acceleration - | Enable3DDefault -- ^ Enable 3D acceleration, using the default renderer - | Enable3DDirect3D -- ^ Enable 3D acceleration using Direct3D - | Enable3DOpenGL -- ^ Enable 3D acceleration using OpenGL - | Enable3DOpenGLES -- ^ Enable 3D acceleration using OpenGLES - | Enable3DOpenGLES2 -- ^ Enable 3D acceleration using OpenGLES2 - | Enable3DSoftware -- ^ Enable 3D acceleration using software rendering - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) - --- | A hint that specifies whether ctrl+click should generate a right-click event --- on Mac. By default holding ctrl while left clicking will not generate a right --- click event when on Mac. -data MacCTRLClickOptions - = NoRightClick -- ^ Disable emulating right click - | EmulateRightClick -- ^ Enable emulating right click - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) - --- | A hint that specifies whether relative mouse mode is implemented using mouse --- warping. By default SDL will use raw input for relative mouse mode -data MouseModeWarpOptions - = MouseRawInput -- ^ Relative mouse mode uses the raw input - | MouseWarping -- ^ Relative mouse mode uses mouse warping - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) - --- | A hint that specifies which render driver to use. By default the first one --- in the list that is available on the current platform is chosen. -data RenderDrivers - = Direct3D - | OpenGL - | OpenGLES - | OpenGLES2 - | Software - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) - --- | A hint that specifies whether the OpenGL render driver uses shaders. --- By default shaders are used if OpenGL supports them. -data RenderOpenGLShaderOptions - = DisableShaders -- ^ Disable shaders - | EnableShaders -- ^ Enable shaders, if they are available - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) - --- | A hint that specifies scaling quality. By default nearest pixel sampling is --- used. -data RenderScaleQuality - = ScaleNearest -- ^ Nearest pixel sampling - | ScaleLinear -- ^ linear filtering (supported by OpenGL and Direct3D) - | ScaleBest -- ^ Anisotropic filtering (supported by Direct3D) - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) - --- | A hint that specifies whether sync to vertical refresh is enabled or --- disabled to avoid tearing. By default SDL uses the flag passed into calls --- to create renderers. -data RenderVSyncOptions - = DisableVSync - | EnableVSync - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) - --- | A hint that specifies which shader compiler to preload when using the Chrome --- ANGLE binaries. By default @d3dcompiler_46.dll@ will be used. -data VideoWinD3DCompilerOptions - = D3DVistaOrLater -- ^ Use @d3dcompiler_46.dll@, best for Vista or later - | D3DXPSupport -- ^ Use @d3dcompiler_43.dll@ for XP support - | D3DNone -- ^ Do not load any library, useful if you compiled ANGLE from source and included the compiler in your binaries - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) - --- | The 'Hint' type exports a well-typed interface to SDL's concept of --- . This type has instances for --- both 'HasGetter' and 'HasSetter', allowing you to get and set hints. Note that --- the 'HasSetter' interface is fairly relaxed - if a hint cannot be set, the --- failure will be silently discarded. For more feedback and control when setting --- hints, see 'setHintWithPriority'. -data Hint :: * -> * where - HintAccelerometerAsJoystick :: Hint AccelerometerJoystickOptions - HintFramebufferAcceleration :: Hint FramebufferAccelerationOptions - HintMacCTRLClick :: Hint MacCTRLClickOptions - HintMouseRelativeModeWarp :: Hint MouseModeWarpOptions - HintRenderDriver :: Hint RenderDrivers - HintRenderOpenGLShaders :: Hint RenderOpenGLShaderOptions - HintRenderScaleQuality :: Hint RenderScaleQuality - HintRenderVSync :: Hint RenderVSyncOptions - HintVideoWinD3DCompiler :: Hint VideoWinD3DCompilerOptions - -instance HasSetter (Hint v) v where - hint $= v = - _setHint (\name value -> - void (Raw.setHint name value)) - hint - v - --- | How to deal with setting hints when an existing override or environment --- variable is present. -data HintPriority - = DefaultPriority -- ^ Low priority, used for default values - | NormalPriority -- ^ Medium priority - | OverridePriority -- ^ High priority - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) - --- | Set the value of a hint, applying priority rules for when there is a --- conflict. Ordinarily, a hint will not be set if there is an existing override --- hint or environment variable that takes precedence. -setHintWithPriority :: MonadIO m => HintPriority -> Hint v -> v -> m Bool -setHintWithPriority prio = - _setHint (\name value -> - Raw.setHintWithPriority - name - value - (case prio of - DefaultPriority -> Raw.SDL_HINT_DEFAULT - NormalPriority -> Raw.SDL_HINT_NORMAL - OverridePriority -> Raw.SDL_HINT_OVERRIDE)) - -_setHint :: MonadIO m => (CString -> CString -> IO a) -> Hint v -> v -> m a -_setHint f h@HintAccelerometerAsJoystick v = liftIO $ - withCString (hintToString h) $ \hint -> - withCString - (case v of - AccelerometerNotJoystick -> "0" - AccelerometerIsJoystick -> "1") - (f hint) - -_setHint f h@HintFramebufferAcceleration v = liftIO $ - withCString (hintToString h) $ \hint -> - withCString - (case v of - Disable3D -> "0" - Enable3DDefault -> "1" - Enable3DDirect3D -> "direct3d" - Enable3DOpenGL -> "opengl" - Enable3DOpenGLES -> "opengles" - Enable3DOpenGLES2 -> "opengles2" - Enable3DSoftware -> "software" - ) - (f hint) - -_setHint f h@HintMacCTRLClick v = liftIO $ - withCString (hintToString h) $ \hint -> - withCString - (case v of - NoRightClick -> "0" - EmulateRightClick -> "1") - (f hint) - -_setHint f h@HintMouseRelativeModeWarp v = liftIO $ - withCString (hintToString h) $ \hint -> - withCString - (case v of - MouseRawInput -> "0" - MouseWarping -> "1") - (f hint) - -_setHint f h@HintRenderDriver v = liftIO $ - withCString (hintToString h) $ \hint -> - withCString - (case v of - Direct3D -> "direct3d" - OpenGL -> "opengl" - OpenGLES -> "opengles" - OpenGLES2 -> "opengles2" - Software -> "software") - (f hint) - -_setHint f h@HintRenderOpenGLShaders v = liftIO $ - withCString (hintToString h) $ \hint -> - withCString - (case v of - DisableShaders -> "0" - EnableShaders -> "1") - (f hint) - -_setHint f h@HintRenderScaleQuality v = liftIO $ - withCString (hintToString h) $ \hint -> - withCString - (case v of - ScaleNearest -> "0" - ScaleLinear -> "1" - ScaleBest -> "2") - (f hint) - -_setHint f h@HintRenderVSync v = liftIO $ - withCString (hintToString h) $ \hint -> - withCString - (case v of - DisableVSync -> "0" - EnableVSync -> "1") - (f hint) - -_setHint f h@HintVideoWinD3DCompiler v = liftIO $ - withCString (hintToString h) $ \hint -> - withCString - (case v of - D3DVistaOrLater -> "d3dcompiler_46.dll" - D3DXPSupport -> "d3dcompiler_43.dll" - D3DNone -> "none") - (f hint) - --- | Retrieve and map the current value associated with the given hint. -mapHint :: MonadIO m => Hint v -> (String -> Maybe v) -> m v -mapHint h f = liftIO $ - withCString (hintToString h) $ \hint -> do - strResult <- peekCString =<< Raw.getHint hint - return $! fromMaybe - (throw (SDLUnknownHintValue (hintToString h) strResult)) - (f strResult) - -instance HasGetter (Hint v) v where - get h@HintAccelerometerAsJoystick = - mapHint h (\case - "0" -> Just AccelerometerNotJoystick - "1" -> Just AccelerometerIsJoystick - _ -> Nothing) - - get h@HintFramebufferAcceleration = - mapHint h (\case - "0" -> Just Disable3D - "1" -> Just Enable3DDefault - "direct3d" -> Just Enable3DDirect3D - "opengl" -> Just Enable3DOpenGL - "opengles" -> Just Enable3DOpenGLES - "opengles2" -> Just Enable3DOpenGLES2 - "software" -> Just Enable3DSoftware - _ -> Nothing) - - get h@HintMacCTRLClick = - mapHint h (\case - "0" -> Just NoRightClick - "1" -> Just EmulateRightClick - _ -> Nothing) - - get h@HintMouseRelativeModeWarp = - mapHint h (\case - "0" -> Just MouseRawInput - "1" -> Just MouseWarping - _ -> Nothing) - - get h@HintRenderDriver = - mapHint h (\case - "direct3d" -> Just Direct3D - "opengl" -> Just OpenGL - "opengles" -> Just OpenGLES - "opengles2" -> Just OpenGLES2 - "software" -> Just Software - _ -> Nothing) - - get h@HintRenderOpenGLShaders = - mapHint h (\case - "0" -> Just DisableShaders - "1" -> Just EnableShaders - _ -> Nothing) - - get h@HintRenderScaleQuality = - mapHint h (\case - "0" -> Just ScaleNearest - "1" -> Just ScaleLinear - "2" -> Just ScaleBest - _ -> Nothing) - - get h@HintRenderVSync = - mapHint h (\case - "0" -> Just DisableVSync - "1" -> Just EnableVSync - _ -> Nothing) - - get h@HintVideoWinD3DCompiler = - mapHint h (\case - "d3dcompiler_46.dll" -> Just D3DVistaOrLater - "d3dcompiler_43.dll" -> Just D3DXPSupport - "none" -> Just D3DNone - _ -> Nothing) - -hintToString :: Hint v -> String -hintToString HintAccelerometerAsJoystick = "SDL_HINT_ACCELEROMETER_AS_JOYSTICK" -hintToString HintFramebufferAcceleration = "SDL_HINT_FRAMEBUFFER_ACCELERATION" -hintToString HintMacCTRLClick = "SDL_HINT_MAC_CTRL_CLICK_EMULATE_RIGHT_CLICK" -hintToString HintMouseRelativeModeWarp = "SDL_HINT_MOUSE_RELATIVE_MODE_WARP" -hintToString HintRenderDriver = "SDL_HINT_RENDER_DRIVER" -hintToString HintRenderOpenGLShaders = "SDL_HINT_RENDER_OPENGL_SHADERS" -hintToString HintRenderScaleQuality = "SDL_HINT_RENDER_SCALE_QUALITY" -hintToString HintRenderVSync = "SDL_HINT_RENDER_VSYNC" -hintToString HintVideoWinD3DCompiler = "SDL_HINT_VIDEO_WIN_D3DCOMPILER" - -clearHints :: MonadIO m => m () -clearHints = Raw.clearHints +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module SDL.Hint ( + -- * Getting and setting hints + Hint(..), + setHintWithPriority, + HintPriority(..), + clearHints, + + -- * Hint Information + -- ** 'HintAccelerometerAsJoystick' + AccelerometerJoystickOptions(..), + + -- ** 'HintFramebufferAcceleration' + FramebufferAccelerationOptions(..), + + -- ** 'HintMacCTRLClick' + MacCTRLClickOptions(..), + + -- ** 'HintMouseRelativeModeWarp' + MouseModeWarpOptions(..), + + -- ** 'HintRenderDriver' + RenderDrivers(..), + + -- ** 'HintRenderOpenGLShaders' + RenderOpenGLShaderOptions(..), + + -- ** 'HintRenderScaleQuality' + RenderScaleQuality(..), + + -- ** 'HintRenderVSync' + RenderVSyncOptions(..), + + -- ** 'HintVideoWinD3DCompiler' + VideoWinD3DCompilerOptions(..) + ) where + +import Control.Exception +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Data (Data) +import Data.Maybe (fromMaybe) +import Data.StateVar +import Data.Typeable +import Foreign.C +import GHC.Generics (Generic) +import SDL.Exception +import qualified SDL.Raw as Raw + +-- | A hint that specifies whether the Android\/iOS built-in accelerometer should +-- be listed as a joystick device, rather than listing actual joysticks only. +-- By default SDL will list real joysticks along with the accelerometer as if it +-- were a 3 axis joystick. +data AccelerometerJoystickOptions + = AccelerometerNotJoystick + -- ^ List only real joysticks and accept input from them + | AccelerometerIsJoystick + -- ^ List real joysticks along with the accelerometer as if it were a 3 axis + -- joystick (the default) + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + +-- | A hint that specifies how 3D acceleration is used to accelerate the SDL +-- screen surface. By default SDL tries to make a best guess whether to use +-- acceleration or not on each platform. +data FramebufferAccelerationOptions + = Disable3D -- ^ Disable 3D acceleration + | Enable3DDefault -- ^ Enable 3D acceleration, using the default renderer + | Enable3DDirect3D -- ^ Enable 3D acceleration using Direct3D + | Enable3DOpenGL -- ^ Enable 3D acceleration using OpenGL + | Enable3DOpenGLES -- ^ Enable 3D acceleration using OpenGLES + | Enable3DOpenGLES2 -- ^ Enable 3D acceleration using OpenGLES2 + | Enable3DSoftware -- ^ Enable 3D acceleration using software rendering + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + +-- | A hint that specifies whether ctrl+click should generate a right-click event +-- on Mac. By default holding ctrl while left clicking will not generate a right +-- click event when on Mac. +data MacCTRLClickOptions + = NoRightClick -- ^ Disable emulating right click + | EmulateRightClick -- ^ Enable emulating right click + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + +-- | A hint that specifies whether relative mouse mode is implemented using mouse +-- warping. By default SDL will use raw input for relative mouse mode +data MouseModeWarpOptions + = MouseRawInput -- ^ Relative mouse mode uses the raw input + | MouseWarping -- ^ Relative mouse mode uses mouse warping + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + +-- | A hint that specifies which render driver to use. By default the first one +-- in the list that is available on the current platform is chosen. +data RenderDrivers + = Direct3D + | OpenGL + | OpenGLES + | OpenGLES2 + | Software + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + +-- | A hint that specifies whether the OpenGL render driver uses shaders. +-- By default shaders are used if OpenGL supports them. +data RenderOpenGLShaderOptions + = DisableShaders -- ^ Disable shaders + | EnableShaders -- ^ Enable shaders, if they are available + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + +-- | A hint that specifies scaling quality. By default nearest pixel sampling is +-- used. +data RenderScaleQuality + = ScaleNearest -- ^ Nearest pixel sampling + | ScaleLinear -- ^ linear filtering (supported by OpenGL and Direct3D) + | ScaleBest -- ^ Anisotropic filtering (supported by Direct3D) + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + +-- | A hint that specifies whether sync to vertical refresh is enabled or +-- disabled to avoid tearing. By default SDL uses the flag passed into calls +-- to create renderers. +data RenderVSyncOptions + = DisableVSync + | EnableVSync + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + +-- | A hint that specifies which shader compiler to preload when using the Chrome +-- ANGLE binaries. By default @d3dcompiler_46.dll@ will be used. +data VideoWinD3DCompilerOptions + = D3DVistaOrLater -- ^ Use @d3dcompiler_46.dll@, best for Vista or later + | D3DXPSupport -- ^ Use @d3dcompiler_43.dll@ for XP support + | D3DNone -- ^ Do not load any library, useful if you compiled ANGLE from source and included the compiler in your binaries + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + +-- | The 'Hint' type exports a well-typed interface to SDL's concept of +-- . This type has instances for +-- both 'HasGetter' and 'HasSetter', allowing you to get and set hints. Note that +-- the 'HasSetter' interface is fairly relaxed - if a hint cannot be set, the +-- failure will be silently discarded. For more feedback and control when setting +-- hints, see 'setHintWithPriority'. +data Hint :: * -> * where + HintAccelerometerAsJoystick :: Hint AccelerometerJoystickOptions + HintFramebufferAcceleration :: Hint FramebufferAccelerationOptions + HintMacCTRLClick :: Hint MacCTRLClickOptions + HintMouseRelativeModeWarp :: Hint MouseModeWarpOptions + HintRenderDriver :: Hint RenderDrivers + HintRenderOpenGLShaders :: Hint RenderOpenGLShaderOptions + HintRenderScaleQuality :: Hint RenderScaleQuality + HintRenderVSync :: Hint RenderVSyncOptions + HintVideoWinD3DCompiler :: Hint VideoWinD3DCompilerOptions + +instance HasSetter (Hint v) v where + hint $= v = + _setHint (\name value -> + void (Raw.setHint name value)) + hint + v + +-- | How to deal with setting hints when an existing override or environment +-- variable is present. +data HintPriority + = DefaultPriority -- ^ Low priority, used for default values + | NormalPriority -- ^ Medium priority + | OverridePriority -- ^ High priority + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + +-- | Set the value of a hint, applying priority rules for when there is a +-- conflict. Ordinarily, a hint will not be set if there is an existing override +-- hint or environment variable that takes precedence. +setHintWithPriority :: MonadIO m => HintPriority -> Hint v -> v -> m Bool +setHintWithPriority prio = + _setHint (\name value -> + Raw.setHintWithPriority + name + value + (case prio of + DefaultPriority -> Raw.SDL_HINT_DEFAULT + NormalPriority -> Raw.SDL_HINT_NORMAL + OverridePriority -> Raw.SDL_HINT_OVERRIDE)) + +_setHint :: MonadIO m => (CString -> CString -> IO a) -> Hint v -> v -> m a +_setHint f h@HintAccelerometerAsJoystick v = liftIO $ + withCString (hintToString h) $ \hint -> + withCString + (case v of + AccelerometerNotJoystick -> "0" + AccelerometerIsJoystick -> "1") + (f hint) + +_setHint f h@HintFramebufferAcceleration v = liftIO $ + withCString (hintToString h) $ \hint -> + withCString + (case v of + Disable3D -> "0" + Enable3DDefault -> "1" + Enable3DDirect3D -> "direct3d" + Enable3DOpenGL -> "opengl" + Enable3DOpenGLES -> "opengles" + Enable3DOpenGLES2 -> "opengles2" + Enable3DSoftware -> "software" + ) + (f hint) + +_setHint f h@HintMacCTRLClick v = liftIO $ + withCString (hintToString h) $ \hint -> + withCString + (case v of + NoRightClick -> "0" + EmulateRightClick -> "1") + (f hint) + +_setHint f h@HintMouseRelativeModeWarp v = liftIO $ + withCString (hintToString h) $ \hint -> + withCString + (case v of + MouseRawInput -> "0" + MouseWarping -> "1") + (f hint) + +_setHint f h@HintRenderDriver v = liftIO $ + withCString (hintToString h) $ \hint -> + withCString + (case v of + Direct3D -> "direct3d" + OpenGL -> "opengl" + OpenGLES -> "opengles" + OpenGLES2 -> "opengles2" + Software -> "software") + (f hint) + +_setHint f h@HintRenderOpenGLShaders v = liftIO $ + withCString (hintToString h) $ \hint -> + withCString + (case v of + DisableShaders -> "0" + EnableShaders -> "1") + (f hint) + +_setHint f h@HintRenderScaleQuality v = liftIO $ + withCString (hintToString h) $ \hint -> + withCString + (case v of + ScaleNearest -> "0" + ScaleLinear -> "1" + ScaleBest -> "2") + (f hint) + +_setHint f h@HintRenderVSync v = liftIO $ + withCString (hintToString h) $ \hint -> + withCString + (case v of + DisableVSync -> "0" + EnableVSync -> "1") + (f hint) + +_setHint f h@HintVideoWinD3DCompiler v = liftIO $ + withCString (hintToString h) $ \hint -> + withCString + (case v of + D3DVistaOrLater -> "d3dcompiler_46.dll" + D3DXPSupport -> "d3dcompiler_43.dll" + D3DNone -> "none") + (f hint) + +-- | Retrieve and map the current value associated with the given hint. +mapHint :: MonadIO m => Hint v -> (String -> Maybe v) -> m v +mapHint h f = liftIO $ + withCString (hintToString h) $ \hint -> do + strResult <- peekCString =<< Raw.getHint hint + return $! fromMaybe + (throw (SDLUnknownHintValue (hintToString h) strResult)) + (f strResult) + +instance HasGetter (Hint v) v where + get h@HintAccelerometerAsJoystick = + mapHint h (\case + "0" -> Just AccelerometerNotJoystick + "1" -> Just AccelerometerIsJoystick + _ -> Nothing) + + get h@HintFramebufferAcceleration = + mapHint h (\case + "0" -> Just Disable3D + "1" -> Just Enable3DDefault + "direct3d" -> Just Enable3DDirect3D + "opengl" -> Just Enable3DOpenGL + "opengles" -> Just Enable3DOpenGLES + "opengles2" -> Just Enable3DOpenGLES2 + "software" -> Just Enable3DSoftware + _ -> Nothing) + + get h@HintMacCTRLClick = + mapHint h (\case + "0" -> Just NoRightClick + "1" -> Just EmulateRightClick + _ -> Nothing) + + get h@HintMouseRelativeModeWarp = + mapHint h (\case + "0" -> Just MouseRawInput + "1" -> Just MouseWarping + _ -> Nothing) + + get h@HintRenderDriver = + mapHint h (\case + "direct3d" -> Just Direct3D + "opengl" -> Just OpenGL + "opengles" -> Just OpenGLES + "opengles2" -> Just OpenGLES2 + "software" -> Just Software + _ -> Nothing) + + get h@HintRenderOpenGLShaders = + mapHint h (\case + "0" -> Just DisableShaders + "1" -> Just EnableShaders + _ -> Nothing) + + get h@HintRenderScaleQuality = + mapHint h (\case + "0" -> Just ScaleNearest + "1" -> Just ScaleLinear + "2" -> Just ScaleBest + _ -> Nothing) + + get h@HintRenderVSync = + mapHint h (\case + "0" -> Just DisableVSync + "1" -> Just EnableVSync + _ -> Nothing) + + get h@HintVideoWinD3DCompiler = + mapHint h (\case + "d3dcompiler_46.dll" -> Just D3DVistaOrLater + "d3dcompiler_43.dll" -> Just D3DXPSupport + "none" -> Just D3DNone + _ -> Nothing) + +hintToString :: Hint v -> String +hintToString HintAccelerometerAsJoystick = "SDL_ACCELEROMETER_AS_JOYSTICK" +hintToString HintFramebufferAcceleration = "SDL_FRAMEBUFFER_ACCELERATION" +hintToString HintMacCTRLClick = "SDL_MAC_CTRL_CLICK_EMULATE_RIGHT_CLICK" +hintToString HintMouseRelativeModeWarp = "SDL_MOUSE_RELATIVE_MODE_WARP" +hintToString HintRenderDriver = "SDL_RENDER_DRIVER" +hintToString HintRenderOpenGLShaders = "SDL_RENDER_OPENGL_SHADERS" +hintToString HintRenderScaleQuality = "SDL_RENDER_SCALE_QUALITY" +hintToString HintRenderVSync = "SDL_RENDER_VSYNC" +hintToString HintVideoWinD3DCompiler = "SDL_VIDEO_WIN_D3DCOMPILER" + +clearHints :: MonadIO m => m () +clearHints = Raw.clearHints diff --git a/src/SDL/Input/Joystick.hs b/src/SDL/Input/Joystick.hs --- a/src/SDL/Input/Joystick.hs +++ b/src/SDL/Input/Joystick.hs @@ -1,148 +1,148 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module SDL.Input.Joystick - ( numJoysticks - , availableJoysticks - , JoystickDevice(..) - - , openJoystick - , closeJoystick - - , getJoystickID - , Joystick - , buttonPressed - , ballDelta - , axisPosition - , numAxes - , numButtons - , numBalls - ) where - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Int -import Data.Text (Text) -import Data.Traversable (for) -import Data.Typeable -import Foreign.C.Types -import Foreign.Marshal.Alloc -import Foreign.Storable -import GHC.Generics (Generic) -import Linear -import SDL.Exception -import SDL.Internal.Types -import qualified Data.ByteString as BS -import qualified Data.Text.Encoding as Text -import qualified Data.Vector as V -import qualified SDL.Raw as Raw - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - --- | A description of joystick that can be opened using 'openJoystick'. To retrieve a list of --- connected joysticks, use 'availableJoysticks'. -data JoystickDevice = JoystickDevice - { joystickDeviceName :: Text - , joystickDeviceId :: CInt - } deriving (Eq, Generic, Read, Ord, Show, Typeable) - --- | Count the number of joysticks attached to the system. --- --- See @@ for C documentation. -numJoysticks :: MonadIO m => m (CInt) -numJoysticks = throwIfNeg "SDL.Input.Joystick.availableJoysticks" "SDL_NumJoysticks" Raw.numJoysticks - --- | Enumerate all connected joysticks, retrieving a description of each. -availableJoysticks :: MonadIO m => m (V.Vector JoystickDevice) -availableJoysticks = liftIO $ do - n <- numJoysticks - fmap (V.fromList) $ - for [0 .. (n - 1)] $ \i -> do - cstr <- - throwIfNull "SDL.Input.Joystick.availableJoysticks" "SDL_JoystickNameForIndex" $ - Raw.joystickNameForIndex i - name <- Text.decodeUtf8 <$> BS.packCString cstr - return (JoystickDevice name i) - --- | Open a joystick so that you can start receiving events from interaction with this joystick. --- --- See @@ for C documentation. -openJoystick :: (Functor m,MonadIO m) - => JoystickDevice -- ^ The device to open. Use 'availableJoysticks' to find 'JoystickDevices's - -> m Joystick -openJoystick (JoystickDevice _ x) = - fmap Joystick $ - throwIfNull "SDL.Input.Joystick.openJoystick" "SDL_OpenJoystick" $ - Raw.joystickOpen x - --- | Close a joystick previously opened with 'openJoystick'. --- --- See @@ for C documentation. -closeJoystick :: MonadIO m => Joystick -> m () -closeJoystick (Joystick j) = Raw.joystickClose j - --- | Get the instance ID of an opened joystick. The instance ID is used to identify the joystick --- in future SDL events. --- --- See @@ for C documentation. -getJoystickID :: MonadIO m => Joystick -> m (Int32) -getJoystickID (Joystick j) = - throwIfNeg "SDL.Input.Joystick.getJoystickID" "SDL_JoystickInstanceID" $ - Raw.joystickInstanceID j - --- | Determine if a given button is currently held. --- --- See @@ for C documentation. -buttonPressed :: (Functor m,MonadIO m) - => Joystick - -> CInt -- ^ The index of the button. You can use 'numButtons' to determine how many buttons a given joystick has. - -> m Bool -buttonPressed (Joystick j) buttonIndex = (== 1) <$> Raw.joystickGetButton j buttonIndex - --- | Get the ball axis change since the last poll. --- --- See @@ for C documentation. -ballDelta :: MonadIO m - => Joystick - -> CInt -- ^ The index of the joystick ball. You can use 'numBalls' to determine how many balls a given joystick has. - -> m (V2 CInt) -ballDelta (Joystick j) ballIndex = liftIO $ - alloca $ \xptr -> - alloca $ \yptr -> do - throwIfNeg_ "SDL.Input.Joystick.ballDelta" "SDL_JoystickGetBall" $ - Raw.joystickGetBall j ballIndex xptr yptr - - V2 <$> peek xptr <*> peek yptr - --- | Get the current state of an axis control on a joystick. --- --- Returns a 16-bit signed integer representing the current position of the axis. The state is a value ranging from -32768 to 32767. --- --- On most modern joysticks the x-axis is usually represented by axis 0 and the y-axis by axis 1. The value returned by 'axisPosition' is a signed integer (-32768 to 32767) representing the current position of the axis. It may be necessary to impose certain tolerances on these values to account for jitter. --- --- Some joysticks use axes 2 and 3 for extra buttons. --- --- See @@ for C documentation. -axisPosition :: MonadIO m => Joystick -> CInt -> m Int16 -axisPosition (Joystick j) axisIndex = Raw.joystickGetAxis j axisIndex - --- | Get the number of general axis controls on a joystick. --- --- See @@ for C documentation. -numAxes :: (MonadIO m) => Joystick -> m CInt -numAxes (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numAxis" "SDL_JoystickNumAxes" (Raw.joystickNumAxes j) - --- | Get the number of buttons on a joystick. --- --- See @@ for C documentation. -numButtons :: (MonadIO m) => Joystick -> m CInt -numButtons (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numButtons" "SDL_JoystickNumButtons" (Raw.joystickNumButtons j) - --- | Get the number of trackballs on a joystick. --- --- See @@ for C documentation. -numBalls :: (MonadIO m) => Joystick -> m CInt -numBalls (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numBalls" "SDL_JoystickNumBalls" (Raw.joystickNumBalls j) +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module SDL.Input.Joystick + ( numJoysticks + , availableJoysticks + , JoystickDevice(..) + + , openJoystick + , closeJoystick + + , getJoystickID + , Joystick + , buttonPressed + , ballDelta + , axisPosition + , numAxes + , numButtons + , numBalls + ) where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Int +import Data.Text (Text) +import Data.Traversable (for) +import Data.Typeable +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Foreign.Storable +import GHC.Generics (Generic) +import SDL.Vect +import SDL.Exception +import SDL.Internal.Types +import qualified Data.ByteString as BS +import qualified Data.Text.Encoding as Text +import qualified Data.Vector as V +import qualified SDL.Raw as Raw + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +-- | A description of joystick that can be opened using 'openJoystick'. To retrieve a list of +-- connected joysticks, use 'availableJoysticks'. +data JoystickDevice = JoystickDevice + { joystickDeviceName :: Text + , joystickDeviceId :: CInt + } deriving (Eq, Generic, Read, Ord, Show, Typeable) + +-- | Count the number of joysticks attached to the system. +-- +-- See @@ for C documentation. +numJoysticks :: MonadIO m => m (CInt) +numJoysticks = throwIfNeg "SDL.Input.Joystick.availableJoysticks" "SDL_NumJoysticks" Raw.numJoysticks + +-- | Enumerate all connected joysticks, retrieving a description of each. +availableJoysticks :: MonadIO m => m (V.Vector JoystickDevice) +availableJoysticks = liftIO $ do + n <- numJoysticks + fmap (V.fromList) $ + for [0 .. (n - 1)] $ \i -> do + cstr <- + throwIfNull "SDL.Input.Joystick.availableJoysticks" "SDL_JoystickNameForIndex" $ + Raw.joystickNameForIndex i + name <- Text.decodeUtf8 <$> BS.packCString cstr + return (JoystickDevice name i) + +-- | Open a joystick so that you can start receiving events from interaction with this joystick. +-- +-- See @@ for C documentation. +openJoystick :: (Functor m,MonadIO m) + => JoystickDevice -- ^ The device to open. Use 'availableJoysticks' to find 'JoystickDevices's + -> m Joystick +openJoystick (JoystickDevice _ x) = + fmap Joystick $ + throwIfNull "SDL.Input.Joystick.openJoystick" "SDL_OpenJoystick" $ + Raw.joystickOpen x + +-- | Close a joystick previously opened with 'openJoystick'. +-- +-- See @@ for C documentation. +closeJoystick :: MonadIO m => Joystick -> m () +closeJoystick (Joystick j) = Raw.joystickClose j + +-- | Get the instance ID of an opened joystick. The instance ID is used to identify the joystick +-- in future SDL events. +-- +-- See @@ for C documentation. +getJoystickID :: MonadIO m => Joystick -> m (Int32) +getJoystickID (Joystick j) = + throwIfNeg "SDL.Input.Joystick.getJoystickID" "SDL_JoystickInstanceID" $ + Raw.joystickInstanceID j + +-- | Determine if a given button is currently held. +-- +-- See @@ for C documentation. +buttonPressed :: (Functor m,MonadIO m) + => Joystick + -> CInt -- ^ The index of the button. You can use 'numButtons' to determine how many buttons a given joystick has. + -> m Bool +buttonPressed (Joystick j) buttonIndex = (== 1) <$> Raw.joystickGetButton j buttonIndex + +-- | Get the ball axis change since the last poll. +-- +-- See @@ for C documentation. +ballDelta :: MonadIO m + => Joystick + -> CInt -- ^ The index of the joystick ball. You can use 'numBalls' to determine how many balls a given joystick has. + -> m (V2 CInt) +ballDelta (Joystick j) ballIndex = liftIO $ + alloca $ \xptr -> + alloca $ \yptr -> do + throwIfNeg_ "SDL.Input.Joystick.ballDelta" "SDL_JoystickGetBall" $ + Raw.joystickGetBall j ballIndex xptr yptr + + V2 <$> peek xptr <*> peek yptr + +-- | Get the current state of an axis control on a joystick. +-- +-- Returns a 16-bit signed integer representing the current position of the axis. The state is a value ranging from -32768 to 32767. +-- +-- On most modern joysticks the x-axis is usually represented by axis 0 and the y-axis by axis 1. The value returned by 'axisPosition' is a signed integer (-32768 to 32767) representing the current position of the axis. It may be necessary to impose certain tolerances on these values to account for jitter. +-- +-- Some joysticks use axes 2 and 3 for extra buttons. +-- +-- See @@ for C documentation. +axisPosition :: MonadIO m => Joystick -> CInt -> m Int16 +axisPosition (Joystick j) axisIndex = Raw.joystickGetAxis j axisIndex + +-- | Get the number of general axis controls on a joystick. +-- +-- See @@ for C documentation. +numAxes :: (MonadIO m) => Joystick -> m CInt +numAxes (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numAxis" "SDL_JoystickNumAxes" (Raw.joystickNumAxes j) + +-- | Get the number of buttons on a joystick. +-- +-- See @@ for C documentation. +numButtons :: (MonadIO m) => Joystick -> m CInt +numButtons (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numButtons" "SDL_JoystickNumButtons" (Raw.joystickNumButtons j) + +-- | Get the number of trackballs on a joystick. +-- +-- See @@ for C documentation. +numBalls :: (MonadIO m) => Joystick -> m CInt +numBalls (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numBalls" "SDL_JoystickNumBalls" (Raw.joystickNumBalls j) diff --git a/src/SDL/Input/Mouse.hs b/src/SDL/Input/Mouse.hs --- a/src/SDL/Input/Mouse.hs +++ b/src/SDL/Input/Mouse.hs @@ -1,245 +1,244 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} - -module SDL.Input.Mouse - ( -- * Relative Mouse Mode - LocationMode(..) - , setMouseLocationMode - , getMouseLocationMode - , setRelativeMouseMode --deprecated - , getRelativeMouseMode --deprecated - - -- * Mouse and Touch Input - , MouseButton(..) - , MouseDevice(..) - - -- * Mouse State - , getModalMouseLocation - , getMouseLocation --deprecated - , getAbsoluteMouseLocation - , getRelativeMouseLocation - , getMouseButtons - - -- * Warping the Mouse - , WarpMouseOrigin - , warpMouse - - -- * Cursor Visibility - , cursorVisible - - -- * Cursor Shape - , Cursor - , activeCursor - , createCursor - , freeCursor - , createColorCursor - ) where - -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Bits -import Data.Bool -import Data.Data (Data) -import Data.StateVar -import Data.Typeable -import Data.Word -import Foreign.C -import Foreign.Marshal.Alloc -import Foreign.Ptr -import Foreign.Storable -import GHC.Generics (Generic) -import Linear -import Linear.Affine -import SDL.Exception -import SDL.Internal.Numbered -import SDL.Internal.Types (Window(Window)) -import SDL.Video.Renderer (Surface(Surface)) -import qualified Data.Vector.Storable as V -import qualified SDL.Raw.Enum as Raw -import qualified SDL.Raw.Event as Raw -import qualified SDL.Raw.Types as Raw - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - -data LocationMode = AbsoluteLocation | RelativeLocation deriving Eq - --- | Sets the current relative mouse mode. --- --- When relative mouse mode is enabled, cursor is hidden and mouse position --- will not change. However, you will be delivered relative mouse position --- change events. -setMouseLocationMode :: (Functor m, MonadIO m) => LocationMode -> m LocationMode -setMouseLocationMode mode = - Raw.setRelativeMouseMode (mode == RelativeLocation) >> getMouseLocationMode - --- | Check which mouse location mode is currently active. -getMouseLocationMode :: MonadIO m => m LocationMode -getMouseLocationMode = do - relativeMode <- Raw.getRelativeMouseMode - return $ if relativeMode then RelativeLocation else AbsoluteLocation - --- | Return proper mouse location depending on mouse mode -getModalMouseLocation :: MonadIO m => m (LocationMode, Point V2 CInt) -getModalMouseLocation = do - mode <- getMouseLocationMode - location <- case mode of - RelativeLocation -> getRelativeMouseLocation - _ -> getAbsoluteMouseLocation - return (mode, location) - --- deprecated -setRelativeMouseMode :: (Functor m, MonadIO m) => Bool -> m () -{-# DEPRECATED setRelativeMouseMode "Use setMouseLocationMode instead" #-} -setRelativeMouseMode enable = - throwIfNeg_ "SDL.Input.Mouse" "SDL_SetRelativeMouseMode" $ - Raw.setRelativeMouseMode enable - ---deprecated -getRelativeMouseMode :: MonadIO m => m Bool -{-# DEPRECATED getRelativeMouseMode "Use getMouseLocationMode instead" #-} -getRelativeMouseMode = Raw.getRelativeMouseMode - ---deprecated -getMouseLocation :: MonadIO m => m (Point V2 CInt) -{-# DEPRECATED getMouseLocation "Use getAbsoluteMouseLocation instead, or getModalMouseLocation to match future behavior." #-} -getMouseLocation = getAbsoluteMouseLocation - -data MouseButton - = ButtonLeft - | ButtonMiddle - | ButtonRight - | ButtonX1 - | ButtonX2 - | ButtonExtra !Int -- ^ An unknown mouse button. - deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) - --- | Identifies what kind of mouse-like device this is. -data MouseDevice - = Mouse !Int -- ^ An actual mouse. The number identifies which mouse. - | Touch -- ^ Some sort of touch device. - deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) - -instance FromNumber MouseDevice Word32 where - fromNumber n' = case n' of - Raw.SDL_TOUCH_MOUSEID -> Touch - n -> Mouse $ fromIntegral n - -data WarpMouseOrigin - = WarpInWindow Window - -- ^ Move the mouse pointer within a given 'Window'. - | WarpCurrentFocus - -- ^ Move the mouse pointer within whichever 'Window' currently has focus. - -- WarpGlobal -- Needs 2.0.4 - deriving (Data, Eq, Generic, Ord, Show, Typeable) - --- | Move the current location of a mouse pointer. The 'WarpMouseOrigin' specifies the origin for the given warp coordinates. -warpMouse :: MonadIO m => WarpMouseOrigin -> Point V2 CInt -> m () -warpMouse (WarpInWindow (Window w)) (P (V2 x y)) = Raw.warpMouseInWindow w x y -warpMouse WarpCurrentFocus (P (V2 x y)) = Raw.warpMouseInWindow nullPtr x y - --- | Get or set whether the cursor is currently visible. --- --- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. --- --- See @@ and @@ for C documentation. -cursorVisible :: StateVar Bool -cursorVisible = makeStateVar getCursorVisible setCursorVisible - where - -- The usage of 'void' is OK here - Raw.showCursor just returns the old state. - setCursorVisible :: (Functor m, MonadIO m) => Bool -> m () - setCursorVisible True = void $ Raw.showCursor 1 - setCursorVisible False = void $ Raw.showCursor 0 - - getCursorVisible :: (Functor m, MonadIO m) => m Bool - getCursorVisible = (== 1) <$> Raw.showCursor (-1) - --- | Retrieve the current location of the mouse, relative to the currently focused window. -getAbsoluteMouseLocation :: MonadIO m => m (Point V2 CInt) -getAbsoluteMouseLocation = liftIO $ - alloca $ \x -> - alloca $ \y -> do - _ <- Raw.getMouseState x y -- We don't deal with button states here - P <$> (V2 <$> peek x <*> peek y) - --- | Retrieve mouse motion -getRelativeMouseLocation :: MonadIO m => m (Point V2 CInt) -getRelativeMouseLocation = liftIO $ - alloca $ \x -> - alloca $ \y -> do - _ <- Raw.getRelativeMouseState x y - P <$> (V2 <$> peek x <*> peek y) - - --- | Retrieve a mapping of which buttons are currently held down. -getMouseButtons :: MonadIO m => m (MouseButton -> Bool) -getMouseButtons = liftIO $ - convert <$> Raw.getMouseState nullPtr nullPtr - where - convert w b = w `testBit` index - where - index = case b of - ButtonLeft -> 0 - ButtonMiddle -> 1 - ButtonRight -> 2 - ButtonX1 -> 3 - ButtonX2 -> 4 - ButtonExtra i -> i - -newtype Cursor = Cursor { unwrapCursor :: Raw.Cursor } - deriving (Eq, Typeable) - --- | Get or set the currently active cursor. You can create new 'Cursor's with 'createCursor'. --- --- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. --- --- See @@ and @@ for C documentation. -activeCursor :: StateVar Cursor -activeCursor = makeStateVar getCursor setCursor - where - getCursor :: MonadIO m => m Cursor - getCursor = liftIO . fmap Cursor $ - throwIfNull "SDL.Input.Mouse.getCursor" "SDL_getCursor" - Raw.getCursor - - setCursor :: MonadIO m => Cursor -> m () - setCursor = Raw.setCursor . unwrapCursor - --- | Create a cursor using the specified bitmap data and mask (in MSB format). --- --- -createCursor :: MonadIO m - => V.Vector Bool -- ^ Whether this part of the cursor is black. Use 'False' for white and 'True' for black. - -> V.Vector Bool -- ^ Whether or not pixels are visible. Use 'True' for visible and 'False' for transparent. - -> V2 CInt -- ^ The width and height of the cursor. - -> Point V2 CInt -- ^ The X- and Y-axis location of the upper left corner of the cursor relative to the actual mouse position - -> m Cursor -createCursor dta msk (V2 w h) (P (V2 hx hy)) = - liftIO . fmap Cursor $ - throwIfNull "SDL.Input.Mouse.createCursor" "SDL_createCursor" $ - V.unsafeWith (V.map (bool 0 1) dta) $ \unsafeDta -> - V.unsafeWith (V.map (bool 0 1) msk) $ \unsafeMsk -> - Raw.createCursor unsafeDta unsafeMsk w h hx hy - --- | Free a cursor created with 'createCursor' and 'createColorCusor'. --- --- See @@ for C documentation. -freeCursor :: MonadIO m => Cursor -> m () -freeCursor = Raw.freeCursor . unwrapCursor - --- | Create a color cursor. --- --- See @@ for C documentation. -createColorCursor :: MonadIO m - => Surface - -> Point V2 CInt -- ^ The location of the cursor hot spot - -> m Cursor -createColorCursor (Surface surfPtr _) (P (V2 hx hy)) = - liftIO . fmap Cursor $ - throwIfNull "SDL.Input.Mouse.createColorCursor" "SDL_createColorCursor" $ - Raw.createColorCursor surfPtr hx hy +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module SDL.Input.Mouse + ( -- * Relative Mouse Mode + LocationMode(..) + , setMouseLocationMode + , getMouseLocationMode + , setRelativeMouseMode --deprecated + , getRelativeMouseMode --deprecated + + -- * Mouse and Touch Input + , MouseButton(..) + , MouseDevice(..) + + -- * Mouse State + , getModalMouseLocation + , getMouseLocation --deprecated + , getAbsoluteMouseLocation + , getRelativeMouseLocation + , getMouseButtons + + -- * Warping the Mouse + , WarpMouseOrigin + , warpMouse + + -- * Cursor Visibility + , cursorVisible + + -- * Cursor Shape + , Cursor + , activeCursor + , createCursor + , freeCursor + , createColorCursor + ) where + +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Bits +import Data.Bool +import Data.Data (Data) +import Data.StateVar +import Data.Typeable +import Data.Word +import Foreign.C +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable +import GHC.Generics (Generic) +import SDL.Vect +import SDL.Exception +import SDL.Internal.Numbered +import SDL.Internal.Types (Window(Window)) +import SDL.Video.Renderer (Surface(Surface)) +import qualified Data.Vector.Storable as V +import qualified SDL.Raw.Enum as Raw +import qualified SDL.Raw.Event as Raw +import qualified SDL.Raw.Types as Raw + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +data LocationMode = AbsoluteLocation | RelativeLocation deriving Eq + +-- | Sets the current relative mouse mode. +-- +-- When relative mouse mode is enabled, cursor is hidden and mouse position +-- will not change. However, you will be delivered relative mouse position +-- change events. +setMouseLocationMode :: (Functor m, MonadIO m) => LocationMode -> m LocationMode +setMouseLocationMode mode = + Raw.setRelativeMouseMode (mode == RelativeLocation) >> getMouseLocationMode + +-- | Check which mouse location mode is currently active. +getMouseLocationMode :: MonadIO m => m LocationMode +getMouseLocationMode = do + relativeMode <- Raw.getRelativeMouseMode + return $ if relativeMode then RelativeLocation else AbsoluteLocation + +-- | Return proper mouse location depending on mouse mode +getModalMouseLocation :: MonadIO m => m (LocationMode, Point V2 CInt) +getModalMouseLocation = do + mode <- getMouseLocationMode + location <- case mode of + RelativeLocation -> getRelativeMouseLocation + _ -> getAbsoluteMouseLocation + return (mode, location) + +-- deprecated +setRelativeMouseMode :: (Functor m, MonadIO m) => Bool -> m () +{-# DEPRECATED setRelativeMouseMode "Use setMouseLocationMode instead" #-} +setRelativeMouseMode enable = + throwIfNeg_ "SDL.Input.Mouse" "SDL_SetRelativeMouseMode" $ + Raw.setRelativeMouseMode enable + +--deprecated +getRelativeMouseMode :: MonadIO m => m Bool +{-# DEPRECATED getRelativeMouseMode "Use getMouseLocationMode instead" #-} +getRelativeMouseMode = Raw.getRelativeMouseMode + +--deprecated +getMouseLocation :: MonadIO m => m (Point V2 CInt) +{-# DEPRECATED getMouseLocation "Use getAbsoluteMouseLocation instead, or getModalMouseLocation to match future behavior." #-} +getMouseLocation = getAbsoluteMouseLocation + +data MouseButton + = ButtonLeft + | ButtonMiddle + | ButtonRight + | ButtonX1 + | ButtonX2 + | ButtonExtra !Int -- ^ An unknown mouse button. + deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) + +-- | Identifies what kind of mouse-like device this is. +data MouseDevice + = Mouse !Int -- ^ An actual mouse. The number identifies which mouse. + | Touch -- ^ Some sort of touch device. + deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) + +instance FromNumber MouseDevice Word32 where + fromNumber n' = case n' of + Raw.SDL_TOUCH_MOUSEID -> Touch + n -> Mouse $ fromIntegral n + +data WarpMouseOrigin + = WarpInWindow Window + -- ^ Move the mouse pointer within a given 'Window'. + | WarpCurrentFocus + -- ^ Move the mouse pointer within whichever 'Window' currently has focus. + -- WarpGlobal -- Needs 2.0.4 + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +-- | Move the current location of a mouse pointer. The 'WarpMouseOrigin' specifies the origin for the given warp coordinates. +warpMouse :: MonadIO m => WarpMouseOrigin -> Point V2 CInt -> m () +warpMouse (WarpInWindow (Window w)) (P (V2 x y)) = Raw.warpMouseInWindow w x y +warpMouse WarpCurrentFocus (P (V2 x y)) = Raw.warpMouseInWindow nullPtr x y + +-- | Get or set whether the cursor is currently visible. +-- +-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. +-- +-- See @@ and @@ for C documentation. +cursorVisible :: StateVar Bool +cursorVisible = makeStateVar getCursorVisible setCursorVisible + where + -- The usage of 'void' is OK here - Raw.showCursor just returns the old state. + setCursorVisible :: (Functor m, MonadIO m) => Bool -> m () + setCursorVisible True = void $ Raw.showCursor 1 + setCursorVisible False = void $ Raw.showCursor 0 + + getCursorVisible :: (Functor m, MonadIO m) => m Bool + getCursorVisible = (== 1) <$> Raw.showCursor (-1) + +-- | Retrieve the current location of the mouse, relative to the currently focused window. +getAbsoluteMouseLocation :: MonadIO m => m (Point V2 CInt) +getAbsoluteMouseLocation = liftIO $ + alloca $ \x -> + alloca $ \y -> do + _ <- Raw.getMouseState x y -- We don't deal with button states here + P <$> (V2 <$> peek x <*> peek y) + +-- | Retrieve mouse motion +getRelativeMouseLocation :: MonadIO m => m (Point V2 CInt) +getRelativeMouseLocation = liftIO $ + alloca $ \x -> + alloca $ \y -> do + _ <- Raw.getRelativeMouseState x y + P <$> (V2 <$> peek x <*> peek y) + + +-- | Retrieve a mapping of which buttons are currently held down. +getMouseButtons :: MonadIO m => m (MouseButton -> Bool) +getMouseButtons = liftIO $ + convert <$> Raw.getMouseState nullPtr nullPtr + where + convert w b = w `testBit` index + where + index = case b of + ButtonLeft -> 0 + ButtonMiddle -> 1 + ButtonRight -> 2 + ButtonX1 -> 3 + ButtonX2 -> 4 + ButtonExtra i -> i + +newtype Cursor = Cursor { unwrapCursor :: Raw.Cursor } + deriving (Eq, Typeable) + +-- | Get or set the currently active cursor. You can create new 'Cursor's with 'createCursor'. +-- +-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. +-- +-- See @@ and @@ for C documentation. +activeCursor :: StateVar Cursor +activeCursor = makeStateVar getCursor setCursor + where + getCursor :: MonadIO m => m Cursor + getCursor = liftIO . fmap Cursor $ + throwIfNull "SDL.Input.Mouse.getCursor" "SDL_getCursor" + Raw.getCursor + + setCursor :: MonadIO m => Cursor -> m () + setCursor = Raw.setCursor . unwrapCursor + +-- | Create a cursor using the specified bitmap data and mask (in MSB format). +-- +-- +createCursor :: MonadIO m + => V.Vector Bool -- ^ Whether this part of the cursor is black. Use 'False' for white and 'True' for black. + -> V.Vector Bool -- ^ Whether or not pixels are visible. Use 'True' for visible and 'False' for transparent. + -> V2 CInt -- ^ The width and height of the cursor. + -> Point V2 CInt -- ^ The X- and Y-axis location of the upper left corner of the cursor relative to the actual mouse position + -> m Cursor +createCursor dta msk (V2 w h) (P (V2 hx hy)) = + liftIO . fmap Cursor $ + throwIfNull "SDL.Input.Mouse.createCursor" "SDL_createCursor" $ + V.unsafeWith (V.map (bool 0 1) dta) $ \unsafeDta -> + V.unsafeWith (V.map (bool 0 1) msk) $ \unsafeMsk -> + Raw.createCursor unsafeDta unsafeMsk w h hx hy + +-- | Free a cursor created with 'createCursor' and 'createColorCusor'. +-- +-- See @@ for C documentation. +freeCursor :: MonadIO m => Cursor -> m () +freeCursor = Raw.freeCursor . unwrapCursor + +-- | Create a color cursor. +-- +-- See @@ for C documentation. +createColorCursor :: MonadIO m + => Surface + -> Point V2 CInt -- ^ The location of the cursor hot spot + -> m Cursor +createColorCursor (Surface surfPtr _) (P (V2 hx hy)) = + liftIO . fmap Cursor $ + throwIfNull "SDL.Input.Mouse.createColorCursor" "SDL_createColorCursor" $ + Raw.createColorCursor surfPtr hx hy diff --git a/src/SDL/Internal/Vect.hs b/src/SDL/Internal/Vect.hs new file mode 100644 --- /dev/null +++ b/src/SDL/Internal/Vect.hs @@ -0,0 +1,669 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} + +#ifndef MIN_VERSION_vector +#define MIN_VERSION_vector(x,y,z) 1 +#endif + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2012-2015 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : non-portable +---------------------------------------------------------------------------- + +module SDL.Internal.Vect + ( Point (..) + , V2 (..) + , V3 (..) + , V4 (..) + ) where + +import Control.Applicative +import Control.Monad (liftM) +import Control.Monad.Fix +import Control.Monad.Zip +import Data.Data +import Data.Foldable +import Data.Monoid +import Data.Traversable +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as M +import qualified Data.Vector.Unboxed.Base as U +import Foreign.Ptr (castPtr) +import Foreign.Storable (Storable (..)) +import GHC.Arr (Ix (..)) +import GHC.Generics (Generic, Generic1) +import Prelude +-- Explicit Prelude import suppresses warnings about redundant imports. +{-# ANN module "HLint: ignore Reduce duplication" #-} +{-# ANN module "HLint: ignore Use fmap" #-} + + +-- | A handy wrapper to help distinguish points from vectors at the +-- type level +newtype Point f a = P (f a) + deriving ( Eq, Ord, Show, Read, Monad, Functor, Applicative, Foldable + , Traversable, Fractional , Num, Ix, Storable, Generic, Generic1 + , Typeable, Data + ) + +data instance U.Vector (Point f a) = V_P !(U.Vector (f a)) +data instance U.MVector s (Point f a) = MV_P !(U.MVector s (f a)) +instance U.Unbox (f a) => U.Unbox (Point f a) + +instance U.Unbox (f a) => M.MVector U.MVector (Point f a) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + basicLength (MV_P v) = M.basicLength v + basicUnsafeSlice m n (MV_P v) = MV_P (M.basicUnsafeSlice m n v) + basicOverlaps (MV_P v) (MV_P u) = M.basicOverlaps v u + basicUnsafeNew n = MV_P `liftM` M.basicUnsafeNew n + basicUnsafeRead (MV_P v) i = P `liftM` M.basicUnsafeRead v i + basicUnsafeWrite (MV_P v) i (P x) = M.basicUnsafeWrite v i x +#if MIN_VERSION_vector(0,11,0) + basicInitialize (MV_P v) = M.basicInitialize v + {-# INLINE basicInitialize #-} +#endif + +instance U.Unbox (f a) => G.Vector U.Vector (Point f a) where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeFreeze (MV_P v) = V_P `liftM` G.basicUnsafeFreeze v + basicUnsafeThaw ( V_P v) = MV_P `liftM` G.basicUnsafeThaw v + basicLength ( V_P v) = G.basicLength v + basicUnsafeSlice m n (V_P v) = V_P (G.basicUnsafeSlice m n v) + basicUnsafeIndexM (V_P v) i = P `liftM` G.basicUnsafeIndexM v i + + +-- | A 2-dimensional vector +-- +-- >>> pure 1 :: V2 Int +-- V2 1 1 +-- +-- >>> V2 1 2 + V2 3 4 +-- V2 4 6 +-- +-- >>> V2 1 2 * V2 3 4 +-- V2 3 8 +-- +-- >>> sum (V2 1 2) +-- 3 +data V2 a = V2 !a !a + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Functor V2 where + fmap f (V2 a b) = V2 (f a) (f b) + {-# INLINE fmap #-} + a <$ _ = V2 a a + {-# INLINE (<$) #-} + +instance Foldable V2 where + foldMap f (V2 a b) = f a `mappend` f b + {-# INLINE foldMap #-} + +instance Traversable V2 where + traverse f (V2 a b) = V2 <$> f a <*> f b + {-# INLINE traverse #-} + +instance Applicative V2 where + pure a = V2 a a + {-# INLINE pure #-} + V2 a b <*> V2 d e = V2 (a d) (b e) + {-# INLINE (<*>) #-} + +instance Monad V2 where + return a = V2 a a + {-# INLINE return #-} + V2 a b >>= f = V2 a' b' where + V2 a' _ = f a + V2 _ b' = f b + {-# INLINE (>>=) #-} + +instance Num a => Num (V2 a) where + (+) = liftA2 (+) + {-# INLINE (+) #-} + (-) = liftA2 (-) + {-# INLINE (-) #-} + (*) = liftA2 (*) + {-# INLINE (*) #-} + negate = fmap negate + {-# INLINE negate #-} + abs = fmap abs + {-# INLINE abs #-} + signum = fmap signum + {-# INLINE signum #-} + fromInteger = pure . fromInteger + {-# INLINE fromInteger #-} + +instance Fractional a => Fractional (V2 a) where + recip = fmap recip + {-# INLINE recip #-} + (/) = liftA2 (/) + {-# INLINE (/) #-} + fromRational = pure . fromRational + {-# INLINE fromRational #-} + +instance Floating a => Floating (V2 a) where + pi = pure pi + {-# INLINE pi #-} + exp = fmap exp + {-# INLINE exp #-} + sqrt = fmap sqrt + {-# INLINE sqrt #-} + log = fmap log + {-# INLINE log #-} + (**) = liftA2 (**) + {-# INLINE (**) #-} + logBase = liftA2 logBase + {-# INLINE logBase #-} + sin = fmap sin + {-# INLINE sin #-} + tan = fmap tan + {-# INLINE tan #-} + cos = fmap cos + {-# INLINE cos #-} + asin = fmap asin + {-# INLINE asin #-} + atan = fmap atan + {-# INLINE atan #-} + acos = fmap acos + {-# INLINE acos #-} + sinh = fmap sinh + {-# INLINE sinh #-} + tanh = fmap tanh + {-# INLINE tanh #-} + cosh = fmap cosh + {-# INLINE cosh #-} + asinh = fmap asinh + {-# INLINE asinh #-} + atanh = fmap atanh + {-# INLINE atanh #-} + acosh = fmap acosh + {-# INLINE acosh #-} + +instance Storable a => Storable (V2 a) where + sizeOf _ = 2 * sizeOf (undefined::a) + {-# INLINE sizeOf #-} + alignment _ = alignment (undefined::a) + {-# INLINE alignment #-} + poke ptr (V2 x y) = poke ptr' x >> pokeElemOff ptr' 1 y + where ptr' = castPtr ptr + {-# INLINE poke #-} + peek ptr = V2 <$> peek ptr' <*> peekElemOff ptr' 1 + where ptr' = castPtr ptr + {-# INLINE peek #-} + +instance Ix a => Ix (V2 a) where + {-# SPECIALISE instance Ix (V2 Int) #-} + + range (V2 l1 l2,V2 u1 u2) = + [ V2 i1 i2 | i1 <- range (l1,u1), i2 <- range (l2,u2) ] + {-# INLINE range #-} + + unsafeIndex (V2 l1 l2,V2 u1 u2) (V2 i1 i2) = + unsafeIndex (l1,u1) i1 * unsafeRangeSize (l2,u2) + unsafeIndex (l2,u2) i2 + {-# INLINE unsafeIndex #-} + + inRange (V2 l1 l2,V2 u1 u2) (V2 i1 i2) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 + {-# INLINE inRange #-} + +data instance U.Vector (V2 a) = V_V2 {-# UNPACK #-} !Int !(U.Vector a) +data instance U.MVector s (V2 a) = MV_V2 {-# UNPACK #-} !Int !(U.MVector s a) +instance U.Unbox a => U.Unbox (V2 a) + +instance U.Unbox a => M.MVector U.MVector (V2 a) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + basicLength (MV_V2 n _) = n + basicUnsafeSlice m n (MV_V2 _ v) = MV_V2 n (M.basicUnsafeSlice (2*m) (2*n) v) + basicOverlaps (MV_V2 _ v) (MV_V2 _ u) = M.basicOverlaps v u + basicUnsafeNew n = liftM (MV_V2 n) (M.basicUnsafeNew (2*n)) + basicUnsafeRead (MV_V2 _ v) i = + do let o = 2*i + x <- M.basicUnsafeRead v o + y <- M.basicUnsafeRead v (o+1) + return (V2 x y) + basicUnsafeWrite (MV_V2 _ v) i (V2 x y) = + do let o = 2*i + M.basicUnsafeWrite v o x + M.basicUnsafeWrite v (o+1) y +#if MIN_VERSION_vector(0,11,0) + basicInitialize (MV_V2 _ v) = M.basicInitialize v + {-# INLINE basicInitialize #-} +#endif + +instance U.Unbox a => G.Vector U.Vector (V2 a) where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeFreeze (MV_V2 n v) = liftM ( V_V2 n) (G.basicUnsafeFreeze v) + basicUnsafeThaw ( V_V2 n v) = liftM (MV_V2 n) (G.basicUnsafeThaw v) + basicLength ( V_V2 n _) = n + basicUnsafeSlice m n (V_V2 _ v) = V_V2 n (G.basicUnsafeSlice (2*m) (2*n) v) + basicUnsafeIndexM (V_V2 _ v) i = + do let o = 2*i + x <- G.basicUnsafeIndexM v o + y <- G.basicUnsafeIndexM v (o+1) + return (V2 x y) + +instance MonadZip V2 where + mzipWith = liftA2 + +instance MonadFix V2 where + mfix f = V2 (let V2 a _ = f a in a) + (let V2 _ a = f a in a) + +instance Bounded a => Bounded (V2 a) where + minBound = pure minBound + {-# INLINE minBound #-} + maxBound = pure maxBound + {-# INLINE maxBound #-} + + +-- | A 3-dimensional vector +data V3 a = V3 !a !a !a + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Functor V3 where + fmap f (V3 a b c) = V3 (f a) (f b) (f c) + {-# INLINE fmap #-} + a <$ _ = V3 a a a + {-# INLINE (<$) #-} + +instance Foldable V3 where + foldMap f (V3 a b c) = f a `mappend` f b `mappend` f c + {-# INLINE foldMap #-} + +instance Traversable V3 where + traverse f (V3 a b c) = V3 <$> f a <*> f b <*> f c + {-# INLINE traverse #-} + +instance Applicative V3 where + pure a = V3 a a a + {-# INLINE pure #-} + V3 a b c <*> V3 d e f = V3 (a d) (b e) (c f) + {-# INLINE (<*>) #-} + +instance Monad V3 where + return a = V3 a a a + {-# INLINE return #-} + V3 a b c >>= f = V3 a' b' c' where + V3 a' _ _ = f a + V3 _ b' _ = f b + V3 _ _ c' = f c + {-# INLINE (>>=) #-} + +instance Num a => Num (V3 a) where + (+) = liftA2 (+) + {-# INLINE (+) #-} + (-) = liftA2 (-) + {-# INLINE (-) #-} + (*) = liftA2 (*) + {-# INLINE (*) #-} + negate = fmap negate + {-# INLINE negate #-} + abs = fmap abs + {-# INLINE abs #-} + signum = fmap signum + {-# INLINE signum #-} + fromInteger = pure . fromInteger + {-# INLINE fromInteger #-} + +instance Fractional a => Fractional (V3 a) where + recip = fmap recip + {-# INLINE recip #-} + (/) = liftA2 (/) + {-# INLINE (/) #-} + fromRational = pure . fromRational + {-# INLINE fromRational #-} + +instance Floating a => Floating (V3 a) where + pi = pure pi + {-# INLINE pi #-} + exp = fmap exp + {-# INLINE exp #-} + sqrt = fmap sqrt + {-# INLINE sqrt #-} + log = fmap log + {-# INLINE log #-} + (**) = liftA2 (**) + {-# INLINE (**) #-} + logBase = liftA2 logBase + {-# INLINE logBase #-} + sin = fmap sin + {-# INLINE sin #-} + tan = fmap tan + {-# INLINE tan #-} + cos = fmap cos + {-# INLINE cos #-} + asin = fmap asin + {-# INLINE asin #-} + atan = fmap atan + {-# INLINE atan #-} + acos = fmap acos + {-# INLINE acos #-} + sinh = fmap sinh + {-# INLINE sinh #-} + tanh = fmap tanh + {-# INLINE tanh #-} + cosh = fmap cosh + {-# INLINE cosh #-} + asinh = fmap asinh + {-# INLINE asinh #-} + atanh = fmap atanh + {-# INLINE atanh #-} + acosh = fmap acosh + {-# INLINE acosh #-} + +instance Storable a => Storable (V3 a) where + sizeOf _ = 3 * sizeOf (undefined::a) + {-# INLINE sizeOf #-} + alignment _ = alignment (undefined::a) + {-# INLINE alignment #-} + poke ptr (V3 x y z) = do poke ptr' x + pokeElemOff ptr' 1 y + pokeElemOff ptr' 2 z + where ptr' = castPtr ptr + {-# INLINE poke #-} + peek ptr = V3 <$> peek ptr' <*> peekElemOff ptr' 1 <*> peekElemOff ptr' 2 + where ptr' = castPtr ptr + {-# INLINE peek #-} + +instance Ix a => Ix (V3 a) where + {-# SPECIALISE instance Ix (V3 Int) #-} + + range (V3 l1 l2 l3,V3 u1 u2 u3) = + [V3 i1 i2 i3 | i1 <- range (l1,u1) + , i2 <- range (l2,u2) + , i3 <- range (l3,u3) + ] + {-# INLINE range #-} + + unsafeIndex (V3 l1 l2 l3,V3 u1 u2 u3) (V3 i1 i2 i3) = + unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( + unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * + unsafeIndex (l1,u1) i1) + {-# INLINE unsafeIndex #-} + + inRange (V3 l1 l2 l3,V3 u1 u2 u3) (V3 i1 i2 i3) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 + {-# INLINE inRange #-} + +data instance U.Vector (V3 a) = V_V3 {-# UNPACK #-} !Int !(U.Vector a) +data instance U.MVector s (V3 a) = MV_V3 {-# UNPACK #-} !Int !(U.MVector s a) +instance U.Unbox a => U.Unbox (V3 a) + +instance U.Unbox a => M.MVector U.MVector (V3 a) where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + basicLength (MV_V3 n _) = n + basicUnsafeSlice m n (MV_V3 _ v) = MV_V3 n (M.basicUnsafeSlice (3*m) (3*n) v) + basicOverlaps (MV_V3 _ v) (MV_V3 _ u) = M.basicOverlaps v u + basicUnsafeNew n = liftM (MV_V3 n) (M.basicUnsafeNew (3*n)) + basicUnsafeRead (MV_V3 _ v) i = + do let o = 3*i + x <- M.basicUnsafeRead v o + y <- M.basicUnsafeRead v (o+1) + z <- M.basicUnsafeRead v (o+2) + return (V3 x y z) + basicUnsafeWrite (MV_V3 _ v) i (V3 x y z) = + do let o = 3*i + M.basicUnsafeWrite v o x + M.basicUnsafeWrite v (o+1) y + M.basicUnsafeWrite v (o+2) z +#if MIN_VERSION_vector(0,11,0) + basicInitialize (MV_V3 _ v) = M.basicInitialize v + {-# INLINE basicInitialize #-} +#endif + +instance U.Unbox a => G.Vector U.Vector (V3 a) where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeFreeze (MV_V3 n v) = liftM ( V_V3 n) (G.basicUnsafeFreeze v) + basicUnsafeThaw ( V_V3 n v) = liftM (MV_V3 n) (G.basicUnsafeThaw v) + basicLength ( V_V3 n _) = n + basicUnsafeSlice m n (V_V3 _ v) = V_V3 n (G.basicUnsafeSlice (3*m) (3*n) v) + basicUnsafeIndexM (V_V3 _ v) i = + do let o = 3*i + x <- G.basicUnsafeIndexM v o + y <- G.basicUnsafeIndexM v (o+1) + z <- G.basicUnsafeIndexM v (o+2) + return (V3 x y z) + +instance MonadZip V3 where + mzipWith = liftA2 + +instance MonadFix V3 where + mfix f = V3 (let V3 a _ _ = f a in a) + (let V3 _ a _ = f a in a) + (let V3 _ _ a = f a in a) + +instance Bounded a => Bounded (V3 a) where + minBound = pure minBound + {-# INLINE minBound #-} + maxBound = pure maxBound + {-# INLINE maxBound #-} + + +-- | A 4-dimensional vector. +data V4 a = V4 !a !a !a !a + deriving (Eq, Ord, Show, Read, Data, Typeable, Generic, Generic1) + +instance Functor V4 where + fmap f (V4 a b c d) = V4 (f a) (f b) (f c) (f d) + {-# INLINE fmap #-} + a <$ _ = V4 a a a a + {-# INLINE (<$) #-} + +instance Foldable V4 where + foldMap f (V4 a b c d) = f a `mappend` f b `mappend` f c `mappend` f d + {-# INLINE foldMap #-} + +instance Traversable V4 where + traverse f (V4 a b c d) = V4 <$> f a <*> f b <*> f c <*> f d + {-# INLINE traverse #-} + +instance Applicative V4 where + pure a = V4 a a a a + {-# INLINE pure #-} + V4 a b c d <*> V4 e f g h = V4 (a e) (b f) (c g) (d h) + {-# INLINE (<*>) #-} + +instance Monad V4 where + return a = V4 a a a a + {-# INLINE return #-} + V4 a b c d >>= f = V4 a' b' c' d' where + V4 a' _ _ _ = f a + V4 _ b' _ _ = f b + V4 _ _ c' _ = f c + V4 _ _ _ d' = f d + {-# INLINE (>>=) #-} + +instance Num a => Num (V4 a) where + (+) = liftA2 (+) + {-# INLINE (+) #-} + (*) = liftA2 (*) + {-# INLINE (-) #-} + (-) = liftA2 (-) + {-# INLINE (*) #-} + negate = fmap negate + {-# INLINE negate #-} + abs = fmap abs + {-# INLINE abs #-} + signum = fmap signum + {-# INLINE signum #-} + fromInteger = pure . fromInteger + {-# INLINE fromInteger #-} + +instance Fractional a => Fractional (V4 a) where + recip = fmap recip + {-# INLINE recip #-} + (/) = liftA2 (/) + {-# INLINE (/) #-} + fromRational = pure . fromRational + {-# INLINE fromRational #-} + +instance Floating a => Floating (V4 a) where + pi = pure pi + {-# INLINE pi #-} + exp = fmap exp + {-# INLINE exp #-} + sqrt = fmap sqrt + {-# INLINE sqrt #-} + log = fmap log + {-# INLINE log #-} + (**) = liftA2 (**) + {-# INLINE (**) #-} + logBase = liftA2 logBase + {-# INLINE logBase #-} + sin = fmap sin + {-# INLINE sin #-} + tan = fmap tan + {-# INLINE tan #-} + cos = fmap cos + {-# INLINE cos #-} + asin = fmap asin + {-# INLINE asin #-} + atan = fmap atan + {-# INLINE atan #-} + acos = fmap acos + {-# INLINE acos #-} + sinh = fmap sinh + {-# INLINE sinh #-} + tanh = fmap tanh + {-# INLINE tanh #-} + cosh = fmap cosh + {-# INLINE cosh #-} + asinh = fmap asinh + {-# INLINE asinh #-} + atanh = fmap atanh + {-# INLINE atanh #-} + acosh = fmap acosh + {-# INLINE acosh #-} + +instance Storable a => Storable (V4 a) where + sizeOf _ = 4 * sizeOf (undefined::a) + {-# INLINE sizeOf #-} + alignment _ = alignment (undefined::a) + {-# INLINE alignment #-} + poke ptr (V4 x y z w) = do poke ptr' x + pokeElemOff ptr' 1 y + pokeElemOff ptr' 2 z + pokeElemOff ptr' 3 w + where ptr' = castPtr ptr + {-# INLINE poke #-} + peek ptr = V4 <$> peek ptr' <*> peekElemOff ptr' 1 + <*> peekElemOff ptr' 2 <*> peekElemOff ptr' 3 + where ptr' = castPtr ptr + {-# INLINE peek #-} + +instance Ix a => Ix (V4 a) where + {-# SPECIALISE instance Ix (V4 Int) #-} + + range (V4 l1 l2 l3 l4,V4 u1 u2 u3 u4) = + [V4 i1 i2 i3 i4 | i1 <- range (l1,u1) + , i2 <- range (l2,u2) + , i3 <- range (l3,u3) + , i4 <- range (l4,u4) + ] + {-# INLINE range #-} + + unsafeIndex (V4 l1 l2 l3 l4,V4 u1 u2 u3 u4) (V4 i1 i2 i3 i4) = + unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * ( + unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( + unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * + unsafeIndex (l1,u1) i1)) + {-# INLINE unsafeIndex #-} + + inRange (V4 l1 l2 l3 l4,V4 u1 u2 u3 u4) (V4 i1 i2 i3 i4) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 && inRange (l4,u4) i4 + {-# INLINE inRange #-} + +data instance U.Vector (V4 a) = V_V4 {-# UNPACK #-} !Int !(U.Vector a) +data instance U.MVector s (V4 a) = MV_V4 {-# UNPACK #-} !Int !(U.MVector s a) +instance U.Unbox a => U.Unbox (V4 a) + +instance U.Unbox a => M.MVector U.MVector (V4 a) where + basicLength (MV_V4 n _) = n + basicUnsafeSlice m n (MV_V4 _ v) = MV_V4 n (M.basicUnsafeSlice (4*m) (4*n) v) + basicOverlaps (MV_V4 _ v) (MV_V4 _ u) = M.basicOverlaps v u + basicUnsafeNew n = liftM (MV_V4 n) (M.basicUnsafeNew (4*n)) + basicUnsafeRead (MV_V4 _ v) i = + do let o = 4*i + x <- M.basicUnsafeRead v o + y <- M.basicUnsafeRead v (o+1) + z <- M.basicUnsafeRead v (o+2) + w <- M.basicUnsafeRead v (o+3) + return (V4 x y z w) + basicUnsafeWrite (MV_V4 _ v) i (V4 x y z w) = + do let o = 4*i + M.basicUnsafeWrite v o x + M.basicUnsafeWrite v (o+1) y + M.basicUnsafeWrite v (o+2) z + M.basicUnsafeWrite v (o+3) w +#if MIN_VERSION_vector(0,11,0) + basicInitialize (MV_V4 _ v) = M.basicInitialize v +#endif + +instance U.Unbox a => G.Vector U.Vector (V4 a) where + basicUnsafeFreeze (MV_V4 n v) = liftM ( V_V4 n) (G.basicUnsafeFreeze v) + basicUnsafeThaw ( V_V4 n v) = liftM (MV_V4 n) (G.basicUnsafeThaw v) + basicLength ( V_V4 n _) = n + basicUnsafeSlice m n (V_V4 _ v) = V_V4 n (G.basicUnsafeSlice (4*m) (4*n) v) + basicUnsafeIndexM (V_V4 _ v) i = + do let o = 4*i + x <- G.basicUnsafeIndexM v o + y <- G.basicUnsafeIndexM v (o+1) + z <- G.basicUnsafeIndexM v (o+2) + w <- G.basicUnsafeIndexM v (o+3) + return (V4 x y z w) + +instance MonadZip V4 where + mzipWith = liftA2 + +instance MonadFix V4 where + mfix f = V4 (let V4 a _ _ _ = f a in a) + (let V4 _ a _ _ = f a in a) + (let V4 _ _ a _ = f a in a) + (let V4 _ _ _ a = f a in a) + +instance Bounded a => Bounded (V4 a) where + minBound = pure minBound + {-# INLINE minBound #-} + maxBound = pure maxBound + {-# INLINE maxBound #-} diff --git a/src/SDL/Vect.hs b/src/SDL/Vect.hs new file mode 100644 --- /dev/null +++ b/src/SDL/Vect.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} + +-- | SDL's vector representation. +-- +-- By default, re-exports the "Linear" and "Linear.Affine" modules from the +-- 'linear' package. With the @no-linear@ Cabal flag, instead exports a +-- duplicate implementation of the 'V2', 'V3', 'V4' and 'Point' types from +-- "SDL.Internal.Vect", which provides as many instances as possible for those +-- types while avoiding any additional dependencies. +module SDL.Vect + ( module Vect + -- * Point + , Point (..) + -- * Vectors + , V2 (..) + , V3 (..) + , V4 (..) + ) where + +#if defined(nolinear) +import SDL.Internal.Vect as Vect +#else +import Linear as Vect +import Linear.Affine as Vect +#endif diff --git a/src/SDL/Video.hs b/src/SDL/Video.hs --- a/src/SDL/Video.hs +++ b/src/SDL/Video.hs @@ -1,581 +1,579 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -module SDL.Video - ( module SDL.Video.OpenGL - , module SDL.Video.Renderer - - -- * Window Management - , Window - , createWindow - , defaultWindow - , WindowConfig(..) - , WindowMode(..) - , WindowPosition(..) - , destroyWindow - - -- * Window Actions - , hideWindow - , raiseWindow - , showWindow - - -- * Window Attributes - , windowMinimumSize - , windowMaximumSize - , windowSize - , windowBordered - , windowBrightness - , windowGammaRamp - , windowGrab - , setWindowMode - , getWindowAbsolutePosition - , setWindowPosition - , windowTitle - , windowData - , getWindowConfig - , getWindowPixelFormat - , PixelFormat(..) - - -- * Renderer Management - , createRenderer - , destroyRenderer - - -- * Clipboard Handling - , getClipboardText - , hasClipboardText - , setClipboardText - - -- * Display - , getDisplays - , Display(..) - , DisplayMode(..) - , VideoDriver(..) - - -- * Screen Savers - -- | Screen savers should be disabled when the sudden enablement of the - -- monitor's power saving features would be inconvenient for when the user - -- hasn't provided any input for some period of time, such as during video - -- playback. - -- - -- Screen savers are disabled by default upon the initialization of the - -- video subsystem. - , disableScreenSaver - , enableScreenSaver - , isScreenSaverEnabled - - -- * Message Box - , showSimpleMessageBox - , MessageKind(..) - ) where - -import Prelude hiding (all, foldl, foldr, mapM_) - -import Data.StateVar -import Control.Applicative -import Control.Exception -import Control.Monad (forM, unless, void) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Bits -import Data.Data (Data) -import Data.Foldable -import Data.Maybe (isJust, fromMaybe) -import Data.Monoid (First(..)) -import Data.Text (Text) -import Data.Typeable -import Foreign hiding (void, throwIfNull, throwIfNeg, throwIfNeg_) -import Foreign.C -import GHC.Generics (Generic) -import Linear -import Linear.Affine (Point(P)) -import SDL.Exception -import SDL.Internal.Numbered -import SDL.Internal.Types -import SDL.Video.OpenGL -import SDL.Video.Renderer - -import qualified Data.ByteString as BS -import qualified Data.Text.Encoding as Text -import qualified Data.Vector.Storable as SV -import qualified SDL.Raw as Raw - --- | Create a window with the given title and configuration. --- --- Throws 'SDLException' on failure. -createWindow :: MonadIO m => Text -> WindowConfig -> m Window -createWindow title config = liftIO $ do - case windowOpenGL config of - Just glcfg -> setGLAttributes glcfg - Nothing -> return () - - BS.useAsCString (Text.encodeUtf8 title) $ \title' -> do - let create = Raw.createWindow title' - let create' (V2 w h) = case windowPosition config of - Centered -> let u = Raw.SDL_WINDOWPOS_CENTERED in create u u w h - Wherever -> let u = Raw.SDL_WINDOWPOS_UNDEFINED in create u u w h - Absolute (P (V2 x y)) -> create x y w h - create' (windowInitialSize config) flags >>= return . Window - where - flags = foldr (.|.) 0 - [ if windowBorder config then 0 else Raw.SDL_WINDOW_BORDERLESS - , if windowHighDPI config then Raw.SDL_WINDOW_ALLOW_HIGHDPI else 0 - , if windowInputGrabbed config then Raw.SDL_WINDOW_INPUT_GRABBED else 0 - , toNumber $ windowMode config - , if isJust $ windowOpenGL config then Raw.SDL_WINDOW_OPENGL else 0 - , if windowResizable config then Raw.SDL_WINDOW_RESIZABLE else 0 - ] - setGLAttributes (OpenGLConfig (V4 r g b a) d s p) = do - let (msk, v0, v1, flg) = case p of - Core Debug v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_CORE, v0', v1', Raw.SDL_GL_CONTEXT_DEBUG_FLAG) - Core Normal v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_CORE, v0', v1', 0) - Compatibility Debug v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_COMPATIBILITY, v0', v1', Raw.SDL_GL_CONTEXT_DEBUG_FLAG) - Compatibility Normal v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_COMPATIBILITY, v0', v1', 0) - ES Debug v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_ES, v0', v1', Raw.SDL_GL_CONTEXT_DEBUG_FLAG) - ES Normal v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_ES, v0', v1', 0) - mapM_ (throwIfNeg_ "SDL.Video.createWindow" "SDL_GL_SetAttribute" . uncurry Raw.glSetAttribute) $ - [ (Raw.SDL_GL_RED_SIZE, r) - , (Raw.SDL_GL_GREEN_SIZE, g) - , (Raw.SDL_GL_BLUE_SIZE, b) - , (Raw.SDL_GL_ALPHA_SIZE, a) - , (Raw.SDL_GL_DEPTH_SIZE, d) - , (Raw.SDL_GL_STENCIL_SIZE, s) - , (Raw.SDL_GL_CONTEXT_PROFILE_MASK, msk) - , (Raw.SDL_GL_CONTEXT_MAJOR_VERSION, v0) - , (Raw.SDL_GL_CONTEXT_MINOR_VERSION, v1) - , (Raw.SDL_GL_CONTEXT_FLAGS, flg) - ] - --- | Default configuration for windows. Use the record update syntax to --- override any of the defaults. --- --- @ --- 'defaultWindow' = 'WindowConfig' --- { 'windowBorder' = True --- , 'windowHighDPI' = False --- , 'windowInputGrabbed' = False --- , 'windowMode' = 'Windowed' --- , 'windowOpenGL' = Nothing --- , 'windowPosition' = 'Wherever' --- , 'windowResizable' = False --- , 'windowInitialSize' = V2 800 600 --- } --- @ -defaultWindow :: WindowConfig -defaultWindow = WindowConfig - { windowBorder = True - , windowHighDPI = False - , windowInputGrabbed = False - , windowMode = Windowed - , windowOpenGL = Nothing - , windowPosition = Wherever - , windowResizable = False - , windowInitialSize = V2 800 600 - } - -data WindowConfig = WindowConfig - { windowBorder :: Bool -- ^ Defaults to 'True'. - , windowHighDPI :: Bool -- ^ Defaults to 'False'. Can not be changed after window creation. - , windowInputGrabbed :: Bool -- ^ Defaults to 'False'. Whether the mouse shall be confined to the window. - , windowMode :: WindowMode -- ^ Defaults to 'Windowed'. - , windowOpenGL :: Maybe OpenGLConfig -- ^ Defaults to 'Nothing'. Can not be changed after window creation. - , windowPosition :: WindowPosition -- ^ Defaults to 'Wherever'. - , windowResizable :: Bool -- ^ Defaults to 'False'. Whether the window can be resized by the user. It is still possible to programatically change the size with 'setWindowSize'. - , windowInitialSize :: V2 CInt -- ^ Defaults to @(800, 600)@. - } deriving (Eq, Generic, Ord, Read, Show, Typeable) - -data WindowMode - = Fullscreen -- ^ Real fullscreen with a video mode change - | FullscreenDesktop -- ^ Fake fullscreen that takes the size of the desktop - | Maximized - | Minimized - | Windowed - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) - -instance ToNumber WindowMode Word32 where - toNumber Fullscreen = Raw.SDL_WINDOW_FULLSCREEN - toNumber FullscreenDesktop = Raw.SDL_WINDOW_FULLSCREEN_DESKTOP - toNumber Maximized = Raw.SDL_WINDOW_MAXIMIZED - toNumber Minimized = Raw.SDL_WINDOW_MINIMIZED - toNumber Windowed = 0 - -instance FromNumber WindowMode Word32 where - fromNumber n = fromMaybe Windowed . getFirst $ - foldMap First [ - sdlWindowFullscreen - , sdlWindowFullscreenDesktop - , sdlWindowMaximized - , sdlWindowMinimized - ] - where - maybeBit val msk = if n .&. msk > 0 then Just val else Nothing - sdlWindowFullscreen = maybeBit Fullscreen Raw.SDL_WINDOW_FULLSCREEN - sdlWindowFullscreenDesktop = maybeBit FullscreenDesktop Raw.SDL_WINDOW_FULLSCREEN_DESKTOP - sdlWindowMaximized = maybeBit Maximized Raw.SDL_WINDOW_MAXIMIZED - sdlWindowMinimized = maybeBit Minimized Raw.SDL_WINDOW_MINIMIZED - -data WindowPosition - = Centered - | Wherever -- ^ Let the window mananger decide where it's best to place the window. - | Absolute (Point V2 CInt) - deriving (Eq, Generic, Ord, Read, Show, Typeable) - --- | Destroy the given window. The 'Window' handler may not be used --- afterwards. -destroyWindow :: MonadIO m => Window -> m () -destroyWindow (Window w) = Raw.destroyWindow w - --- | Get or set if the window should have a border. --- --- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -windowBordered :: Window -> StateVar Bool -windowBordered (Window w) = makeStateVar getWindowBordered setWindowBordered - where - getWindowBordered = fmap ((== 0) . (.&. Raw.SDL_WINDOW_BORDERLESS)) (Raw.getWindowFlags w) - setWindowBordered = Raw.setWindowBordered w - --- | Get or set the window's brightness, where 0.0 is completely dark and 1.0 is normal brightness. --- --- Throws 'SDLException' if the hardware does not support gamma --- correction, or if the system has run out of memory. --- --- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -windowBrightness :: Window -> StateVar Float -windowBrightness (Window w) = makeStateVar getWindowBrightness setWindowBrightness - where - setWindowBrightness brightness = do - throwIfNot0_ "SDL.Video.setWindowBrightness" "SDL_SetWindowBrightness" $ - Raw.setWindowBrightness w $ realToFrac brightness - - getWindowBrightness = - return . realToFrac =<< Raw.getWindowBrightness w - --- | Get or set whether the mouse shall be confined to the window. --- --- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. -windowGrab :: Window -> StateVar Bool -windowGrab (Window w) = makeStateVar getWindowGrab setWindowGrab - where - setWindowGrab = Raw.setWindowGrab w - getWindowGrab = Raw.getWindowGrab w - --- | Change between window modes. --- --- Throws 'SDLException' on failure. -setWindowMode :: MonadIO m => Window -> WindowMode -> m () -setWindowMode (Window w) mode = - liftIO . throwIfNot0_ "SDL.Video.setWindowMode" "SDL_SetWindowFullscreen" $ - case mode of - Fullscreen -> Raw.setWindowFullscreen w Raw.SDL_WINDOW_FULLSCREEN - FullscreenDesktop -> Raw.setWindowFullscreen w Raw.SDL_WINDOW_FULLSCREEN_DESKTOP - Maximized -> Raw.setWindowFullscreen w 0 <* Raw.maximizeWindow w - Minimized -> Raw.minimizeWindow w >> return 0 - Windowed -> Raw.restoreWindow w >> return 0 - --- | Set the position of the window. -setWindowPosition :: MonadIO m => Window -> WindowPosition -> m () -setWindowPosition (Window w) pos = case pos of - Centered -> let u = Raw.SDL_WINDOWPOS_CENTERED in Raw.setWindowPosition w u u - Wherever -> let u = Raw.SDL_WINDOWPOS_UNDEFINED in Raw.setWindowPosition w u u - Absolute (P (V2 x y)) -> Raw.setWindowPosition w x y - --- | Get the position of the window. -getWindowAbsolutePosition :: MonadIO m => Window -> m (V2 CInt) -getWindowAbsolutePosition (Window w) = - liftIO $ - alloca $ \wPtr -> - alloca $ \hPtr -> do - Raw.getWindowPosition w wPtr hPtr - V2 <$> peek wPtr <*> peek hPtr - - --- | Get or set the size of a window's client area. Values beyond the maximum supported size are clamped. --- --- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. --- --- See @@ and @@ for C documentation. -windowSize :: Window -> StateVar (V2 CInt) -windowSize (Window win) = makeStateVar getWindowSize setWindowSize - where - setWindowSize (V2 w h) = Raw.setWindowSize win w h - - getWindowSize = - liftIO $ - alloca $ \wptr -> - alloca $ \hptr -> do - Raw.getWindowSize win wptr hptr - V2 <$> peek wptr <*> peek hptr - --- | Get or set the title of the window. If the window has no title, then an empty string is returned. --- --- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. --- --- See @@ and @@ for C documentation. -windowTitle :: Window -> StateVar Text -windowTitle (Window w) = makeStateVar getWindowTitle setWindowTitle - where - setWindowTitle title = - liftIO . BS.useAsCString (Text.encodeUtf8 title) $ - Raw.setWindowTitle w - - getWindowTitle = liftIO $ do - cstr <- Raw.getWindowTitle w - Text.decodeUtf8 <$> BS.packCString cstr - --- | Get or set the pointer to arbitrary user data associated with the given --- window and name. --- --- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. --- --- See @@ and @@ for C documentation. -windowData :: Window -> CString -> StateVar (Ptr ()) -windowData (Window w) key = makeStateVar getWindowData setWindowData - where - setWindowData = void . Raw.setWindowData w key - getWindowData = Raw.getWindowData w key - --- | Retrieve the configuration of the given window. --- --- Note that 'Nothing' will be returned instead of potential OpenGL parameters --- used during the creation of the window. -getWindowConfig :: MonadIO m => Window -> m WindowConfig -getWindowConfig (Window w) = do - wFlags <- Raw.getWindowFlags w - - wSize <- get (windowSize (Window w)) - wPos <- getWindowAbsolutePosition (Window w) - - return WindowConfig { - windowBorder = wFlags .&. Raw.SDL_WINDOW_BORDERLESS == 0 - , windowHighDPI = wFlags .&. Raw.SDL_WINDOW_ALLOW_HIGHDPI > 0 - , windowInputGrabbed = wFlags .&. Raw.SDL_WINDOW_INPUT_GRABBED > 0 - , windowMode = fromNumber wFlags - -- Should we store the openGL config that was used to create the window? - , windowOpenGL = Nothing - , windowPosition = Absolute (P wPos) - , windowResizable = wFlags .&. Raw.SDL_WINDOW_RESIZABLE > 0 - , windowInitialSize = wSize - } - --- | Get the pixel format that is used for the given window. -getWindowPixelFormat :: MonadIO m => Window -> m PixelFormat -getWindowPixelFormat (Window w) = return . fromNumber =<< Raw.getWindowPixelFormat w - --- | Get the text from the clipboard. --- --- Throws 'SDLException' on failure. -getClipboardText :: MonadIO m => m Text -getClipboardText = liftIO . mask_ $ do - cstr <- throwIfNull "SDL.Video.getClipboardText" "SDL_GetClipboardText" - Raw.getClipboardText - finally (Text.decodeUtf8 <$> BS.packCString cstr) (free cstr) - --- | Checks if the clipboard exists, and has some text in it. -hasClipboardText :: MonadIO m => m Bool -hasClipboardText = Raw.hasClipboardText - --- | Replace the contents of the clipboard with the given text. --- --- Throws 'SDLException' on failure. -setClipboardText :: MonadIO m => Text -> m () -setClipboardText str = liftIO $ do - throwIfNot0_ "SDL.Video.setClipboardText" "SDL_SetClipboardText" $ - BS.useAsCString (Text.encodeUtf8 str) Raw.setClipboardText - --- | Hide a window. --- --- See @@ for C documentation. -hideWindow :: MonadIO m => Window -> m () -hideWindow (Window w) = Raw.hideWindow w - --- | Raise the window above other windows and set the input focus. --- --- See @@ for C documentation. -raiseWindow :: MonadIO m => Window -> m () -raiseWindow (Window w) = Raw.raiseWindow w - --- | Prevent the screen from being blanked by a screen saver. If you disable the screensaver, it is automatically re-enabled when SDL quits. --- --- See @@ for C documentation. -disableScreenSaver :: MonadIO m => m () -disableScreenSaver = Raw.disableScreenSaver - --- | Allow the screen to be blanked by a screen saver. --- --- See @@ for C documentation. -enableScreenSaver :: MonadIO m => m () -enableScreenSaver = Raw.enableScreenSaver - --- | Check whether screen savers are enabled . --- --- See @@ for C documentation. -isScreenSaverEnabled :: MonadIO m => m Bool -isScreenSaverEnabled = Raw.isScreenSaverEnabled - --- | Show a window. --- --- See @@ for C documentation. -showWindow :: MonadIO m => Window -> m () -showWindow (Window w) = Raw.showWindow w - --- | Gets or sets the gamma ramp for the display that owns a given window. --- --- Note that the data for the gamma ramp - the 'V3' ('SV.Vector' 'Word16') - must contain 256 element arrays. This triple is a set of translation vectors for each of the 16-bit red, green and blue channels. --- --- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. --- --- Despite the name and signature, this method retrieves the gamma ramp of the entire display, not an individual window. A window is considered to be owned by the display that contains the window's center pixel. -windowGammaRamp :: Window -> StateVar (V3 (SV.Vector Word16)) -windowGammaRamp (Window w) = makeStateVar getWindowGammaRamp setWindowGammaRamp - where - getWindowGammaRamp = - allocaArray 256 $ \rPtr -> - allocaArray 256 $ \gPtr -> - allocaArray 256 $ \bPtr -> do - throwIfNeg_ "SDL.Video.getWindowGammaRamp" "SDL_GetWindowGammaRamp" - (Raw.getWindowGammaRamp w rPtr gPtr bPtr) - liftA3 V3 (fmap SV.fromList (peekArray 256 rPtr)) - (fmap SV.fromList (peekArray 256 gPtr)) - (fmap SV.fromList (peekArray 256 bPtr)) - - - setWindowGammaRamp (V3 r g b) = liftIO $ do - unless (all ((== 256) . SV.length) [r,g,b]) $ - error "setWindowGammaRamp requires 256 element in each colour channel" - - SV.unsafeWith r $ \rPtr -> - SV.unsafeWith b $ \bPtr -> - SV.unsafeWith g $ \gPtr -> - throwIfNeg_ "SDL.Video.setWindowGammaRamp" "SDL_SetWindowGammaRamp" $ - Raw.setWindowGammaRamp w rPtr gPtr bPtr - -data Display = Display { - displayName :: String - , displayBoundsPosition :: Point V2 CInt - -- ^ Position of the desktop area represented by the display, - -- with the primary display located at @(0, 0)@. - , displayBoundsSize :: V2 CInt - -- ^ Size of the desktop area represented by the display. - , displayModes :: [DisplayMode] - } - deriving (Eq, Generic, Ord, Read, Show, Typeable) - -data DisplayMode = DisplayMode { - displayModeFormat :: PixelFormat - , displayModeSize :: V2 CInt - , displayModeRefreshRate :: CInt -- ^ Display's refresh rate in hertz, or @0@ if unspecified. - } - deriving (Eq, Generic, Ord, Read, Show, Typeable) - -data VideoDriver = VideoDriver { - videoDriverName :: String - } - deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) - --- | Throws 'SDLException' on failure. -getDisplays :: MonadIO m => m [Display] -getDisplays = liftIO $ do - numDisplays <- throwIfNeg "SDL.Video.getDisplays" "SDL_GetNumVideoDisplays" - Raw.getNumVideoDisplays - - forM [0..numDisplays - 1] $ \displayId -> do - name <- throwIfNull "SDL.Video.getDisplays" "SDL_GetDisplayName" $ - Raw.getDisplayName displayId - - name' <- peekCString name - - Raw.Rect x y w h <- alloca $ \rect -> do - throwIfNot0_ "SDL.Video.getDisplays" "SDL_GetDisplayBounds" $ - Raw.getDisplayBounds displayId rect - peek rect - - numModes <- throwIfNeg "SDL.Video.getDisplays" "SDL_GetNumDisplayModes" $ - Raw.getNumDisplayModes displayId - - modes <- forM [0..numModes - 1] $ \modeId -> do - Raw.DisplayMode format w' h' refreshRate _ <- alloca $ \mode -> do - throwIfNot0_ "SDL.Video.getDisplays" "SDL_GetDisplayMode" $ - Raw.getDisplayMode displayId modeId mode - peek mode - - return $ DisplayMode { - displayModeFormat = fromNumber format - , displayModeSize = V2 w' h' - , displayModeRefreshRate = refreshRate - } - - return $ Display { - displayName = name' - , displayBoundsPosition = P (V2 x y) - , displayBoundsSize = V2 w h - , displayModes = modes - } - --- | Show a simple message box with the given title and a message. Consider --- writing your messages to @stderr@ too. --- --- Throws 'SDLException' if there are no available video targets. -showSimpleMessageBox :: MonadIO m => Maybe Window -> MessageKind -> Text -> Text -> m () -showSimpleMessageBox window kind title message = - liftIO . throwIfNot0_ "SDL.Video.showSimpleMessageBox" "SDL_ShowSimpleMessageBox" $ do - BS.useAsCString (Text.encodeUtf8 title) $ \title' -> - BS.useAsCString (Text.encodeUtf8 message) $ \message' -> - Raw.showSimpleMessageBox (toNumber kind) title' message' $ - windowId window - where - windowId (Just (Window w)) = w - windowId Nothing = nullPtr - -data MessageKind - = Error - | Warning - | Information - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) - -instance ToNumber MessageKind Word32 where - toNumber Error = Raw.SDL_MESSAGEBOX_ERROR - toNumber Warning = Raw.SDL_MESSAGEBOX_WARNING - toNumber Information = Raw.SDL_MESSAGEBOX_INFORMATION - --- | Get or set the maximum size of a window's client area. --- --- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. --- --- See @@ and @@ for C documentation. -windowMaximumSize :: Window -> StateVar (V2 CInt) -windowMaximumSize (Window win) = makeStateVar getWindowMaximumSize setWindowMaximumSize - where - setWindowMaximumSize (V2 w h) = Raw.setWindowMaximumSize win w h - - getWindowMaximumSize = - liftIO $ - alloca $ \wptr -> - alloca $ \hptr -> do - Raw.getWindowMaximumSize win wptr hptr - V2 <$> peek wptr <*> peek hptr - --- | Get or set the minimum size of a window's client area. --- --- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. --- --- See @@ and @@ for C documentation. -windowMinimumSize :: Window -> StateVar (V2 CInt) -windowMinimumSize (Window win) = makeStateVar getWindowMinimumSize setWindowMinimumSize - where - setWindowMinimumSize (V2 w h) = Raw.setWindowMinimumSize win w h - - getWindowMinimumSize = - liftIO $ - alloca $ \wptr -> - alloca $ \hptr -> do - Raw.getWindowMinimumSize win wptr hptr - V2 <$> peek wptr <*> peek hptr - -createRenderer :: MonadIO m => Window -> CInt -> RendererConfig -> m Renderer -createRenderer (Window w) driver config = - liftIO . fmap Renderer $ - throwIfNull "SDL.Video.createRenderer" "SDL_CreateRenderer" $ - Raw.createRenderer w driver (toNumber config) - -destroyRenderer :: MonadIO m => Renderer -> m () -destroyRenderer (Renderer r) = Raw.destroyRenderer r +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +module SDL.Video + ( module SDL.Video.OpenGL + , module SDL.Video.Renderer + + -- * Window Management + , Window + , createWindow + , defaultWindow + , WindowConfig(..) + , WindowMode(..) + , WindowPosition(..) + , destroyWindow + + -- * Window Actions + , hideWindow + , raiseWindow + , showWindow + + -- * Window Attributes + , windowMinimumSize + , windowMaximumSize + , windowSize + , windowBordered + , windowBrightness + , windowGammaRamp + , windowGrab + , setWindowMode + , getWindowAbsolutePosition + , setWindowPosition + , windowTitle + , windowData + , getWindowConfig + , getWindowPixelFormat + , PixelFormat(..) + + -- * Renderer Management + , createRenderer + , destroyRenderer + + -- * Clipboard Handling + , getClipboardText + , hasClipboardText + , setClipboardText + + -- * Display + , getDisplays + , Display(..) + , DisplayMode(..) + , VideoDriver(..) + + -- * Screen Savers + -- | Screen savers should be disabled when the sudden enablement of the + -- monitor's power saving features would be inconvenient for when the user + -- hasn't provided any input for some period of time, such as during video + -- playback. + -- + -- Screen savers are disabled by default upon the initialization of the + -- video subsystem. + , disableScreenSaver + , enableScreenSaver + , isScreenSaverEnabled + + -- * Message Box + , showSimpleMessageBox + , MessageKind(..) + ) where + +import Prelude hiding (all, foldl, foldr, mapM_) + +import Data.StateVar +import Control.Applicative +import Control.Exception +import Control.Monad (forM, unless, void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Bits +import Data.Data (Data) +import Data.Foldable +import Data.Maybe (isJust, fromMaybe) +import Data.Monoid (First(..)) +import Data.Text (Text) +import Data.Typeable +import Foreign hiding (void, throwIfNull, throwIfNeg, throwIfNeg_) +import Foreign.C +import GHC.Generics (Generic) +import SDL.Vect +import SDL.Exception +import SDL.Internal.Numbered +import SDL.Internal.Types +import SDL.Video.OpenGL +import SDL.Video.Renderer + +import qualified Data.ByteString as BS +import qualified Data.Text.Encoding as Text +import qualified Data.Vector.Storable as SV +import qualified SDL.Raw as Raw + +-- | Create a window with the given title and configuration. +-- +-- Throws 'SDLException' on failure. +createWindow :: MonadIO m => Text -> WindowConfig -> m Window +createWindow title config = liftIO $ do + case windowOpenGL config of + Just glcfg -> setGLAttributes glcfg + Nothing -> return () + + BS.useAsCString (Text.encodeUtf8 title) $ \title' -> do + let create = Raw.createWindow title' + let create' (V2 w h) = case windowPosition config of + Centered -> let u = Raw.SDL_WINDOWPOS_CENTERED in create u u w h + Wherever -> let u = Raw.SDL_WINDOWPOS_UNDEFINED in create u u w h + Absolute (P (V2 x y)) -> create x y w h + create' (windowInitialSize config) flags >>= return . Window + where + flags = foldr (.|.) 0 + [ if windowBorder config then 0 else Raw.SDL_WINDOW_BORDERLESS + , if windowHighDPI config then Raw.SDL_WINDOW_ALLOW_HIGHDPI else 0 + , if windowInputGrabbed config then Raw.SDL_WINDOW_INPUT_GRABBED else 0 + , toNumber $ windowMode config + , if isJust $ windowOpenGL config then Raw.SDL_WINDOW_OPENGL else 0 + , if windowResizable config then Raw.SDL_WINDOW_RESIZABLE else 0 + ] + setGLAttributes (OpenGLConfig (V4 r g b a) d s p) = do + let (msk, v0, v1, flg) = case p of + Core Debug v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_CORE, v0', v1', Raw.SDL_GL_CONTEXT_DEBUG_FLAG) + Core Normal v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_CORE, v0', v1', 0) + Compatibility Debug v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_COMPATIBILITY, v0', v1', Raw.SDL_GL_CONTEXT_DEBUG_FLAG) + Compatibility Normal v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_COMPATIBILITY, v0', v1', 0) + ES Debug v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_ES, v0', v1', Raw.SDL_GL_CONTEXT_DEBUG_FLAG) + ES Normal v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_ES, v0', v1', 0) + mapM_ (throwIfNeg_ "SDL.Video.createWindow" "SDL_GL_SetAttribute" . uncurry Raw.glSetAttribute) $ + [ (Raw.SDL_GL_RED_SIZE, r) + , (Raw.SDL_GL_GREEN_SIZE, g) + , (Raw.SDL_GL_BLUE_SIZE, b) + , (Raw.SDL_GL_ALPHA_SIZE, a) + , (Raw.SDL_GL_DEPTH_SIZE, d) + , (Raw.SDL_GL_STENCIL_SIZE, s) + , (Raw.SDL_GL_CONTEXT_PROFILE_MASK, msk) + , (Raw.SDL_GL_CONTEXT_MAJOR_VERSION, v0) + , (Raw.SDL_GL_CONTEXT_MINOR_VERSION, v1) + , (Raw.SDL_GL_CONTEXT_FLAGS, flg) + ] + +-- | Default configuration for windows. Use the record update syntax to +-- override any of the defaults. +-- +-- @ +-- 'defaultWindow' = 'WindowConfig' +-- { 'windowBorder' = True +-- , 'windowHighDPI' = False +-- , 'windowInputGrabbed' = False +-- , 'windowMode' = 'Windowed' +-- , 'windowOpenGL' = Nothing +-- , 'windowPosition' = 'Wherever' +-- , 'windowResizable' = False +-- , 'windowInitialSize' = V2 800 600 +-- } +-- @ +defaultWindow :: WindowConfig +defaultWindow = WindowConfig + { windowBorder = True + , windowHighDPI = False + , windowInputGrabbed = False + , windowMode = Windowed + , windowOpenGL = Nothing + , windowPosition = Wherever + , windowResizable = False + , windowInitialSize = V2 800 600 + } + +data WindowConfig = WindowConfig + { windowBorder :: Bool -- ^ Defaults to 'True'. + , windowHighDPI :: Bool -- ^ Defaults to 'False'. Can not be changed after window creation. + , windowInputGrabbed :: Bool -- ^ Defaults to 'False'. Whether the mouse shall be confined to the window. + , windowMode :: WindowMode -- ^ Defaults to 'Windowed'. + , windowOpenGL :: Maybe OpenGLConfig -- ^ Defaults to 'Nothing'. Can not be changed after window creation. + , windowPosition :: WindowPosition -- ^ Defaults to 'Wherever'. + , windowResizable :: Bool -- ^ Defaults to 'False'. Whether the window can be resized by the user. It is still possible to programatically change the size with 'setWindowSize'. + , windowInitialSize :: V2 CInt -- ^ Defaults to @(800, 600)@. + } deriving (Eq, Generic, Ord, Read, Show, Typeable) + +data WindowMode + = Fullscreen -- ^ Real fullscreen with a video mode change + | FullscreenDesktop -- ^ Fake fullscreen that takes the size of the desktop + | Maximized + | Minimized + | Windowed + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + +instance ToNumber WindowMode Word32 where + toNumber Fullscreen = Raw.SDL_WINDOW_FULLSCREEN + toNumber FullscreenDesktop = Raw.SDL_WINDOW_FULLSCREEN_DESKTOP + toNumber Maximized = Raw.SDL_WINDOW_MAXIMIZED + toNumber Minimized = Raw.SDL_WINDOW_MINIMIZED + toNumber Windowed = 0 + +instance FromNumber WindowMode Word32 where + fromNumber n = fromMaybe Windowed . getFirst $ + foldMap First [ + sdlWindowFullscreen + , sdlWindowFullscreenDesktop + , sdlWindowMaximized + , sdlWindowMinimized + ] + where + maybeBit val msk = if n .&. msk > 0 then Just val else Nothing + sdlWindowFullscreen = maybeBit Fullscreen Raw.SDL_WINDOW_FULLSCREEN + sdlWindowFullscreenDesktop = maybeBit FullscreenDesktop Raw.SDL_WINDOW_FULLSCREEN_DESKTOP + sdlWindowMaximized = maybeBit Maximized Raw.SDL_WINDOW_MAXIMIZED + sdlWindowMinimized = maybeBit Minimized Raw.SDL_WINDOW_MINIMIZED + +data WindowPosition + = Centered + | Wherever -- ^ Let the window mananger decide where it's best to place the window. + | Absolute (Point V2 CInt) + deriving (Eq, Generic, Ord, Read, Show, Typeable) + +-- | Destroy the given window. The 'Window' handler may not be used +-- afterwards. +destroyWindow :: MonadIO m => Window -> m () +destroyWindow (Window w) = Raw.destroyWindow w + +-- | Get or set if the window should have a border. +-- +-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. +windowBordered :: Window -> StateVar Bool +windowBordered (Window w) = makeStateVar getWindowBordered setWindowBordered + where + getWindowBordered = fmap ((== 0) . (.&. Raw.SDL_WINDOW_BORDERLESS)) (Raw.getWindowFlags w) + setWindowBordered = Raw.setWindowBordered w + +-- | Get or set the window's brightness, where 0.0 is completely dark and 1.0 is normal brightness. +-- +-- Throws 'SDLException' if the hardware does not support gamma +-- correction, or if the system has run out of memory. +-- +-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. +windowBrightness :: Window -> StateVar Float +windowBrightness (Window w) = makeStateVar getWindowBrightness setWindowBrightness + where + setWindowBrightness brightness = do + throwIfNot0_ "SDL.Video.setWindowBrightness" "SDL_SetWindowBrightness" $ + Raw.setWindowBrightness w $ realToFrac brightness + + getWindowBrightness = + return . realToFrac =<< Raw.getWindowBrightness w + +-- | Get or set whether the mouse shall be confined to the window. +-- +-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. +windowGrab :: Window -> StateVar Bool +windowGrab (Window w) = makeStateVar getWindowGrab setWindowGrab + where + setWindowGrab = Raw.setWindowGrab w + getWindowGrab = Raw.getWindowGrab w + +-- | Change between window modes. +-- +-- Throws 'SDLException' on failure. +setWindowMode :: MonadIO m => Window -> WindowMode -> m () +setWindowMode (Window w) mode = + liftIO . throwIfNot0_ "SDL.Video.setWindowMode" "SDL_SetWindowFullscreen" $ + case mode of + Fullscreen -> Raw.setWindowFullscreen w Raw.SDL_WINDOW_FULLSCREEN + FullscreenDesktop -> Raw.setWindowFullscreen w Raw.SDL_WINDOW_FULLSCREEN_DESKTOP + Maximized -> Raw.setWindowFullscreen w 0 <* Raw.maximizeWindow w + Minimized -> Raw.minimizeWindow w >> return 0 + Windowed -> Raw.restoreWindow w >> return 0 + +-- | Set the position of the window. +setWindowPosition :: MonadIO m => Window -> WindowPosition -> m () +setWindowPosition (Window w) pos = case pos of + Centered -> let u = Raw.SDL_WINDOWPOS_CENTERED in Raw.setWindowPosition w u u + Wherever -> let u = Raw.SDL_WINDOWPOS_UNDEFINED in Raw.setWindowPosition w u u + Absolute (P (V2 x y)) -> Raw.setWindowPosition w x y + +-- | Get the position of the window. +getWindowAbsolutePosition :: MonadIO m => Window -> m (V2 CInt) +getWindowAbsolutePosition (Window w) = + liftIO $ + alloca $ \wPtr -> + alloca $ \hPtr -> do + Raw.getWindowPosition w wPtr hPtr + V2 <$> peek wPtr <*> peek hPtr + +-- | Get or set the size of a window's client area. Values beyond the maximum supported size are clamped. +-- +-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. +-- +-- See @@ and @@ for C documentation. +windowSize :: Window -> StateVar (V2 CInt) +windowSize (Window win) = makeStateVar getWindowSize setWindowSize + where + setWindowSize (V2 w h) = Raw.setWindowSize win w h + + getWindowSize = + liftIO $ + alloca $ \wptr -> + alloca $ \hptr -> do + Raw.getWindowSize win wptr hptr + V2 <$> peek wptr <*> peek hptr + +-- | Get or set the title of the window. If the window has no title, then an empty string is returned. +-- +-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. +-- +-- See @@ and @@ for C documentation. +windowTitle :: Window -> StateVar Text +windowTitle (Window w) = makeStateVar getWindowTitle setWindowTitle + where + setWindowTitle title = + liftIO . BS.useAsCString (Text.encodeUtf8 title) $ + Raw.setWindowTitle w + + getWindowTitle = liftIO $ do + cstr <- Raw.getWindowTitle w + Text.decodeUtf8 <$> BS.packCString cstr + +-- | Get or set the pointer to arbitrary user data associated with the given +-- window and name. +-- +-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. +-- +-- See @@ and @@ for C documentation. +windowData :: Window -> CString -> StateVar (Ptr ()) +windowData (Window w) key = makeStateVar getWindowData setWindowData + where + setWindowData = void . Raw.setWindowData w key + getWindowData = Raw.getWindowData w key + +-- | Retrieve the configuration of the given window. +-- +-- Note that 'Nothing' will be returned instead of potential OpenGL parameters +-- used during the creation of the window. +getWindowConfig :: MonadIO m => Window -> m WindowConfig +getWindowConfig (Window w) = do + wFlags <- Raw.getWindowFlags w + + wSize <- get (windowSize (Window w)) + wPos <- getWindowAbsolutePosition (Window w) + + return WindowConfig { + windowBorder = wFlags .&. Raw.SDL_WINDOW_BORDERLESS == 0 + , windowHighDPI = wFlags .&. Raw.SDL_WINDOW_ALLOW_HIGHDPI > 0 + , windowInputGrabbed = wFlags .&. Raw.SDL_WINDOW_INPUT_GRABBED > 0 + , windowMode = fromNumber wFlags + -- Should we store the openGL config that was used to create the window? + , windowOpenGL = Nothing + , windowPosition = Absolute (P wPos) + , windowResizable = wFlags .&. Raw.SDL_WINDOW_RESIZABLE > 0 + , windowInitialSize = wSize + } + +-- | Get the pixel format that is used for the given window. +getWindowPixelFormat :: MonadIO m => Window -> m PixelFormat +getWindowPixelFormat (Window w) = return . fromNumber =<< Raw.getWindowPixelFormat w + +-- | Get the text from the clipboard. +-- +-- Throws 'SDLException' on failure. +getClipboardText :: MonadIO m => m Text +getClipboardText = liftIO . mask_ $ do + cstr <- throwIfNull "SDL.Video.getClipboardText" "SDL_GetClipboardText" + Raw.getClipboardText + finally (Text.decodeUtf8 <$> BS.packCString cstr) (free cstr) + +-- | Checks if the clipboard exists, and has some text in it. +hasClipboardText :: MonadIO m => m Bool +hasClipboardText = Raw.hasClipboardText + +-- | Replace the contents of the clipboard with the given text. +-- +-- Throws 'SDLException' on failure. +setClipboardText :: MonadIO m => Text -> m () +setClipboardText str = liftIO $ do + throwIfNot0_ "SDL.Video.setClipboardText" "SDL_SetClipboardText" $ + BS.useAsCString (Text.encodeUtf8 str) Raw.setClipboardText + +-- | Hide a window. +-- +-- See @@ for C documentation. +hideWindow :: MonadIO m => Window -> m () +hideWindow (Window w) = Raw.hideWindow w + +-- | Raise the window above other windows and set the input focus. +-- +-- See @@ for C documentation. +raiseWindow :: MonadIO m => Window -> m () +raiseWindow (Window w) = Raw.raiseWindow w + +-- | Prevent the screen from being blanked by a screen saver. If you disable the screensaver, it is automatically re-enabled when SDL quits. +-- +-- See @@ for C documentation. +disableScreenSaver :: MonadIO m => m () +disableScreenSaver = Raw.disableScreenSaver + +-- | Allow the screen to be blanked by a screen saver. +-- +-- See @@ for C documentation. +enableScreenSaver :: MonadIO m => m () +enableScreenSaver = Raw.enableScreenSaver + +-- | Check whether screen savers are enabled . +-- +-- See @@ for C documentation. +isScreenSaverEnabled :: MonadIO m => m Bool +isScreenSaverEnabled = Raw.isScreenSaverEnabled + +-- | Show a window. +-- +-- See @@ for C documentation. +showWindow :: MonadIO m => Window -> m () +showWindow (Window w) = Raw.showWindow w + +-- | Gets or sets the gamma ramp for the display that owns a given window. +-- +-- Note that the data for the gamma ramp - the 'V3' ('SV.Vector' 'Word16') - must contain 256 element arrays. This triple is a set of translation vectors for each of the 16-bit red, green and blue channels. +-- +-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. +-- +-- Despite the name and signature, this method retrieves the gamma ramp of the entire display, not an individual window. A window is considered to be owned by the display that contains the window's center pixel. +windowGammaRamp :: Window -> StateVar (V3 (SV.Vector Word16)) +windowGammaRamp (Window w) = makeStateVar getWindowGammaRamp setWindowGammaRamp + where + getWindowGammaRamp = + allocaArray 256 $ \rPtr -> + allocaArray 256 $ \gPtr -> + allocaArray 256 $ \bPtr -> do + throwIfNeg_ "SDL.Video.getWindowGammaRamp" "SDL_GetWindowGammaRamp" + (Raw.getWindowGammaRamp w rPtr gPtr bPtr) + liftA3 V3 (fmap SV.fromList (peekArray 256 rPtr)) + (fmap SV.fromList (peekArray 256 gPtr)) + (fmap SV.fromList (peekArray 256 bPtr)) + + + setWindowGammaRamp (V3 r g b) = liftIO $ do + unless (all ((== 256) . SV.length) [r,g,b]) $ + error "setWindowGammaRamp requires 256 element in each colour channel" + + SV.unsafeWith r $ \rPtr -> + SV.unsafeWith b $ \bPtr -> + SV.unsafeWith g $ \gPtr -> + throwIfNeg_ "SDL.Video.setWindowGammaRamp" "SDL_SetWindowGammaRamp" $ + Raw.setWindowGammaRamp w rPtr gPtr bPtr + +data Display = Display { + displayName :: String + , displayBoundsPosition :: Point V2 CInt + -- ^ Position of the desktop area represented by the display, + -- with the primary display located at @(0, 0)@. + , displayBoundsSize :: V2 CInt + -- ^ Size of the desktop area represented by the display. + , displayModes :: [DisplayMode] + } + deriving (Eq, Generic, Ord, Read, Show, Typeable) + +data DisplayMode = DisplayMode { + displayModeFormat :: PixelFormat + , displayModeSize :: V2 CInt + , displayModeRefreshRate :: CInt -- ^ Display's refresh rate in hertz, or @0@ if unspecified. + } + deriving (Eq, Generic, Ord, Read, Show, Typeable) + +data VideoDriver = VideoDriver { + videoDriverName :: String + } + deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) + +-- | Throws 'SDLException' on failure. +getDisplays :: MonadIO m => m [Display] +getDisplays = liftIO $ do + numDisplays <- throwIfNeg "SDL.Video.getDisplays" "SDL_GetNumVideoDisplays" + Raw.getNumVideoDisplays + + forM [0..numDisplays - 1] $ \displayId -> do + name <- throwIfNull "SDL.Video.getDisplays" "SDL_GetDisplayName" $ + Raw.getDisplayName displayId + + name' <- peekCString name + + Raw.Rect x y w h <- alloca $ \rect -> do + throwIfNot0_ "SDL.Video.getDisplays" "SDL_GetDisplayBounds" $ + Raw.getDisplayBounds displayId rect + peek rect + + numModes <- throwIfNeg "SDL.Video.getDisplays" "SDL_GetNumDisplayModes" $ + Raw.getNumDisplayModes displayId + + modes <- forM [0..numModes - 1] $ \modeId -> do + Raw.DisplayMode format w' h' refreshRate _ <- alloca $ \mode -> do + throwIfNot0_ "SDL.Video.getDisplays" "SDL_GetDisplayMode" $ + Raw.getDisplayMode displayId modeId mode + peek mode + + return $ DisplayMode { + displayModeFormat = fromNumber format + , displayModeSize = V2 w' h' + , displayModeRefreshRate = refreshRate + } + + return $ Display { + displayName = name' + , displayBoundsPosition = P (V2 x y) + , displayBoundsSize = V2 w h + , displayModes = modes + } + +-- | Show a simple message box with the given title and a message. Consider +-- writing your messages to @stderr@ too. +-- +-- Throws 'SDLException' if there are no available video targets. +showSimpleMessageBox :: MonadIO m => Maybe Window -> MessageKind -> Text -> Text -> m () +showSimpleMessageBox window kind title message = + liftIO . throwIfNot0_ "SDL.Video.showSimpleMessageBox" "SDL_ShowSimpleMessageBox" $ do + BS.useAsCString (Text.encodeUtf8 title) $ \title' -> + BS.useAsCString (Text.encodeUtf8 message) $ \message' -> + Raw.showSimpleMessageBox (toNumber kind) title' message' $ + windowId window + where + windowId (Just (Window w)) = w + windowId Nothing = nullPtr + +data MessageKind + = Error + | Warning + | Information + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + +instance ToNumber MessageKind Word32 where + toNumber Error = Raw.SDL_MESSAGEBOX_ERROR + toNumber Warning = Raw.SDL_MESSAGEBOX_WARNING + toNumber Information = Raw.SDL_MESSAGEBOX_INFORMATION + +-- | Get or set the maximum size of a window's client area. +-- +-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. +-- +-- See @@ and @@ for C documentation. +windowMaximumSize :: Window -> StateVar (V2 CInt) +windowMaximumSize (Window win) = makeStateVar getWindowMaximumSize setWindowMaximumSize + where + setWindowMaximumSize (V2 w h) = Raw.setWindowMaximumSize win w h + + getWindowMaximumSize = + liftIO $ + alloca $ \wptr -> + alloca $ \hptr -> do + Raw.getWindowMaximumSize win wptr hptr + V2 <$> peek wptr <*> peek hptr + +-- | Get or set the minimum size of a window's client area. +-- +-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. +-- +-- See @@ and @@ for C documentation. +windowMinimumSize :: Window -> StateVar (V2 CInt) +windowMinimumSize (Window win) = makeStateVar getWindowMinimumSize setWindowMinimumSize + where + setWindowMinimumSize (V2 w h) = Raw.setWindowMinimumSize win w h + + getWindowMinimumSize = + liftIO $ + alloca $ \wptr -> + alloca $ \hptr -> do + Raw.getWindowMinimumSize win wptr hptr + V2 <$> peek wptr <*> peek hptr + +createRenderer :: MonadIO m => Window -> CInt -> RendererConfig -> m Renderer +createRenderer (Window w) driver config = + liftIO . fmap Renderer $ + throwIfNull "SDL.Video.createRenderer" "SDL_CreateRenderer" $ + Raw.createRenderer w driver (toNumber config) + +destroyRenderer :: MonadIO m => Renderer -> m () +destroyRenderer (Renderer r) = Raw.destroyRenderer r diff --git a/src/SDL/Video/OpenGL.hs b/src/SDL/Video/OpenGL.hs --- a/src/SDL/Video/OpenGL.hs +++ b/src/SDL/Video/OpenGL.hs @@ -1,171 +1,185 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -module SDL.Video.OpenGL - ( -- * Creating and Configuring OpenGL Contexts - defaultOpenGL - , OpenGLConfig(..) - , GLContext - , glCreateContext - , Profile(..) - , Mode(..) - , glMakeCurrent - , glDeleteContext - - -- * Swapping - -- | The process of \"swapping\" means to move the back-buffer into the window contents itself. - , glSwapWindow - , SwapInterval(..) - , swapInterval - - -- * Function Loading - , Raw.glGetProcAddress - ) where - -import Control.Monad.IO.Class (MonadIO) -import Data.Data (Data) -import Data.StateVar -import Data.Typeable -import Foreign.C.Types -import GHC.Generics (Generic) -import Linear -import SDL.Exception -import SDL.Internal.Numbered -import SDL.Internal.Types -import qualified SDL.Raw as Raw - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - --- | A set of default options for 'OpenGLConfig' --- --- @ --- 'defaultOpenGL' = 'OpenGLConfig' --- { 'glColorPrecision' = V4 8 8 8 0 --- , 'glDepthPrecision' = 24 --- , 'glStencilPrecision' = 8 --- , 'glProfile' = 'Compatibility' 'Normal' 2 1 --- } --- @ -defaultOpenGL :: OpenGLConfig -defaultOpenGL = OpenGLConfig - { glColorPrecision = V4 8 8 8 0 - , glDepthPrecision = 24 - , glStencilPrecision = 8 - , glProfile = Compatibility Normal 2 1 - } - --- | Configuration used when creating an OpenGL rendering context. -data OpenGLConfig = OpenGLConfig - { glColorPrecision :: V4 CInt -- ^ Defaults to 'V4' @8 8 8 0@. - , glDepthPrecision :: CInt -- ^ Defaults to @24@. - , glStencilPrecision :: CInt -- ^ Defaults to @8@. - , glProfile :: Profile -- ^ Defaults to 'Compatibility' 'Normal' @2 1@. - } deriving (Eq, Generic, Ord, Read, Show, Typeable) - --- | The profile a driver should use when creating an OpenGL context. -data Profile - = Core Mode CInt CInt - -- ^ Use the OpenGL core profile, with a given major and minor version - | Compatibility Mode CInt CInt - -- ^ Use the compatibilty profile with a given major and minor version. The compatibility profile allows you to use deprecated functions such as immediate mode - | ES Mode CInt CInt - -- ^ Use an OpenGL profile for embedded systems - deriving (Eq, Generic, Ord, Read, Show, Typeable) - --- | The mode a driver should use when creating an OpenGL context. -data Mode - = Normal - -- ^ A normal profile with no special debugging support - | Debug - -- ^ Use a debug context, allowing the usage of extensions such as @GL_ARB_debug_output@ - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) - --- | A created OpenGL context. -newtype GLContext = GLContext Raw.GLContext - deriving (Eq, Typeable) - --- | Create a new OpenGL context and makes it the current context for the --- window. --- --- Throws 'SDLException' if the window wasn't configured with OpenGL --- support, or if context creation fails. --- --- See @@ for C documentation. -glCreateContext :: (Functor m, MonadIO m) => Window -> m GLContext -glCreateContext (Window w) = - GLContext <$> throwIfNull "SDL.Video.glCreateContext" "SDL_GL_CreateContext" - (Raw.glCreateContext w) - --- | Set up an OpenGL context for rendering into an OpenGL window. --- --- Throws 'SDLException' on failure. --- --- See @@ for C documentation. -glMakeCurrent :: (Functor m, MonadIO m) => Window -> GLContext -> m () -glMakeCurrent (Window w) (GLContext ctx) = - throwIfNeg_ "SDL.Video.OpenGL.glMakeCurrent" "SDL_GL_MakeCurrent" $ - Raw.glMakeCurrent w ctx - --- | Delete the given OpenGL context. --- --- You /must/ make sure that there are no pending commands in the OpenGL --- command queue, the driver may still be processing commands even if you have --- stopped issuing them! --- --- The @glFinish@ command will block until the command queue has been fully --- processed. You should call that function before deleting a context. --- --- See @@ for C documentation. -glDeleteContext :: MonadIO m => GLContext -> m () -glDeleteContext (GLContext ctx) = Raw.glDeleteContext ctx - --- | Replace the contents of the front buffer with the back buffer's. The --- contents of the back buffer are undefined, clear them with @glClear@ or --- equivalent before drawing to them again. --- --- See @@ for C documentation. -glSwapWindow :: MonadIO m => Window -> m () -glSwapWindow (Window w) = Raw.glSwapWindow w - --- | The swap interval for the current OpenGL context. -data SwapInterval - = ImmediateUpdates - -- ^ No vertical retrace synchronization - | SynchronizedUpdates - -- ^ The buffer swap is synchronized with the vertical retrace - | LateSwapTearing - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) - -instance ToNumber SwapInterval CInt where - toNumber ImmediateUpdates = 0 - toNumber SynchronizedUpdates = 1 - toNumber LateSwapTearing = -1 - -instance FromNumber SwapInterval CInt where - fromNumber n' = - case n' of - 0 -> ImmediateUpdates - 1 -> SynchronizedUpdates - -1 -> LateSwapTearing - _ -> - error ("Unknown SwapInterval: " ++ show n') - --- | Get or set the swap interval for the current OpenGL context. --- --- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. --- --- See @@ and @@ for C documentation. -swapInterval :: StateVar SwapInterval -swapInterval = makeStateVar glGetSwapInterval glSetSwapInterval - where - glGetSwapInterval = fmap fromNumber $ Raw.glGetSwapInterval - - glSetSwapInterval i = - throwIfNeg_ "SDL.Video.glSetSwapInterval" "SDL_GL_SetSwapInterval" $ - Raw.glSetSwapInterval (toNumber i) +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module SDL.Video.OpenGL + ( -- * Creating and Configuring OpenGL Contexts + defaultOpenGL + , OpenGLConfig(..) + , GLContext + , glCreateContext + , Profile(..) + , Mode(..) + , glMakeCurrent + , glDeleteContext + + -- * Querying for the drawable size without a Renderer + , glGetDrawableSize + + -- * Swapping + -- | The process of \"swapping\" means to move the back-buffer into the window contents itself. + , glSwapWindow + , SwapInterval(..) + , swapInterval + + -- * Function Loading + , Raw.glGetProcAddress + ) where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Data (Data) +import Data.StateVar +import Data.Typeable +import Foreign hiding (void, throwIfNull, throwIfNeg, throwIfNeg_) +import Foreign.C.Types +import GHC.Generics (Generic) +import SDL.Vect +import SDL.Exception +import SDL.Internal.Numbered +import SDL.Internal.Types +import qualified SDL.Raw as Raw + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +-- | A set of default options for 'OpenGLConfig' +-- +-- @ +-- 'defaultOpenGL' = 'OpenGLConfig' +-- { 'glColorPrecision' = V4 8 8 8 0 +-- , 'glDepthPrecision' = 24 +-- , 'glStencilPrecision' = 8 +-- , 'glProfile' = 'Compatibility' 'Normal' 2 1 +-- } +-- @ +defaultOpenGL :: OpenGLConfig +defaultOpenGL = OpenGLConfig + { glColorPrecision = V4 8 8 8 0 + , glDepthPrecision = 24 + , glStencilPrecision = 8 + , glProfile = Compatibility Normal 2 1 + } + +-- | Configuration used when creating an OpenGL rendering context. +data OpenGLConfig = OpenGLConfig + { glColorPrecision :: V4 CInt -- ^ Defaults to 'V4' @8 8 8 0@. + , glDepthPrecision :: CInt -- ^ Defaults to @24@. + , glStencilPrecision :: CInt -- ^ Defaults to @8@. + , glProfile :: Profile -- ^ Defaults to 'Compatibility' 'Normal' @2 1@. + } deriving (Eq, Generic, Ord, Read, Show, Typeable) + +-- | The profile a driver should use when creating an OpenGL context. +data Profile + = Core Mode CInt CInt + -- ^ Use the OpenGL core profile, with a given major and minor version + | Compatibility Mode CInt CInt + -- ^ Use the compatibilty profile with a given major and minor version. The compatibility profile allows you to use deprecated functions such as immediate mode + | ES Mode CInt CInt + -- ^ Use an OpenGL profile for embedded systems + deriving (Eq, Generic, Ord, Read, Show, Typeable) + +-- | The mode a driver should use when creating an OpenGL context. +data Mode + = Normal + -- ^ A normal profile with no special debugging support + | Debug + -- ^ Use a debug context, allowing the usage of extensions such as @GL_ARB_debug_output@ + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + +-- | A created OpenGL context. +newtype GLContext = GLContext Raw.GLContext + deriving (Eq, Typeable) + +-- | Create a new OpenGL context and makes it the current context for the +-- window. +-- +-- Throws 'SDLException' if the window wasn't configured with OpenGL +-- support, or if context creation fails. +-- +-- See @@ for C documentation. +glCreateContext :: (Functor m, MonadIO m) => Window -> m GLContext +glCreateContext (Window w) = + GLContext <$> throwIfNull "SDL.Video.glCreateContext" "SDL_GL_CreateContext" + (Raw.glCreateContext w) + +-- | Set up an OpenGL context for rendering into an OpenGL window. +-- +-- Throws 'SDLException' on failure. +-- +-- See @@ for C documentation. +glMakeCurrent :: (Functor m, MonadIO m) => Window -> GLContext -> m () +glMakeCurrent (Window w) (GLContext ctx) = + throwIfNeg_ "SDL.Video.OpenGL.glMakeCurrent" "SDL_GL_MakeCurrent" $ + Raw.glMakeCurrent w ctx + +-- | Delete the given OpenGL context. +-- +-- You /must/ make sure that there are no pending commands in the OpenGL +-- command queue, the driver may still be processing commands even if you have +-- stopped issuing them! +-- +-- The @glFinish@ command will block until the command queue has been fully +-- processed. You should call that function before deleting a context. +-- +-- See @@ for C documentation. +glDeleteContext :: MonadIO m => GLContext -> m () +glDeleteContext (GLContext ctx) = Raw.glDeleteContext ctx + +-- | Replace the contents of the front buffer with the back buffer's. The +-- contents of the back buffer are undefined, clear them with @glClear@ or +-- equivalent before drawing to them again. +-- +-- See @@ for C documentation. +glSwapWindow :: MonadIO m => Window -> m () +glSwapWindow (Window w) = Raw.glSwapWindow w + +-- | The swap interval for the current OpenGL context. +data SwapInterval + = ImmediateUpdates + -- ^ No vertical retrace synchronization + | SynchronizedUpdates + -- ^ The buffer swap is synchronized with the vertical retrace + | LateSwapTearing + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + +instance ToNumber SwapInterval CInt where + toNumber ImmediateUpdates = 0 + toNumber SynchronizedUpdates = 1 + toNumber LateSwapTearing = -1 + +instance FromNumber SwapInterval CInt where + fromNumber n' = + case n' of + 0 -> ImmediateUpdates + 1 -> SynchronizedUpdates + -1 -> LateSwapTearing + _ -> + error ("Unknown SwapInterval: " ++ show n') + +-- | Get or set the swap interval for the current OpenGL context. +-- +-- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. +-- +-- See @@ and @@ for C documentation. +swapInterval :: StateVar SwapInterval +swapInterval = makeStateVar glGetSwapInterval glSetSwapInterval + where + glGetSwapInterval = fmap fromNumber $ Raw.glGetSwapInterval + + glSetSwapInterval i = + throwIfNeg_ "SDL.Video.glSetSwapInterval" "SDL_GL_SetSwapInterval" $ + Raw.glSetSwapInterval (toNumber i) + +-- | Get the size of a window's underlying drawable area in pixels (for use +-- with glViewport). +glGetDrawableSize :: MonadIO m => Window -> m (V2 CInt) +glGetDrawableSize (Window w) = + liftIO $ + alloca $ \wptr -> + alloca $ \hptr -> do + Raw.glGetDrawableSize w wptr hptr + V2 <$> peek wptr <*> peek hptr 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 @@ -88,6 +88,7 @@ , createTexture , TextureAccess(..) , createTextureFromSurface + , updateTexture , destroyTexture , glBindTexture , glUnbindTexture @@ -124,18 +125,19 @@ import Data.Word import Foreign.C.String import Foreign.C.Types +import Foreign.ForeignPtr import Foreign.Marshal.Alloc import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.Storable import GHC.Generics (Generic) -import Linear -import Linear.Affine (Point(P)) import Prelude hiding (foldr) +import SDL.Vect import SDL.Exception import SDL.Internal.Numbered import SDL.Internal.Types import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BSI import qualified Data.Text.Encoding as Text import qualified Data.Vector.Storable as SV import qualified Data.Vector.Storable.Mutable as MSV @@ -206,6 +208,23 @@ glUnbindTexture (Texture t) = throwIfNeg_ "SDL.Video.Renderer.glUnindTexture" "SDL_GL_UnbindTexture" $ Raw.glUnbindTexture t + +-- | Updates texture rectangle with new pixel data. +-- +-- See @@ for C documentation. +updateTexture :: (Functor m, MonadIO m) + => Texture -- ^ The 'Texture' to be updated + -> Maybe (Rectangle CInt) -- ^ The area to update, Nothing for entire texture + -> BS.ByteString -- ^ The raw pixel data + -> CInt -- ^ The number of bytes in a row of pixel data, including padding between lines + -> m Texture +updateTexture tex@(Texture t) rect pixels pitch = do + liftIO $ throwIfNeg_ "SDL.Video.updateTexture" "SDL_UpdateTexture" $ + maybeWith with rect $ \rectPtr -> + let (pixelForeign, _, _) = BSI.toForeignPtr pixels + in withForeignPtr pixelForeign $ \pixelsPtr -> + Raw.updateTexture t (castPtr rectPtr) (castPtr pixelsPtr) pitch + return tex -- | Destroy the specified texture. --