├── .github └── workflows │ └── workflow.yml ├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── bench └── Space.hs ├── cabal.project ├── cbits └── sdlhelper.c ├── default.nix ├── examples ├── AudioExample.hs ├── EventWatch.hs ├── OpenGLExample.hs ├── RenderGeometry.hs ├── UserEvents.hs ├── lazyfoo │ ├── Lesson01.hs │ ├── Lesson02.hs │ ├── Lesson03.hs │ ├── Lesson04.hs │ ├── Lesson05.hs │ ├── Lesson07.hs │ ├── Lesson08.hs │ ├── Lesson09.hs │ ├── Lesson10.hs │ ├── Lesson11.hs │ ├── Lesson12.hs │ ├── Lesson13.hs │ ├── Lesson14.hs │ ├── Lesson15.hs │ ├── Lesson17.hs │ ├── Lesson18.hs │ ├── Lesson19.hs │ ├── Lesson20.hs │ ├── Lesson43.hs │ ├── animation.bmp │ ├── arrow.bmp │ ├── background.bmp │ ├── button.bmp │ ├── colors.bmp │ ├── dots.bmp │ ├── down.bmp │ ├── fadein.bmp │ ├── fadeout.bmp │ ├── foo.bmp │ ├── hello_world.bmp │ ├── left.bmp │ ├── press.bmp │ ├── right.bmp │ ├── rumble.bmp │ ├── stretch.bmp │ ├── texture.bmp │ ├── up.bmp │ ├── viewport.bmp │ └── x.bmp └── twinklebear │ ├── Lesson01.hs │ ├── Lesson02.hs │ ├── Lesson04.hs │ ├── Lesson04a.hs │ ├── Lesson05.hs │ ├── background.bmp │ ├── event-driven.bmp │ ├── hello.bmp │ ├── ladybeetle.bmp │ ├── smiley.bmp │ └── spritesheet.bmp ├── include └── sdlhelper.h ├── scripts ├── find_missing_symbols.sh └── update-haddocks ├── sdl2.cabal ├── shell.nix └── src ├── Data └── Bitmask.hs ├── SDL.hs └── SDL ├── Audio.hs ├── Event.hs ├── Exception.hs ├── Filesystem.hs ├── Haptic.hs ├── Hint.hs ├── Init.hs ├── Input.hs ├── Input ├── GameController.hs ├── Joystick.hs ├── Keyboard.hs ├── Keyboard │ └── Codes.hs └── Mouse.hs ├── Internal ├── Exception.hs ├── Numbered.hs ├── Types.hs └── Vect.hs ├── Power.hs ├── Raw.hs ├── Raw ├── Audio.hs ├── Basic.hs ├── Enum.hsc ├── Error.hs ├── Event.hs ├── Filesystem.hs ├── Haptic.hs ├── Platform.hs ├── Power.hs ├── Thread.hs ├── Timer.hs ├── Types.hsc └── Video.hs ├── Time.hs ├── Vect.hs ├── Video.hs └── Video ├── OpenGL.hs ├── Renderer.hs └── Vulkan.hs /.github/workflows/workflow.yml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | 3 | name: build 4 | 5 | jobs: 6 | build: # TODO: split by OS 7 | strategy: 8 | fail-fast: false 9 | max-parallel: 3 10 | matrix: 11 | ghc: ['8.8', '8.10', '9.0', '9.2'] 12 | os: [ubuntu-latest, macOS-latest, windows-latest] 13 | # exclude: 14 | # # GHC 8.8+ only works with cabal v3+ 15 | # - ghc: 8.8.4 16 | # cabal: 2.4.1.0 17 | runs-on: ${{ matrix.os }} 18 | name: ${{ matrix.os }} ghc-${{ matrix.ghc }} 19 | steps: 20 | - uses: actions/checkout@v2 21 | 22 | - uses: haskell/actions/setup@v1 23 | with: 24 | ghc-version: ${{ matrix.ghc }} 25 | cabal-version: ${{ matrix.cabal }} 26 | 27 | - if: matrix.os == 'ubuntu-latest' 28 | run: sudo apt update; sudo apt install -y libsdl2-dev 29 | 30 | - if: matrix.os == 'macOS-latest' 31 | run: brew install pkg-config SDL2 32 | 33 | - run: cabal build --only-dependencies -j2 34 | 35 | - if: matrix.os != 'windows-latest' 36 | run: cabal build 37 | 38 | - if: matrix.os == 'windows-latest' 39 | uses: msys2/setup-msys2@v2 40 | with: 41 | path-type: inherit 42 | update: true 43 | install: >- 44 | mingw-w64-x86_64-pkg-config 45 | mingw-w64-x86_64-SDL2 46 | - if: matrix.os == 'windows-latest' 47 | shell: msys2 {0} 48 | run: cabal build 49 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | .stack-work/ 5 | .sosrc 6 | *.sw[a-z] 7 | dist/ 8 | *.hi 9 | *.o 10 | *.hi 11 | *.chi 12 | *.chs.h 13 | *.dyn_o 14 | *.dyn_hi 15 | .hpc 16 | .hsenv 17 | .cabal-sandbox/ 18 | cabal.sandbox.config 19 | *.prof 20 | *.aux 21 | *.hp 22 | *.eventlog 23 | .stack-work/ 24 | cabal.project.local 25 | stack.yaml 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013-2017 Gabríel Arthúr Pétursson 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Gabríel Arthúr Pétursson nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This package provides Haskell bindings for the SDL2 library. 2 | 3 | # What is SDL2? 4 | 5 | SDL (Simple DirectMedia Layer) is a library for cross-platform development of interactive applications. 6 | SDL provides routines for managing windows, rendering graphics, processing sound, collecting input data, and much more. 7 | 8 | The Haskell sdl2 library provides both a high- and low-level API to interface with SDL. 9 | 10 | You may also want to check out: 11 | 12 | - [sdl2-image](https://hackage.haskell.org/package/sdl2-image) - For handling different image formats such as `jpg` and `png`. 13 | - [sdl2-mixer](https://hackage.haskell.org/package/sdl2-mixer) - For playing audio. 14 | - [sdl2-gfx](https://hackage.haskell.org/package/sdl2-gfx) - For drawing graphics primitives such as circles and polygons. 15 | - [sdl2-ttf](https://hackage.haskell.org/package/sdl2-ttf) - For handling true type fonts. 16 | 17 | 18 | # Building 19 | 20 | [![Build Status](https://travis-ci.org/haskell-game/sdl2.svg?branch=master)](https://travis-ci.org/haskell-game/sdl2) 21 | 22 | If you don't have SDL 2.0.6 or higher on your system via your 23 | package manager, you can install it from the 24 | [official SDL site](https://www.libsdl.org/download-2.0.php). 25 | 26 | On Ubuntu you can install from source with a simple 27 | 28 | ./configure && make -j4 && sudo make install 29 | 30 | On OSX you can install SDL with [homebrew](http://brew.sh/). pkg-config is also recommended. 31 | 32 | brew install sdl2 pkg-config 33 | 34 | On Windows you can install SDL with `pacman` under [MSYS2](https://msys2.github.io/) (or use [stack's embedded MSYS2](https://www.reddit.com/r/haskellgamedev/comments/4jpthu/windows_sdl2_is_now_almost_painless_via_stack/)). 35 | 36 | pacman -S mingw-w64-x86_64-pkg-config mingw-w64-x86_64-SDL2 37 | 38 | > Note: If you want to use console output, you should add this in your cabal configuration: 39 | > ``` 40 | > executable your-app 41 | > if os(windows) 42 | > ghc-options: -optl-mconsole 43 | > ``` 44 | 45 | ## Build errors 46 | 47 | If you are getting build errors like `‘SDL_Vertex’ undeclared` then your installed libsdl2 version is missing some recent additions. 48 | 49 | You have two options to mitigate this: 50 | 1. Flip a package flag named `recent-ish` in your **project** configuration file. 51 | * `cabal.project.local`: 52 | ```yaml 53 | package sdl2 54 | flags: -recent-ish 55 | ``` 56 | * `stack.yaml`: 57 | ```yaml 58 | flags: 59 | sdl2: 60 | recent-ish: false 61 | ``` 62 | 2. Build SDL2 from source and use `extra-include-dirs` / `extra-lib-dirs` options, while disabling the pkgconfig-provided dependency: 63 | * `cabal.project.local`: 64 | ```yaml 65 | extra-include-dirs: /path/to/sdl2/include 66 | extra-lib-dirs: /path/to/sdl2/lib 67 | package sdl2 68 | flags: -pkgconfig 69 | ``` 70 | * `stack.yaml`: 71 | ```yaml 72 | extra-include-dirs: 73 | - /path/to/sdl2/include 74 | extra-lib-dirs: 75 | - /path/to/sdl2/lib 76 | flags: 77 | sdl2: 78 | pkgconfig: false 79 | ``` 80 | 81 | The flag enables some features from SDL2 past 2.0.8 and assumes a host system has at least version 2.0.20 installed. 82 | If you have libsdl2 version older than that, but need some features past 2.0.8, you'd have to use the `extra-*-dirs` way. 83 | 84 | # Get Started 85 | 86 | Take a look at the [getting started guide](https://hackage.haskell.org/package/sdl2/docs/SDL.html). 87 | 88 | # Contributing 89 | 90 | We need your help! The SDL API is fairly large, and the more hands we have, the 91 | quicker we can reach full coverage and release this to Hackage. There are a few 92 | ways you can help: 93 | 94 | 1. Browse https://wiki.libsdl.org/SDL2/CategoryAPI and find functions that aren't 95 | exposed in the high-level bindings. 96 | 97 | 2. The above can be somewhat laborious - an easier way to find out what's 98 | missing is to write code. 99 | 100 | * https://www.willusher.io/pages/sdl2/ is a collection of tutorials for C++. 101 | * https://lazyfoo.net/tutorials/SDL/index.php is another collection of C++ 102 | tutorials. 103 | 104 | Both of these would be useful if they were translated to Haskell, and we'd be 105 | happy to store this code in this repository. 106 | 107 | 3. Documentation is welcome, but may not be the best use of your time as we are 108 | currently in a period of rapid development as we find the most productive 109 | API. 110 | 111 | # Development 112 | 113 | ## Using `cabal repl` 114 | 115 | You can use `cabal repl` as a development tool, but you'll need to configure the project in a slightly non-standard way first: 116 | 117 | ``` 118 | cabal configure --ghc-option=-fPIC 119 | ``` 120 | 121 | You only need to do this once (unless you reconfigure). From this point, `cabal repl` should Just Work. 122 | 123 | If you get an `Invalid window` error, try the `-fno-ghci-sandbox` option. For example, in `ghci`: 124 | 125 | ``` 126 | :set -fno-ghci-sandbox 127 | ``` 128 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | package sdl2 4 | ghc-options: -Wall -Wcompat 5 | -------------------------------------------------------------------------------- /cbits/sdlhelper.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "sdlhelper.h" 4 | 5 | int SDLHelper_GetEventBufferSize() { return 64; } 6 | SDL_Event *SDLHelper_GetEventBuffer() { 7 | static SDL_Event *buffer = NULL; 8 | if(buffer == NULL) { 9 | /* leak an inconsequental amount of memory */ 10 | buffer = calloc(SDLHelper_GetEventBufferSize(), sizeof(SDL_Event)); 11 | } 12 | return buffer; 13 | } 14 | 15 | void SDLHelper_JoystickGetDeviceGUID (int device_index, SDL_JoystickGUID *guid) 16 | { 17 | SDL_JoystickGUID t = SDL_JoystickGetDeviceGUID (device_index); 18 | memcpy (guid, &t, sizeof (*guid)); 19 | } 20 | 21 | void SDLHelper_JoystickGetGUID (SDL_Joystick *joystick, SDL_JoystickGUID *guid) 22 | { 23 | SDL_JoystickGUID t = SDL_JoystickGetGUID (joystick); 24 | memcpy (guid, &t, sizeof (*guid)); 25 | } 26 | 27 | void SDLHelper_JoystickGetGUIDFromString (const char *pchGUID, SDL_JoystickGUID *guid) 28 | { 29 | SDL_JoystickGUID t = SDL_JoystickGetGUIDFromString (pchGUID); 30 | memcpy (guid, &t, sizeof (*guid)); 31 | } 32 | 33 | void SDLHelper_JoystickGetGUIDString (const SDL_JoystickGUID *guid, char *gszGUID, int cbGUID) 34 | { 35 | SDL_JoystickGetGUIDString (*guid, gszGUID, cbGUID); 36 | } 37 | 38 | void SDLHelper_GameControllerGetBindForAxis (SDL_GameController *gamecontroller, SDL_GameControllerAxis axis, SDL_GameControllerButtonBind *bind) 39 | { 40 | SDL_GameControllerButtonBind t = SDL_GameControllerGetBindForAxis (gamecontroller, axis); 41 | memcpy (bind, &t, sizeof (*bind)); 42 | } 43 | 44 | void SDLHelper_GameControllerGetBindForButton (SDL_GameController *gamecontroller, SDL_GameControllerButton button, SDL_GameControllerButtonBind *bind) 45 | { 46 | SDL_GameControllerButtonBind t = SDL_GameControllerGetBindForButton (gamecontroller, button); 47 | memcpy (bind, &t, sizeof (*bind)); 48 | } 49 | 50 | char *SDLHelper_GameControllerMappingForGUID (const SDL_JoystickGUID *guid) 51 | { 52 | return SDL_GameControllerMappingForGUID (*guid); 53 | } 54 | 55 | void SDLHelper_LogMessage (int category, SDL_LogPriority priority, const char *str) 56 | { 57 | SDL_LogMessage (category, priority, "%s", str); 58 | } 59 | 60 | int SDLHelper_RWclose (SDL_RWops *ctx) 61 | { 62 | return SDL_RWclose (ctx); 63 | } 64 | 65 | size_t SDLHelper_RWread (SDL_RWops *ctx, void *ptr, size_t size, size_t maxnum) 66 | { 67 | return SDL_RWread (ctx, ptr, size, maxnum); 68 | } 69 | 70 | Sint64 SDLHelper_RWseek (SDL_RWops *ctx, Sint64 offset, int whence) 71 | { 72 | return SDL_RWseek (ctx, offset, whence); 73 | } 74 | 75 | Sint64 SDLHelper_RWtell (SDL_RWops *ctx) 76 | { 77 | return SDL_RWtell (ctx); 78 | } 79 | 80 | size_t SDLHelper_RWwrite (SDL_RWops *ctx, const void *ptr, size_t size, size_t num) 81 | { 82 | return SDL_RWwrite (ctx, ptr, size, num); 83 | } 84 | 85 | int SDLHelper_SetError (const char *str) 86 | { 87 | return SDL_SetError ("%s", str); 88 | } 89 | 90 | int SDLHelper_RenderFillRectEx(SDL_Renderer* renderer, int x, int y, int w, int h) 91 | { 92 | SDL_Rect rect; 93 | rect.x=x; 94 | rect.y=y; 95 | rect.w=w; 96 | rect.h=h; 97 | return SDL_RenderFillRect(renderer,&rect); 98 | } 99 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, bytestring, lens, linear, SDL2, StateVar, stdenv, text 2 | , transformers, vector 3 | }: 4 | mkDerivation { 5 | pname = "sdl2"; 6 | version = "2.0.0"; 7 | src = ./.; 8 | isLibrary = true; 9 | isExecutable = true; 10 | libraryHaskellDepends = [ 11 | base bytestring lens linear StateVar text transformers vector 12 | ]; 13 | description = "Both high- and low-level bindings to the SDL library (version 2.0.6)."; 14 | license = stdenv.lib.licenses.bsd3; 15 | librarySystemDepends = [ SDL2 ]; 16 | libraryPkgconfigDepends = [ SDL2 ]; 17 | } 18 | -------------------------------------------------------------------------------- /examples/AudioExample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | module AudioExample where 4 | 5 | import Data.IORef 6 | import Control.Monad 7 | import Control.Concurrent 8 | import Data.Int (Int16, Int32) 9 | import SDL 10 | import qualified Data.Vector.Storable.Mutable as V 11 | 12 | sinSamples :: [Int16] 13 | sinSamples = 14 | map (\n -> 15 | let t = fromIntegral n / 48000 :: Double 16 | freq = 440 17 | in round (fromIntegral (maxBound `div` 2 :: Int16) * sin (2 * pi * freq * t))) 18 | [0 :: Int32 ..] 19 | 20 | audioCB :: IORef [Int16] -> AudioFormat sampleType -> V.IOVector sampleType -> IO () 21 | audioCB samples format buffer = 22 | case format of 23 | Signed16BitLEAudio -> 24 | do samples' <- readIORef samples 25 | let n = V.length buffer 26 | zipWithM_ (V.write buffer) 27 | [0 ..] 28 | (take n samples') 29 | writeIORef samples 30 | (drop n samples') 31 | _ -> error "Unsupported audio format" 32 | 33 | main :: IO () 34 | main = 35 | do initializeAll 36 | samples <- newIORef sinSamples 37 | (device,_) <- 38 | openAudioDevice 39 | OpenDeviceSpec {SDL.openDeviceFreq = 40 | Mandate 48000 41 | ,SDL.openDeviceFormat = 42 | Mandate Signed16BitNativeAudio 43 | ,SDL.openDeviceChannels = 44 | Mandate Mono 45 | ,SDL.openDeviceSamples = 4096 * 2 46 | ,SDL.openDeviceCallback = audioCB samples 47 | ,SDL.openDeviceUsage = ForPlayback 48 | ,SDL.openDeviceName = Nothing} 49 | setAudioDevicePlaybackState device Play 50 | forever (threadDelay maxBound) 51 | -------------------------------------------------------------------------------- /examples/EventWatch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | {-| 4 | 5 | The following example shows how setting a watch for the WindowSizeChangedEvent 6 | allows us to handle the events as they are generated. Handling them in the 7 | event loop, on the other hand, only allows us to see a final, coalesced, event. 8 | 9 | To demonstrate this, run the program, resize the window with your mouse, 10 | and check your console output. 11 | 12 | -} 13 | module EventWatch where 14 | 15 | import SDL 16 | 17 | import Control.Monad (void) 18 | 19 | main :: IO () 20 | main = do 21 | initializeAll 22 | window <- createWindow "resize" WindowConfig { 23 | windowBorder = True 24 | , windowHighDPI = False 25 | , windowInputGrabbed = False 26 | , windowMode = Windowed 27 | , windowGraphicsContext = NoGraphicsContext 28 | , windowPosition = Wherever 29 | , windowResizable = True 30 | , windowInitialSize = V2 800 600 31 | , windowVisible = True 32 | } 33 | _renderer <- createRenderer window (-1) defaultRenderer 34 | void . addEventWatch $ \ev -> 35 | case eventPayload ev of 36 | WindowSizeChangedEvent sizeChangeData -> 37 | putStrLn $ "eventWatch windowSizeChanged: " ++ show sizeChangeData 38 | _ -> return () 39 | appLoop 40 | 41 | appLoop :: IO () 42 | appLoop = waitEvent >>= go 43 | where 44 | go :: Event -> IO () 45 | go ev = 46 | case eventPayload ev of 47 | WindowSizeChangedEvent sizeChangeData -> do 48 | putStrLn $ "waitEvent windowSizeChanged: " ++ show sizeChangeData 49 | waitEvent >>= go 50 | KeyboardEvent keyboardEvent 51 | | keyboardEventKeyMotion keyboardEvent == Pressed && 52 | keysymKeycode (keyboardEventKeysym keyboardEvent) == KeycodeQ 53 | -> return () 54 | KeyboardEvent keyboardEvent 55 | | keyboardEventKeyMotion keyboardEvent == Pressed 56 | -> print (keyboardEventKeysym keyboardEvent) >> waitEvent >>= go 57 | MouseMotionEvent mouseMotionEvent 58 | -> print mouseMotionEvent >> waitEvent >>= go 59 | MouseButtonEvent mouseButtonEvent 60 | -> print mouseButtonEvent >> waitEvent >>= go 61 | MouseWheelEvent mouseWheelEvent 62 | -> print mouseWheelEvent >> waitEvent >>= go 63 | QuitEvent 64 | -> return () 65 | _ -> waitEvent >>= go 66 | -------------------------------------------------------------------------------- /examples/OpenGLExample.hs: -------------------------------------------------------------------------------- 1 | --port of https://github.com/bergey/haskell-OpenGL-examples 2 | 3 | {-# LANGUAGE CPP #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | module OpenGLExample where 6 | 7 | import Control.Monad 8 | import Foreign.C.Types 9 | import SDL.Vect 10 | import qualified Data.ByteString as BS 11 | import qualified Data.Vector.Storable as V 12 | import System.Exit (exitFailure) 13 | import System.IO 14 | 15 | import SDL (($=)) 16 | import qualified SDL 17 | import qualified Graphics.Rendering.OpenGL as GL 18 | 19 | screenWidth, screenHeight :: CInt 20 | (screenWidth, screenHeight) = (640, 480) 21 | 22 | main :: IO () 23 | main = do 24 | SDL.initialize [SDL.InitVideo] 25 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 26 | do renderQuality <- SDL.get SDL.HintRenderScaleQuality 27 | when (renderQuality /= SDL.ScaleLinear) $ 28 | putStrLn "Warning: Linear texture filtering not enabled!" 29 | 30 | window <- 31 | SDL.createWindow 32 | "SDL / OpenGL Example" 33 | SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight, 34 | SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL} 35 | SDL.showWindow window 36 | 37 | _ <- SDL.glCreateContext window 38 | (prog, attrib) <- initResources 39 | 40 | let loop = do 41 | events <- SDL.pollEvents 42 | let quit = elem SDL.QuitEvent $ map SDL.eventPayload events 43 | 44 | GL.clear [GL.ColorBuffer] 45 | draw prog attrib 46 | SDL.glSwapWindow window 47 | 48 | unless quit loop 49 | 50 | loop 51 | 52 | SDL.destroyWindow window 53 | SDL.quit 54 | 55 | initResources :: IO (GL.Program, GL.AttribLocation) 56 | initResources = do 57 | -- compile vertex shader 58 | vs <- GL.createShader GL.VertexShader 59 | GL.shaderSourceBS vs $= vsSource 60 | GL.compileShader vs 61 | vsOK <- GL.get $ GL.compileStatus vs 62 | unless vsOK $ do 63 | hPutStrLn stderr "Error in vertex shader\n" 64 | exitFailure 65 | 66 | -- Do it again for the fragment shader 67 | fs <- GL.createShader GL.FragmentShader 68 | GL.shaderSourceBS fs $= fsSource 69 | GL.compileShader fs 70 | fsOK <- GL.get $ GL.compileStatus fs 71 | unless fsOK $ do 72 | hPutStrLn stderr "Error in fragment shader\n" 73 | exitFailure 74 | 75 | program <- GL.createProgram 76 | GL.attachShader program vs 77 | GL.attachShader program fs 78 | GL.attribLocation program "coord2d" $= GL.AttribLocation 0 79 | GL.linkProgram program 80 | linkOK <- GL.get $ GL.linkStatus program 81 | GL.validateProgram program 82 | status <- GL.get $ GL.validateStatus program 83 | unless (linkOK && status) $ do 84 | hPutStrLn stderr "GL.linkProgram error" 85 | plog <- GL.get $ GL.programInfoLog program 86 | putStrLn plog 87 | exitFailure 88 | GL.currentProgram $= Just program 89 | 90 | return (program, GL.AttribLocation 0) 91 | 92 | draw :: GL.Program -> GL.AttribLocation -> IO () 93 | draw program attrib = do 94 | GL.clearColor $= GL.Color4 1 1 1 1 95 | GL.clear [GL.ColorBuffer] 96 | GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral screenWidth) (fromIntegral screenHeight)) 97 | 98 | GL.currentProgram $= Just program 99 | GL.vertexAttribArray attrib $= GL.Enabled 100 | V.unsafeWith vertices $ \ptr -> 101 | GL.vertexAttribPointer attrib $= 102 | (GL.ToFloat, GL.VertexArrayDescriptor 2 GL.Float 0 ptr) 103 | GL.drawArrays GL.Triangles 0 3 -- 3 is the number of vertices 104 | GL.vertexAttribArray attrib $= GL.Disabled 105 | 106 | vsSource, fsSource :: BS.ByteString 107 | vsSource = BS.intercalate "\n" 108 | [ 109 | "attribute vec2 coord2d; " 110 | , "" 111 | , "void main(void) { " 112 | , " gl_Position = vec4(coord2d, 0.0, 1.0); " 113 | , "}" 114 | ] 115 | 116 | fsSource = BS.intercalate "\n" 117 | [ 118 | "" 119 | , "#version 120" 120 | , "void main(void) {" 121 | , "gl_FragColor = vec4((gl_FragCoord.x/640), (gl_FragCoord.y/480), 0, 1);" 122 | , "}" 123 | ] 124 | 125 | vertices :: V.Vector Float 126 | vertices = V.fromList [ 0.0, 0.8 127 | , -0.8, -0.8 128 | , 0.8, -0.8 129 | ] 130 | -------------------------------------------------------------------------------- /examples/RenderGeometry.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module RenderGeometry where 4 | 5 | import Control.Monad 6 | import Data.Word (Word8) 7 | import Foreign (castPtr, plusPtr, sizeOf) 8 | import Foreign.C.Types 9 | import SDL.Vect 10 | import qualified Data.Vector.Storable as V 11 | 12 | import SDL (($=)) 13 | import qualified SDL 14 | import SDL.Raw.Types (FPoint(..), Color(..)) 15 | 16 | screenWidth, screenHeight :: CInt 17 | (screenWidth, screenHeight) = (640, 480) 18 | 19 | main :: IO () 20 | main = do 21 | SDL.initialize [SDL.InitVideo] 22 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 23 | do renderQuality <- SDL.get SDL.HintRenderScaleQuality 24 | when (renderQuality /= SDL.ScaleLinear) $ 25 | putStrLn "Warning: Linear texture filtering not enabled!" 26 | 27 | window <- 28 | SDL.createWindow 29 | "SDL / RenderGeometry Example" 30 | SDL.defaultWindow 31 | { SDL.windowInitialSize = V2 screenWidth screenHeight 32 | , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL 33 | } 34 | SDL.showWindow window 35 | 36 | renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer 37 | 38 | let 39 | tl = fromIntegral screenWidth * 0.1 40 | tt = fromIntegral screenHeight * 0.1 41 | tr = fromIntegral screenWidth * 0.9 42 | tb = fromIntegral screenHeight * 0.9 43 | 44 | triVertices = V.fromList 45 | [ SDL.Vertex 46 | (FPoint tl tb) 47 | (Color 0xFF 0 0 255) 48 | (FPoint 0 0) 49 | , SDL.Vertex 50 | (FPoint tr tb) 51 | (Color 0 0xFF 0 255) 52 | (FPoint 0 1) 53 | , SDL.Vertex 54 | (FPoint (tl/2 + tr/2) tt) 55 | (Color 0 0 0xFF 255) 56 | (FPoint 1 1) 57 | ] 58 | 59 | let 60 | l = fromIntegral screenWidth * 0.2 61 | t = fromIntegral screenHeight * 0.2 62 | r = fromIntegral screenWidth * 0.8 63 | b = fromIntegral screenHeight * 0.8 64 | 65 | quadVertices = V.fromList 66 | [ SDL.Vertex 67 | (FPoint l b) 68 | (Color 0xFF 0 0xFF 127) 69 | (FPoint 0 0) 70 | , SDL.Vertex 71 | (FPoint r b) 72 | (Color 0xFF 0 0xFF 127) 73 | (FPoint 1 0) 74 | , SDL.Vertex 75 | (FPoint r t) 76 | (Color 0xFF 0xFF 0 127) 77 | (FPoint 1 1) 78 | , SDL.Vertex 79 | (FPoint l t) 80 | (Color 0 0 0 127) 81 | (FPoint 0 1) 82 | ] 83 | quadIndices = V.fromList 84 | [ 0, 1, 3 85 | , 2, 3, 1 86 | ] 87 | stride = fromIntegral $ sizeOf (undefined :: SDL.Vertex) 88 | 89 | let loop = do 90 | events <- SDL.pollEvents 91 | let quit = elem SDL.QuitEvent $ map SDL.eventPayload events 92 | 93 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 94 | SDL.clear renderer 95 | 96 | SDL.renderGeometry 97 | renderer 98 | Nothing 99 | triVertices 100 | mempty 101 | 102 | SDL.rendererDrawBlendMode renderer $= SDL.BlendAlphaBlend 103 | V.unsafeWith quadVertices $ \ptr -> 104 | SDL.renderGeometryRaw 105 | renderer 106 | Nothing 107 | (castPtr ptr) 108 | stride 109 | (castPtr ptr `plusPtr` sizeOf (undefined :: FPoint)) 110 | stride 111 | (castPtr ptr `plusPtr` sizeOf (undefined :: FPoint) `plusPtr` sizeOf (undefined :: Color)) 112 | stride 113 | (fromIntegral $ V.length quadVertices) 114 | (quadIndices :: V.Vector Word8) 115 | 116 | SDL.present renderer 117 | 118 | unless quit loop 119 | 120 | loop 121 | 122 | SDL.destroyWindow window 123 | SDL.quit 124 | -------------------------------------------------------------------------------- /examples/UserEvents.hs: -------------------------------------------------------------------------------- 1 | module UserEvents where 2 | 3 | import Control.Concurrent (myThreadId) 4 | import Control.Monad (void) 5 | import Data.Maybe (Maybe(Nothing)) 6 | import Data.Word (Word32) 7 | import qualified Data.Text as Text 8 | import Foreign.Ptr (nullPtr) 9 | import SDL 10 | 11 | -- | A timer event with timestamp 12 | data TimerEvent = TimerEvent Word32 13 | 14 | timerEvent :: IO TimerEvent 15 | timerEvent = do 16 | t <- show <$> ticks 17 | tid <- show <$> myThreadId 18 | putStrLn $ "Created timer event at " ++ t ++ " ticks. Threadid: " ++ tid 19 | return $ TimerEvent 0 20 | 21 | main :: IO () 22 | main = do 23 | initializeAll 24 | let toTimerEvent _ = return . Just . TimerEvent 25 | fromTimerEvent = const $ return emptyRegisteredEvent 26 | registeredEvent <- registerEvent toTimerEvent fromTimerEvent 27 | case registeredEvent of 28 | Nothing -> putStrLn "Fatal error: unable to register timer events." 29 | Just registeredTimerEvent -> do 30 | void . addTimer 1000 $ mkTimerCb registeredTimerEvent 31 | putStrLn "press q at any time to quit" 32 | appLoop registeredTimerEvent 33 | 34 | mkTimerCb :: RegisteredEventType TimerEvent -> TimerCallback 35 | mkTimerCb (RegisteredEventType pushTimerEvent _) interval = do 36 | pushResult <- pushTimerEvent =<< timerEvent 37 | case pushResult of 38 | EventPushSuccess -> return () 39 | EventPushFiltered -> putStrLn "event push was filtered: this is impossible" 40 | EventPushFailure e -> putStrLn $ "Couldn't push event: " ++ Text.unpack e 41 | return $ Reschedule interval 42 | 43 | appLoop :: RegisteredEventType TimerEvent -> IO () 44 | appLoop (RegisteredEventType _pushTimerEvent getTimerEvent) = waitEvent >>= go 45 | where 46 | go :: Event -> IO () 47 | go ev = 48 | case eventPayload ev of 49 | -- Press Q to quit 50 | KeyboardEvent keyboardEvent 51 | | keyboardEventKeyMotion keyboardEvent == Pressed && 52 | keysymKeycode (keyboardEventKeysym keyboardEvent) == KeycodeQ 53 | -> return () 54 | UserEvent _ -> do 55 | maybeTimerEvent <- getTimerEvent ev 56 | case maybeTimerEvent of 57 | Just (TimerEvent ts) -> do 58 | t <- show <$> ticks 59 | tid <- show <$> myThreadId 60 | putStrLn $ "Got timer event from queue at " ++ t ++ " ticks." 61 | putStrLn $ "Timestamp: " ++ show ts 62 | putStrLn $ "Threadid: " ++ tid 63 | Nothing -> return () 64 | waitEvent >>= go 65 | _ -> waitEvent >>= go 66 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson01.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Lazyfoo.Lesson01 (main) where 3 | 4 | import Control.Concurrent (threadDelay) 5 | import Foreign.C.Types 6 | import SDL.Vect 7 | import qualified SDL 8 | 9 | screenWidth, screenHeight :: CInt 10 | (screenWidth, screenHeight) = (640, 480) 11 | 12 | main :: IO () 13 | main = do 14 | SDL.initialize [SDL.InitVideo] 15 | 16 | window <- SDL.createWindow "SDL Tutorial" SDL.defaultWindow { SDL.windowInitialSize = V2 screenWidth screenHeight } 17 | SDL.showWindow window 18 | 19 | screenSurface <- SDL.getWindowSurface window 20 | let white = V4 maxBound maxBound maxBound maxBound 21 | SDL.surfaceFillRect screenSurface Nothing white 22 | SDL.updateWindowSurface window 23 | 24 | threadDelay 2000000 25 | 26 | SDL.destroyWindow window 27 | SDL.quit 28 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson02.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Lazyfoo.Lesson02 (main) where 3 | 4 | import Control.Concurrent (threadDelay) 5 | import Control.Monad (void) 6 | import Foreign.C.Types 7 | import SDL.Vect 8 | import qualified SDL 9 | 10 | import Paths_sdl2 (getDataFileName) 11 | 12 | screenWidth, screenHeight :: CInt 13 | (screenWidth, screenHeight) = (640, 480) 14 | 15 | main :: IO () 16 | main = do 17 | SDL.initialize [SDL.InitVideo] 18 | window <- SDL.createWindow "SDL Tutorial" SDL.defaultWindow { SDL.windowInitialSize = V2 screenWidth screenHeight } 19 | SDL.showWindow window 20 | screenSurface <- SDL.getWindowSurface window 21 | 22 | helloWorld <- getDataFileName "examples/lazyfoo/hello_world.bmp" >>= SDL.loadBMP 23 | 24 | void $ SDL.surfaceBlit helloWorld Nothing screenSurface Nothing 25 | SDL.updateWindowSurface window 26 | 27 | threadDelay 2000000 28 | 29 | SDL.destroyWindow window 30 | SDL.freeSurface helloWorld 31 | SDL.quit 32 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson03.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Lazyfoo.Lesson03 (main) where 5 | 6 | import Control.Monad 7 | import Foreign.C.Types 8 | import SDL.Vect 9 | import qualified SDL 10 | 11 | import Paths_sdl2 (getDataFileName) 12 | 13 | screenWidth, screenHeight :: CInt 14 | (screenWidth, screenHeight) = (640, 480) 15 | 16 | main :: IO () 17 | main = do 18 | SDL.initialize [SDL.InitVideo] 19 | window <- SDL.createWindow "SDL Tutorial" SDL.defaultWindow { SDL.windowInitialSize = V2 screenWidth screenHeight } 20 | SDL.showWindow window 21 | screenSurface <- SDL.getWindowSurface window 22 | 23 | xOut <- getDataFileName "examples/lazyfoo/x.bmp" >>= SDL.loadBMP 24 | 25 | let 26 | loop = do 27 | events <- SDL.pollEvents 28 | let quit = elem SDL.QuitEvent $ map SDL.eventPayload events 29 | 30 | void $ SDL.surfaceBlit xOut Nothing screenSurface Nothing 31 | SDL.updateWindowSurface window 32 | 33 | unless quit loop 34 | 35 | loop 36 | 37 | SDL.freeSurface xOut 38 | SDL.destroyWindow window 39 | SDL.quit 40 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson04.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | module Lazyfoo.Lesson04 (main) where 6 | 7 | import Prelude hiding (any, mapM_) 8 | import Control.Monad hiding (mapM_) 9 | import Data.Foldable hiding (elem) 10 | import Data.Maybe 11 | import Data.Monoid 12 | import Foreign.C.Types 13 | import SDL.Vect 14 | import qualified SDL 15 | 16 | import Paths_sdl2 (getDataFileName) 17 | 18 | #if !MIN_VERSION_base(4,8,0) 19 | import Control.Applicative 20 | #endif 21 | 22 | screenWidth, screenHeight :: CInt 23 | (screenWidth, screenHeight) = (640, 480) 24 | 25 | loadBMP :: FilePath -> IO SDL.Surface 26 | loadBMP path = getDataFileName path >>= SDL.loadBMP 27 | 28 | main :: IO () 29 | main = do 30 | SDL.initialize [SDL.InitVideo] 31 | window <- SDL.createWindow "SDL Tutorial" SDL.defaultWindow { SDL.windowInitialSize = V2 screenWidth screenHeight } 32 | SDL.showWindow window 33 | screenSurface <- SDL.getWindowSurface window 34 | 35 | surfaceDefault <- loadBMP "examples/lazyfoo/press.bmp" 36 | surfaceUp <- loadBMP "examples/lazyfoo/up.bmp" 37 | surfaceDown <- loadBMP "examples/lazyfoo/down.bmp" 38 | surfaceLeft <- loadBMP "examples/lazyfoo/left.bmp" 39 | surfaceRight <- loadBMP "examples/lazyfoo/right.bmp" 40 | 41 | let 42 | loop oldSurface = do 43 | events <- map SDL.eventPayload <$> SDL.pollEvents 44 | let quit = SDL.QuitEvent `elem` events 45 | 46 | currentSurface = 47 | fromMaybe oldSurface $ getLast $ 48 | foldMap (\case SDL.KeyboardEvent e 49 | | SDL.keyboardEventKeyMotion e == SDL.Pressed -> 50 | case SDL.keysymKeycode (SDL.keyboardEventKeysym e) of 51 | SDL.KeycodeUp -> Last (Just surfaceUp) 52 | SDL.KeycodeDown -> Last (Just surfaceDown) 53 | SDL.KeycodeRight -> Last (Just surfaceRight) 54 | SDL.KeycodeLeft -> Last (Just surfaceLeft) 55 | _ -> mempty 56 | _ -> mempty) 57 | events 58 | 59 | void $ SDL.surfaceBlit currentSurface Nothing screenSurface Nothing 60 | SDL.updateWindowSurface window 61 | 62 | unless quit (loop currentSurface) 63 | 64 | loop surfaceDefault 65 | 66 | mapM_ SDL.freeSurface [ surfaceDefault, surfaceUp, surfaceDown, surfaceRight, surfaceLeft ] 67 | SDL.destroyWindow window 68 | SDL.quit 69 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson05.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Lazyfoo.Lesson05 (main) where 4 | 5 | import Control.Monad 6 | import Foreign.C.Types 7 | import SDL.Vect 8 | import qualified SDL 9 | 10 | import Paths_sdl2 (getDataFileName) 11 | 12 | #if !MIN_VERSION_base(4,8,0) 13 | import Control.Applicative 14 | #endif 15 | 16 | screenWidth, screenHeight :: CInt 17 | (screenWidth, screenHeight) = (640, 480) 18 | 19 | loadSurface :: SDL.Surface -> FilePath -> IO SDL.Surface 20 | loadSurface screenSurface path = do 21 | loadedSurface <- getDataFileName path >>= SDL.loadBMP 22 | desiredFormat <- SDL.surfaceFormat screenSurface 23 | SDL.convertSurface loadedSurface desiredFormat <* SDL.freeSurface loadedSurface 24 | 25 | main :: IO () 26 | main = do 27 | SDL.initialize [SDL.InitVideo] 28 | window <- SDL.createWindow "SDL Tutorial" SDL.defaultWindow { SDL.windowInitialSize = V2 screenWidth screenHeight } 29 | SDL.showWindow window 30 | screenSurface <- SDL.getWindowSurface window 31 | 32 | stretchedSurface <- loadSurface screenSurface "examples/lazyfoo/stretch.bmp" 33 | 34 | let 35 | loop = do 36 | events <- SDL.pollEvents 37 | let quit = elem SDL.QuitEvent $ map SDL.eventPayload events 38 | 39 | SDL.surfaceBlitScaled stretchedSurface Nothing screenSurface Nothing 40 | SDL.updateWindowSurface window 41 | 42 | unless quit loop 43 | 44 | loop 45 | 46 | SDL.freeSurface stretchedSurface 47 | SDL.destroyWindow window 48 | SDL.quit 49 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson07.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Lazyfoo.Lesson07 (main) where 3 | 4 | import Control.Monad 5 | import Foreign.C.Types 6 | import SDL.Vect 7 | import SDL (($=)) 8 | import qualified SDL 9 | 10 | import Paths_sdl2 (getDataFileName) 11 | 12 | screenWidth, screenHeight :: CInt 13 | (screenWidth, screenHeight) = (640, 480) 14 | 15 | main :: IO () 16 | main = do 17 | SDL.initialize [SDL.InitVideo] 18 | 19 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 20 | do renderQuality <- SDL.get SDL.HintRenderScaleQuality 21 | when (renderQuality /= SDL.ScaleLinear) $ 22 | putStrLn "Warning: Linear texture filtering not enabled!" 23 | 24 | window <- 25 | SDL.createWindow 26 | "SDL Tutorial" 27 | SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight} 28 | SDL.showWindow window 29 | 30 | renderer <- 31 | SDL.createRenderer 32 | window 33 | (-1) 34 | SDL.RendererConfig 35 | { SDL.rendererType = SDL.AcceleratedRenderer 36 | , SDL.rendererTargetTexture = False 37 | } 38 | 39 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 40 | 41 | xOutSurface <- getDataFileName "examples/lazyfoo/texture.bmp" >>= SDL.loadBMP 42 | texture <- SDL.createTextureFromSurface renderer xOutSurface 43 | SDL.freeSurface xOutSurface 44 | 45 | let loop = do 46 | events <- SDL.pollEvents 47 | 48 | let quit = elem SDL.QuitEvent $ map SDL.eventPayload events 49 | 50 | SDL.clear renderer 51 | SDL.copy renderer texture Nothing Nothing 52 | SDL.present renderer 53 | 54 | unless quit loop 55 | 56 | loop 57 | 58 | SDL.destroyRenderer renderer 59 | SDL.destroyWindow window 60 | SDL.quit 61 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson08.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Lazyfoo.Lesson08 (main) where 3 | 4 | import Control.Monad 5 | import Data.Foldable (for_) 6 | import Foreign.C.Types 7 | import SDL.Vect 8 | import SDL (($=)) 9 | import qualified SDL 10 | 11 | screenWidth, screenHeight :: CInt 12 | (screenWidth, screenHeight) = (640, 480) 13 | 14 | main :: IO () 15 | main = do 16 | SDL.initialize [SDL.InitVideo] 17 | 18 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 19 | do renderQuality <- SDL.get SDL.HintRenderScaleQuality 20 | when (renderQuality /= SDL.ScaleLinear) $ 21 | putStrLn "Warning: Linear texture filtering not enabled!" 22 | 23 | window <- 24 | SDL.createWindow 25 | "SDL Tutorial" 26 | SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight} 27 | SDL.showWindow window 28 | 29 | renderer <- 30 | SDL.createRenderer 31 | window 32 | (-1) 33 | SDL.RendererConfig 34 | { SDL.rendererType = SDL.AcceleratedRenderer 35 | , SDL.rendererTargetTexture = False 36 | } 37 | 38 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 39 | 40 | let loop = do 41 | events <- SDL.pollEvents 42 | 43 | let quit = elem SDL.QuitEvent $ map SDL.eventPayload events 44 | 45 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 46 | SDL.clear renderer 47 | 48 | SDL.rendererDrawColor renderer $= V4 maxBound 0 0 maxBound 49 | SDL.fillRect renderer (Just $ SDL.Rectangle (P $ V2 (screenWidth `div` 4) (screenHeight `div` 4)) 50 | (V2 (screenWidth `div` 2) (screenHeight `div` 2))) 51 | 52 | SDL.rendererDrawColor renderer $= V4 0 0 maxBound maxBound 53 | SDL.drawRect renderer (Just (SDL.Rectangle (P $ V2 (screenWidth `div` 6) (screenHeight `div` 6)) 54 | (V2 (screenWidth * 2 `div` 3) (screenHeight * 2 `div` 3)))) 55 | 56 | SDL.rendererDrawColor renderer $= V4 0 maxBound 0 maxBound 57 | SDL.drawLine renderer (P (V2 0 (screenHeight `div` 2))) (P (V2 screenWidth (screenHeight `div` 2))) 58 | 59 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 60 | for_ [0, 4 .. screenHeight] $ \i -> 61 | SDL.drawPoint renderer (P (V2 (screenWidth `div` 2) i)) 62 | 63 | SDL.present renderer 64 | 65 | unless quit loop 66 | 67 | loop 68 | 69 | SDL.destroyRenderer renderer 70 | SDL.destroyWindow window 71 | SDL.quit 72 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson09.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Lazyfoo.Lesson09 (main) where 3 | 4 | import Control.Monad 5 | import Foreign.C.Types 6 | import SDL.Vect 7 | import SDL (($=)) 8 | import qualified SDL 9 | 10 | import Paths_sdl2 (getDataFileName) 11 | 12 | screenWidth, screenHeight :: CInt 13 | (screenWidth, screenHeight) = (640, 480) 14 | 15 | main :: IO () 16 | main = do 17 | SDL.initialize [SDL.InitVideo] 18 | 19 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 20 | do renderQuality <- SDL.get SDL.HintRenderScaleQuality 21 | when (renderQuality /= SDL.ScaleLinear) $ 22 | putStrLn "Warning: Linear texture filtering not enabled!" 23 | 24 | window <- 25 | SDL.createWindow 26 | "SDL Tutorial" 27 | SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight} 28 | SDL.showWindow window 29 | 30 | renderer <- 31 | SDL.createRenderer 32 | window 33 | (-1) 34 | SDL.RendererConfig 35 | { SDL.rendererType = SDL.AcceleratedRenderer 36 | , SDL.rendererTargetTexture = False 37 | } 38 | 39 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 40 | 41 | textureSurface <- getDataFileName "examples/lazyfoo/viewport.bmp" >>= SDL.loadBMP 42 | texture <- SDL.createTextureFromSurface renderer textureSurface 43 | SDL.freeSurface textureSurface 44 | 45 | let loop = do 46 | events <- SDL.pollEvents 47 | 48 | let quit = elem SDL.QuitEvent $ map SDL.eventPayload events 49 | 50 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 51 | SDL.clear renderer 52 | 53 | SDL.rendererViewport renderer $= Just (SDL.Rectangle (P (V2 0 0)) (V2 (screenWidth `div` 2) (screenHeight `div` 2))) 54 | SDL.copy renderer texture Nothing Nothing 55 | 56 | SDL.rendererViewport renderer $= Just (SDL.Rectangle (P (V2 (screenWidth `div` 2) 0)) (V2 (screenWidth `div` 2) (screenHeight `div` 2))) 57 | SDL.copy renderer texture Nothing Nothing 58 | 59 | SDL.rendererViewport renderer $= Just (SDL.Rectangle (P (V2 0 (screenHeight `div` 2))) (V2 screenWidth (screenHeight `div` 2))) 60 | SDL.copy renderer texture Nothing Nothing 61 | 62 | SDL.present renderer 63 | 64 | unless quit loop 65 | 66 | loop 67 | 68 | SDL.destroyRenderer renderer 69 | SDL.destroyWindow window 70 | SDL.quit 71 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson10.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Lazyfoo.Lesson10 (main) where 3 | 4 | import Control.Monad 5 | import Foreign.C.Types 6 | import SDL.Vect 7 | import SDL (($=)) 8 | import qualified SDL 9 | 10 | import Paths_sdl2 (getDataFileName) 11 | 12 | screenWidth, screenHeight :: CInt 13 | (screenWidth, screenHeight) = (640, 480) 14 | 15 | data Texture = Texture SDL.Texture (V2 CInt) 16 | 17 | loadTexture :: SDL.Renderer -> FilePath -> IO Texture 18 | loadTexture r filePath = do 19 | surface <- getDataFileName filePath >>= SDL.loadBMP 20 | size <- SDL.surfaceDimensions surface 21 | let key = V4 0 maxBound maxBound maxBound 22 | SDL.surfaceColorKey surface $= Just key 23 | t <- SDL.createTextureFromSurface r surface 24 | SDL.freeSurface surface 25 | return (Texture t size) 26 | 27 | renderTexture :: SDL.Renderer -> Texture -> Point V2 CInt -> IO () 28 | renderTexture r (Texture t size) xy = 29 | SDL.copy r t Nothing (Just $ SDL.Rectangle xy size) 30 | 31 | main :: IO () 32 | main = do 33 | SDL.initialize [SDL.InitVideo] 34 | 35 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 36 | do renderQuality <- SDL.get SDL.HintRenderScaleQuality 37 | when (renderQuality /= SDL.ScaleLinear) $ 38 | putStrLn "Warning: Linear texture filtering not enabled!" 39 | 40 | window <- 41 | SDL.createWindow 42 | "SDL Tutorial" 43 | SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight} 44 | SDL.showWindow window 45 | 46 | renderer <- 47 | SDL.createRenderer 48 | window 49 | (-1) 50 | SDL.RendererConfig 51 | { SDL.rendererType = SDL.AcceleratedRenderer 52 | , SDL.rendererTargetTexture = False 53 | } 54 | 55 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 56 | 57 | fooTexture <- loadTexture renderer "examples/lazyfoo/foo.bmp" 58 | backgroundTexture <- loadTexture renderer "examples/lazyfoo/background.bmp" 59 | 60 | let loop = do 61 | events <- SDL.pollEvents 62 | 63 | let quit = elem SDL.QuitEvent $ map SDL.eventPayload events 64 | 65 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 66 | SDL.clear renderer 67 | 68 | renderTexture renderer backgroundTexture 0 69 | renderTexture renderer fooTexture (P (V2 240 190)) 70 | 71 | SDL.present renderer 72 | 73 | unless quit loop 74 | 75 | loop 76 | 77 | SDL.destroyRenderer renderer 78 | SDL.destroyWindow window 79 | SDL.quit 80 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson11.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Lazyfoo.Lesson11 (main) where 4 | 5 | import Control.Monad 6 | import Foreign.C.Types 7 | import SDL.Vect 8 | import SDL (($=)) 9 | import qualified SDL 10 | 11 | import Paths_sdl2 (getDataFileName) 12 | 13 | #if !MIN_VERSION_base(4,8,0) 14 | import Control.Applicative 15 | #endif 16 | 17 | screenWidth, screenHeight :: CInt 18 | (screenWidth, screenHeight) = (640, 480) 19 | 20 | data Texture = Texture SDL.Texture (V2 CInt) 21 | 22 | loadTexture :: SDL.Renderer -> FilePath -> IO Texture 23 | loadTexture r filePath = do 24 | surface <- getDataFileName filePath >>= SDL.loadBMP 25 | size <- SDL.surfaceDimensions surface 26 | let key = V4 0 maxBound maxBound maxBound 27 | SDL.surfaceColorKey surface $= Just key 28 | t <- SDL.createTextureFromSurface r surface 29 | SDL.freeSurface surface 30 | return (Texture t size) 31 | 32 | renderTexture :: SDL.Renderer -> Texture -> Point V2 CInt -> Maybe (SDL.Rectangle CInt) -> IO () 33 | renderTexture r (Texture t size) xy clip = 34 | let dstSize = maybe size (\(SDL.Rectangle _ size') -> size') clip 35 | in SDL.copy r t clip (Just (SDL.Rectangle xy dstSize)) 36 | 37 | main :: IO () 38 | main = do 39 | SDL.initialize [SDL.InitVideo] 40 | 41 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 42 | do renderQuality <- SDL.get SDL.HintRenderScaleQuality 43 | when (renderQuality /= SDL.ScaleLinear) $ 44 | putStrLn "Warning: Linear texture filtering not enabled!" 45 | 46 | window <- 47 | SDL.createWindow 48 | "SDL Tutorial" 49 | SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight} 50 | SDL.showWindow window 51 | 52 | renderer <- 53 | SDL.createRenderer 54 | window 55 | (-1) 56 | SDL.RendererConfig 57 | { SDL.rendererType = SDL.SoftwareRenderer 58 | , SDL.rendererTargetTexture = False 59 | } 60 | 61 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 62 | 63 | spriteSheetTexture <- loadTexture renderer "examples/lazyfoo/dots.bmp" 64 | let spriteSize = V2 100 100 65 | clip1 = SDL.Rectangle (P (V2 0 0)) spriteSize 66 | clip2 = SDL.Rectangle (P (V2 100 0)) spriteSize 67 | clip3 = SDL.Rectangle (P (V2 0 100)) spriteSize 68 | clip4 = SDL.Rectangle (P (V2 100 100)) spriteSize 69 | 70 | let loop = do 71 | events <- SDL.pollEvents 72 | 73 | let quit = elem SDL.QuitEvent $ map SDL.eventPayload events 74 | 75 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 76 | SDL.clear renderer 77 | 78 | renderTexture renderer spriteSheetTexture (P (V2 0 0)) (Just clip1) 79 | renderTexture renderer spriteSheetTexture (P (V2 (screenWidth -) (const 0) <*> spriteSize)) (Just clip2) 80 | renderTexture renderer spriteSheetTexture (P (V2 (const 0) (screenHeight -) <*> spriteSize)) (Just clip3) 81 | renderTexture renderer spriteSheetTexture (P (V2 (screenWidth -) (screenHeight -) <*> spriteSize)) (Just clip4) 82 | 83 | SDL.present renderer 84 | 85 | unless quit loop 86 | 87 | loop 88 | 89 | SDL.destroyRenderer renderer 90 | SDL.destroyWindow window 91 | SDL.quit 92 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson12.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiWayIf #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | module Lazyfoo.Lesson12 (main) where 7 | 8 | import Control.Monad 9 | import Data.Monoid 10 | import Data.Word 11 | import Foreign.C.Types 12 | import SDL.Vect 13 | import SDL (($=)) 14 | import qualified SDL 15 | 16 | import Paths_sdl2 (getDataFileName) 17 | 18 | #if !MIN_VERSION_base(4,8,0) 19 | import Data.Foldable 20 | #endif 21 | 22 | screenWidth, screenHeight :: CInt 23 | (screenWidth, screenHeight) = (640, 480) 24 | 25 | data Texture = Texture SDL.Texture (V2 CInt) 26 | 27 | loadTexture :: SDL.Renderer -> FilePath -> IO Texture 28 | loadTexture r filePath = do 29 | surface <- getDataFileName filePath >>= SDL.loadBMP 30 | size <- SDL.surfaceDimensions surface 31 | let key = V4 0 maxBound maxBound maxBound 32 | SDL.surfaceColorKey surface $= Just key 33 | t <- SDL.createTextureFromSurface r surface 34 | SDL.freeSurface surface 35 | return (Texture t size) 36 | 37 | renderTexture :: SDL.Renderer -> Texture -> Point V2 CInt -> Maybe (SDL.Rectangle CInt) -> IO () 38 | renderTexture r (Texture t size) xy clip = 39 | let dstSize = maybe size (\(SDL.Rectangle _ size') -> size') clip 40 | in SDL.copy r t clip (Just (SDL.Rectangle xy dstSize)) 41 | 42 | setTextureColor :: Texture -> V3 Word8 -> IO () 43 | setTextureColor (Texture t _) rgb = SDL.textureColorMod t $= rgb 44 | 45 | main :: IO () 46 | main = do 47 | SDL.initialize [SDL.InitVideo] 48 | 49 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 50 | do renderQuality <- SDL.get SDL.HintRenderScaleQuality 51 | when (renderQuality /= SDL.ScaleLinear) $ 52 | putStrLn "Warning: Linear texture filtering not enabled!" 53 | 54 | window <- 55 | SDL.createWindow 56 | "SDL Tutorial" 57 | SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight} 58 | SDL.showWindow window 59 | 60 | renderer <- 61 | SDL.createRenderer 62 | window 63 | (-1) 64 | SDL.RendererConfig 65 | { SDL.rendererType = SDL.SoftwareRenderer 66 | , SDL.rendererTargetTexture = False 67 | } 68 | 69 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 70 | 71 | modulatedTexture <- loadTexture renderer "examples/lazyfoo/colors.bmp" 72 | 73 | let loop color = do 74 | events <- SDL.pollEvents 75 | 76 | let (Any quit, Sum colorAdjustment) = 77 | foldMap (\case 78 | SDL.QuitEvent -> (Any True, mempty) 79 | SDL.KeyboardEvent e -> 80 | (\x -> (mempty, x)) $ 81 | if | SDL.keyboardEventKeyMotion e == SDL.Pressed -> 82 | case SDL.keysymScancode (SDL.keyboardEventKeysym e) of 83 | SDL.ScancodeQ -> Sum (V3 32 0 0) 84 | SDL.ScancodeW -> Sum (V3 0 32 0) 85 | SDL.ScancodeE -> Sum (V3 0 0 32) 86 | SDL.ScancodeA -> Sum (V3 224 0 0) 87 | SDL.ScancodeS -> Sum (V3 0 224 0) 88 | SDL.ScancodeD -> Sum (V3 0 0 224) 89 | _ -> mempty 90 | | otherwise -> mempty 91 | _ -> mempty) $ 92 | map SDL.eventPayload events 93 | 94 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 95 | SDL.clear renderer 96 | 97 | let color' = color + colorAdjustment 98 | setTextureColor modulatedTexture color' 99 | renderTexture renderer modulatedTexture 0 Nothing 100 | 101 | SDL.present renderer 102 | 103 | unless quit (loop color') 104 | 105 | loop (V3 maxBound maxBound maxBound) 106 | 107 | SDL.destroyRenderer renderer 108 | SDL.destroyWindow window 109 | SDL.quit 110 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson13.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiWayIf #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | module Lazyfoo.Lesson13 (main) where 7 | 8 | import Control.Monad 9 | import Data.Monoid 10 | import Data.Word 11 | import Foreign.C.Types 12 | import SDL.Vect 13 | import SDL (($=)) 14 | import qualified SDL 15 | 16 | import Paths_sdl2 (getDataFileName) 17 | 18 | #if !MIN_VERSION_base(4,8,0) 19 | import Data.Foldable 20 | #endif 21 | 22 | screenWidth, screenHeight :: CInt 23 | (screenWidth, screenHeight) = (640, 480) 24 | 25 | data Texture = Texture SDL.Texture (V2 CInt) 26 | 27 | loadTexture :: SDL.Renderer -> FilePath -> IO Texture 28 | loadTexture r filePath = do 29 | surface <- getDataFileName filePath >>= SDL.loadBMP 30 | size <- SDL.surfaceDimensions surface 31 | let key = V4 0 maxBound maxBound maxBound 32 | SDL.surfaceColorKey surface $= Just key 33 | t <- SDL.createTextureFromSurface r surface 34 | SDL.freeSurface surface 35 | return (Texture t size) 36 | 37 | renderTexture :: SDL.Renderer -> Texture -> Point V2 CInt -> Maybe (SDL.Rectangle CInt) -> IO () 38 | renderTexture r (Texture t size) xy clip = 39 | let dstSize = maybe size (\(SDL.Rectangle _ size') -> size') clip 40 | in SDL.copy r t clip (Just (SDL.Rectangle xy dstSize)) 41 | 42 | setTextureAlpha :: Texture -> Word8 -> IO () 43 | setTextureAlpha (Texture t _) rgb = SDL.textureAlphaMod t $= rgb 44 | 45 | setTextureBlendMode :: Texture -> SDL.BlendMode -> IO () 46 | setTextureBlendMode (Texture t _) bm = SDL.textureBlendMode t $= bm 47 | 48 | main :: IO () 49 | main = do 50 | SDL.initialize [SDL.InitVideo] 51 | 52 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 53 | do renderQuality <- SDL.get SDL.HintRenderScaleQuality 54 | when (renderQuality /= SDL.ScaleLinear) $ 55 | putStrLn "Warning: Linear texture filtering not enabled!" 56 | 57 | window <- 58 | SDL.createWindow 59 | "SDL Tutorial" 60 | SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight} 61 | SDL.showWindow window 62 | 63 | renderer <- 64 | SDL.createRenderer 65 | window 66 | (-1) 67 | SDL.RendererConfig 68 | { SDL.rendererType = SDL.UnacceleratedRenderer 69 | , SDL.rendererTargetTexture = False 70 | } 71 | 72 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 73 | 74 | modulatedTexture <- loadTexture renderer "examples/lazyfoo/fadeout.bmp" 75 | setTextureBlendMode modulatedTexture SDL.BlendAlphaBlend 76 | 77 | backgroundTexture <- loadTexture renderer "examples/lazyfoo/fadein.bmp" 78 | 79 | let loop alpha = do 80 | events <- SDL.pollEvents 81 | 82 | let (Any quit, Sum alphaAdjustment) = 83 | foldMap (\case 84 | SDL.QuitEvent -> (Any True, mempty) 85 | SDL.KeyboardEvent e -> 86 | (\x -> (mempty, x)) $ 87 | if | SDL.keyboardEventKeyMotion e == SDL.Pressed -> 88 | case SDL.keysymScancode (SDL.keyboardEventKeysym e) of 89 | SDL.ScancodeW -> Sum 32 90 | SDL.ScancodeS -> Sum (-32) 91 | _ -> mempty 92 | | otherwise -> mempty 93 | _ -> mempty) $ 94 | map SDL.eventPayload events 95 | 96 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 97 | SDL.clear renderer 98 | 99 | renderTexture renderer backgroundTexture 0 Nothing 100 | 101 | let alpha' = max 0 (min 255 (alpha + alphaAdjustment)) 102 | setTextureAlpha modulatedTexture (fromIntegral alpha') 103 | renderTexture renderer modulatedTexture 0 Nothing 104 | 105 | SDL.present renderer 106 | 107 | unless quit (loop alpha') 108 | 109 | loop (255 :: Int) -- We use 'Int' to avoid integer overflow 110 | 111 | SDL.destroyRenderer renderer 112 | SDL.destroyWindow window 113 | SDL.quit 114 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson14.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Lazyfoo.Lesson14 (main) where 4 | 5 | import Control.Monad 6 | import Foreign.C.Types 7 | import SDL.Vect 8 | import SDL (($=)) 9 | import qualified SDL 10 | 11 | import Paths_sdl2 (getDataFileName) 12 | 13 | screenWidth, screenHeight :: CInt 14 | (screenWidth, screenHeight) = (640, 480) 15 | 16 | data Texture = Texture SDL.Texture (V2 CInt) 17 | 18 | loadTexture :: SDL.Renderer -> FilePath -> IO Texture 19 | loadTexture r filePath = do 20 | surface <- getDataFileName filePath >>= SDL.loadBMP 21 | size <- SDL.surfaceDimensions surface 22 | let key = V4 0 maxBound maxBound maxBound 23 | SDL.surfaceColorKey surface $= Just key 24 | t <- SDL.createTextureFromSurface r surface 25 | SDL.freeSurface surface 26 | return (Texture t size) 27 | 28 | renderTexture :: SDL.Renderer -> Texture -> Point V2 CInt -> Maybe (SDL.Rectangle CInt) -> IO () 29 | renderTexture r (Texture t size) xy clip = 30 | let dstSize = maybe size (\(SDL.Rectangle _ size') -> size') clip 31 | in SDL.copy r t clip (Just (SDL.Rectangle xy dstSize)) 32 | 33 | main :: IO () 34 | main = do 35 | SDL.initialize [SDL.InitVideo] 36 | 37 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 38 | do renderQuality <- SDL.get SDL.HintRenderScaleQuality 39 | when (renderQuality /= SDL.ScaleLinear) $ 40 | putStrLn "Warning: Linear texture filtering not enabled!" 41 | 42 | window <- 43 | SDL.createWindow 44 | "SDL Tutorial" 45 | SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight} 46 | SDL.showWindow window 47 | 48 | renderer <- 49 | SDL.createRenderer 50 | window 51 | (-1) 52 | SDL.RendererConfig 53 | { SDL.rendererType = SDL.AcceleratedVSyncRenderer 54 | , SDL.rendererTargetTexture = False 55 | } 56 | 57 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 58 | 59 | spriteSheetTexture <- loadTexture renderer "examples/lazyfoo/animation.bmp" 60 | let spriteSize = V2 64 205 61 | clip1 = SDL.Rectangle (P (V2 0 0)) spriteSize 62 | clip2 = SDL.Rectangle (P (V2 64 0)) spriteSize 63 | clip3 = SDL.Rectangle (P (V2 128 0)) spriteSize 64 | clip4 = SDL.Rectangle (P (V2 196 0)) spriteSize 65 | 66 | let loop [] = return () 67 | loop (frame:frames) = do 68 | events <- SDL.pollEvents 69 | 70 | let quit = elem SDL.QuitEvent $ map SDL.eventPayload events 71 | 72 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 73 | SDL.clear renderer 74 | 75 | renderTexture renderer spriteSheetTexture (P (fmap (`div` 2) (V2 screenWidth screenHeight) - fmap (`div` 2) spriteSize)) (Just frame) 76 | 77 | SDL.present renderer 78 | 79 | unless quit (loop frames) 80 | 81 | loop (cycle ([clip1, clip2, clip3, clip4] >>= replicate 4)) 82 | 83 | SDL.destroyRenderer renderer 84 | SDL.destroyWindow window 85 | SDL.quit 86 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson15.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiWayIf #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | module Lazyfoo.Lesson15 (main) where 7 | 8 | import Control.Monad 9 | import Data.Monoid 10 | import Data.Maybe 11 | import Foreign.C.Types 12 | import SDL.Vect 13 | import SDL (($=)) 14 | import qualified SDL 15 | 16 | import Paths_sdl2 (getDataFileName) 17 | 18 | #if !MIN_VERSION_base(4,8,0) 19 | import Control.Applicative 20 | import Data.Foldable 21 | #endif 22 | 23 | screenWidth, screenHeight :: CInt 24 | (screenWidth, screenHeight) = (640, 480) 25 | 26 | data Texture = Texture SDL.Texture (V2 CInt) 27 | 28 | loadTexture :: SDL.Renderer -> FilePath -> IO Texture 29 | loadTexture r filePath = do 30 | surface <- getDataFileName filePath >>= SDL.loadBMP 31 | size <- SDL.surfaceDimensions surface 32 | let key = V4 0 maxBound maxBound maxBound 33 | SDL.surfaceColorKey surface $= Just key 34 | t <- SDL.createTextureFromSurface r surface 35 | SDL.freeSurface surface 36 | return (Texture t size) 37 | 38 | renderTexture :: SDL.Renderer -> Texture -> Point V2 CInt -> Maybe (SDL.Rectangle CInt) -> Maybe CDouble -> Maybe (Point V2 CInt) -> Maybe (V2 Bool) -> IO () 39 | renderTexture r (Texture t size) xy clip theta center flips = 40 | let dstSize = 41 | maybe size (\(SDL.Rectangle _ size') -> size') clip 42 | in SDL.copyEx r 43 | t 44 | clip 45 | (Just (SDL.Rectangle xy dstSize)) 46 | (fromMaybe 0 theta) 47 | center 48 | (fromMaybe (pure False) flips) 49 | 50 | textureSize :: Texture -> V2 CInt 51 | textureSize (Texture _ sz) = sz 52 | 53 | main :: IO () 54 | main = do 55 | SDL.initialize [SDL.InitVideo] 56 | 57 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 58 | do renderQuality <- SDL.get SDL.HintRenderScaleQuality 59 | when (renderQuality /= SDL.ScaleLinear) $ 60 | putStrLn "Warning: Linear texture filtering not enabled!" 61 | 62 | window <- 63 | SDL.createWindow 64 | "SDL Tutorial" 65 | SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight} 66 | SDL.showWindow window 67 | 68 | renderer <- 69 | SDL.createRenderer 70 | window 71 | (-1) 72 | SDL.RendererConfig 73 | { SDL.rendererType = SDL.AcceleratedVSyncRenderer 74 | , SDL.rendererTargetTexture = False 75 | } 76 | 77 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 78 | 79 | arrowTexture <- loadTexture renderer "examples/lazyfoo/arrow.bmp" 80 | 81 | let loop theta flips = do 82 | events <- SDL.pollEvents 83 | 84 | let (Any quit, Sum phi, Last newFlips) = 85 | foldMap (\case 86 | SDL.QuitEvent -> (Any True, mempty, mempty) 87 | SDL.KeyboardEvent e -> 88 | (\(x,y) -> (mempty, x,y)) $ 89 | if | SDL.keyboardEventKeyMotion e == SDL.Pressed -> 90 | case SDL.keysymScancode (SDL.keyboardEventKeysym e) of 91 | SDL.ScancodeQ -> (mempty, Last (Just (V2 True False))) 92 | SDL.ScancodeW -> (mempty, Last (Just (V2 False False))) 93 | SDL.ScancodeE -> (mempty, Last (Just (V2 False True))) 94 | SDL.ScancodeA -> (Sum (-60), mempty) 95 | SDL.ScancodeD -> (Sum 60, mempty) 96 | _ -> mempty 97 | | otherwise -> mempty 98 | _ -> mempty) $ 99 | map SDL.eventPayload events 100 | 101 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 102 | SDL.clear renderer 103 | 104 | let theta' = theta + phi 105 | flips' = fromMaybe flips newFlips 106 | renderTexture renderer arrowTexture (P (fmap (`div` 2) (V2 screenWidth screenHeight) - fmap (`div` 2) (textureSize arrowTexture))) Nothing (Just theta') Nothing (Just flips') 107 | 108 | SDL.present renderer 109 | 110 | unless quit (loop theta' flips') 111 | 112 | loop 0 (pure False) 113 | 114 | SDL.destroyRenderer renderer 115 | SDL.destroyWindow window 116 | SDL.quit 117 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson17.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module Lazyfoo.Lesson17 (main) where 5 | 6 | import Prelude hiding (foldl1, and) 7 | import Control.Monad 8 | import Data.Foldable 9 | import Data.Monoid 10 | import Data.Maybe 11 | import Foreign.C.Types 12 | import SDL.Vect 13 | import SDL (($=)) 14 | import qualified SDL 15 | 16 | import Paths_sdl2 (getDataFileName) 17 | 18 | #if !MIN_VERSION_base(4,8,0) 19 | import Control.Applicative 20 | #endif 21 | 22 | screenWidth, screenHeight :: CInt 23 | (screenWidth, screenHeight) = (640, 480) 24 | 25 | data Texture = Texture SDL.Texture (V2 CInt) 26 | 27 | loadTexture :: SDL.Renderer -> FilePath -> IO Texture 28 | loadTexture r filePath = do 29 | surface <- getDataFileName filePath >>= SDL.loadBMP 30 | size <- SDL.surfaceDimensions surface 31 | let key = V4 0 maxBound maxBound maxBound 32 | SDL.surfaceColorKey surface $= Just key 33 | t <- SDL.createTextureFromSurface r surface 34 | SDL.freeSurface surface 35 | return (Texture t size) 36 | 37 | renderTexture :: SDL.Renderer -> Texture -> Point V2 CInt -> Maybe (SDL.Rectangle CInt) -> Maybe CDouble -> Maybe (Point V2 CInt) -> Maybe (V2 Bool) -> IO () 38 | renderTexture r (Texture t size) xy clip theta center flips = 39 | let dstSize = 40 | maybe size (\(SDL.Rectangle _ size') -> size') clip 41 | in SDL.copyEx r 42 | t 43 | clip 44 | (Just (SDL.Rectangle xy dstSize)) 45 | (fromMaybe 0 theta) 46 | center 47 | (fromMaybe (pure False) flips) 48 | 49 | data ButtonSprite = MouseOut | MouseOver | MouseDown | MouseUp 50 | 51 | data Button = Button (Point V2 CInt) ButtonSprite 52 | 53 | buttonSize :: V2 CInt 54 | buttonWidth, buttonHeight :: CInt 55 | buttonSize@(V2 buttonWidth buttonHeight) = V2 300 200 56 | 57 | handleEvent :: Point V2 CInt -> SDL.EventPayload -> Button -> Button 58 | handleEvent mousePos ev (Button buttonPos _) = 59 | let inside = and ((>=) <$> mousePos <*> buttonPos) && 60 | and ((<=) <$> mousePos <*> buttonPos + P buttonSize) 61 | sprite 62 | | inside = case ev of 63 | SDL.MouseButtonEvent e 64 | | SDL.mouseButtonEventMotion e == SDL.Pressed -> MouseDown 65 | | SDL.mouseButtonEventMotion e == SDL.Released -> MouseUp 66 | | otherwise -> MouseOver 67 | _ -> MouseOver 68 | | otherwise = MouseOut 69 | 70 | in Button buttonPos sprite 71 | 72 | renderButton :: SDL.Renderer -> Texture -> Button -> IO () 73 | renderButton r spriteSheet (Button xy sprite) = 74 | renderTexture r spriteSheet xy (Just spriteClipRect) Nothing Nothing Nothing 75 | where 76 | spriteClipRect = 77 | let i = case sprite of 78 | MouseOut -> 0 79 | MouseOver -> 1 80 | MouseDown -> 2 81 | MouseUp -> 3 82 | in SDL.Rectangle (P (V2 0 (i * 200))) (V2 300 200) 83 | 84 | main :: IO () 85 | main = do 86 | SDL.initialize [SDL.InitVideo] 87 | 88 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 89 | do renderQuality <- SDL.get SDL.HintRenderScaleQuality 90 | when (renderQuality /= SDL.ScaleLinear) $ 91 | putStrLn "Warning: Linear texture filtering not enabled!" 92 | 93 | window <- 94 | SDL.createWindow 95 | "SDL Tutorial" 96 | SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight} 97 | SDL.showWindow window 98 | 99 | renderer <- 100 | SDL.createRenderer 101 | window 102 | (-1) 103 | SDL.RendererConfig 104 | { SDL.rendererType = SDL.AcceleratedVSyncRenderer 105 | , SDL.rendererTargetTexture = False 106 | } 107 | 108 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 109 | 110 | buttonSpriteSheet <- loadTexture renderer "examples/lazyfoo/button.bmp" 111 | 112 | let loop buttons = do 113 | events <- SDL.pollEvents 114 | mousePos <- SDL.getAbsoluteMouseLocation 115 | 116 | let (Any quit, Endo updateButton) = 117 | foldMap (\case 118 | SDL.QuitEvent -> (Any True, mempty) 119 | e -> (mempty, Endo (handleEvent mousePos e))) $ 120 | map SDL.eventPayload events 121 | 122 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 123 | SDL.clear renderer 124 | 125 | let buttons' = map updateButton buttons 126 | for_ buttons' (renderButton renderer buttonSpriteSheet) 127 | 128 | SDL.present renderer 129 | 130 | unless quit (loop buttons') 131 | 132 | loop (let newButton xy = Button xy MouseOut 133 | in [ newButton (P (V2 0 0)) 134 | , newButton (P (V2 (screenWidth - buttonWidth) 0)) 135 | , newButton (P (V2 0 (screenHeight - buttonHeight))) 136 | , newButton (P (V2 screenWidth screenHeight - buttonSize)) 137 | ]) 138 | 139 | SDL.destroyRenderer renderer 140 | SDL.destroyWindow window 141 | SDL.quit 142 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson18.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiWayIf #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | module Lazyfoo.Lesson18 (main) where 6 | 7 | import Prelude hiding (any, mapM_) 8 | import Control.Monad hiding (mapM_) 9 | import Data.Foldable hiding (elem) 10 | import Data.Maybe 11 | import Foreign.C.Types 12 | import SDL.Vect 13 | import SDL (($=)) 14 | import qualified SDL 15 | 16 | import Paths_sdl2 (getDataFileName) 17 | 18 | #if !MIN_VERSION_base(4,8,0) 19 | import Control.Applicative 20 | #endif 21 | 22 | screenWidth, screenHeight :: CInt 23 | (screenWidth, screenHeight) = (640, 480) 24 | 25 | data Texture = Texture SDL.Texture (V2 CInt) 26 | 27 | loadTexture :: SDL.Renderer -> FilePath -> IO Texture 28 | loadTexture r filePath = do 29 | surface <- getDataFileName filePath >>= SDL.loadBMP 30 | size <- SDL.surfaceDimensions surface 31 | let key = V4 0 maxBound maxBound maxBound 32 | SDL.surfaceColorKey surface $= Just key 33 | t <- SDL.createTextureFromSurface r surface 34 | SDL.freeSurface surface 35 | return (Texture t size) 36 | 37 | renderTexture :: SDL.Renderer -> Texture -> Point V2 CInt -> Maybe (SDL.Rectangle CInt) -> Maybe CDouble -> Maybe (Point V2 CInt) -> Maybe (V2 Bool) -> IO () 38 | renderTexture r (Texture t size) xy clip theta center flips = 39 | let dstSize = 40 | maybe size (\(SDL.Rectangle _ size') -> size') clip 41 | in SDL.copyEx r 42 | t 43 | clip 44 | (Just (SDL.Rectangle xy dstSize)) 45 | (fromMaybe 0 theta) 46 | center 47 | (fromMaybe (pure False) flips) 48 | main :: IO () 49 | main = do 50 | SDL.initialize [SDL.InitVideo] 51 | 52 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 53 | do renderQuality <- SDL.get SDL.HintRenderScaleQuality 54 | when (renderQuality /= SDL.ScaleLinear) $ 55 | putStrLn "Warning: Linear texture filtering not enabled!" 56 | 57 | window <- 58 | SDL.createWindow 59 | "SDL Tutorial" 60 | SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight} 61 | SDL.showWindow window 62 | 63 | renderer <- 64 | SDL.createRenderer 65 | window 66 | (-1) 67 | SDL.RendererConfig 68 | { SDL.rendererType = SDL.AcceleratedVSyncRenderer 69 | , SDL.rendererTargetTexture = False 70 | } 71 | 72 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 73 | 74 | pressTexture <- loadTexture renderer "examples/lazyfoo/press.bmp" 75 | upTexture <- loadTexture renderer "examples/lazyfoo/up.bmp" 76 | downTexture <- loadTexture renderer "examples/lazyfoo/down.bmp" 77 | leftTexture <- loadTexture renderer "examples/lazyfoo/left.bmp" 78 | rightTexture <- loadTexture renderer "examples/lazyfoo/right.bmp" 79 | 80 | let 81 | loop = do 82 | events <- map SDL.eventPayload <$> SDL.pollEvents 83 | let quit = SDL.QuitEvent `elem` events 84 | 85 | keyMap <- SDL.getKeyboardState 86 | let texture = 87 | if | keyMap SDL.ScancodeUp -> upTexture 88 | | keyMap SDL.ScancodeDown -> downTexture 89 | | keyMap SDL.ScancodeLeft -> leftTexture 90 | | keyMap SDL.ScancodeRight -> rightTexture 91 | | otherwise -> pressTexture 92 | 93 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 94 | SDL.clear renderer 95 | 96 | renderTexture renderer texture 0 Nothing Nothing Nothing Nothing 97 | 98 | SDL.present renderer 99 | 100 | unless quit loop 101 | 102 | loop 103 | 104 | SDL.destroyWindow window 105 | SDL.quit 106 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson19.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiWayIf #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | module Lazyfoo.Lesson19 (main) where 7 | 8 | import Prelude hiding (any, mapM_) 9 | import Control.Monad hiding (mapM_) 10 | import Data.Int 11 | import Data.Maybe 12 | import Data.Monoid 13 | import Foreign.C.Types 14 | import SDL.Vect 15 | import SDL (($=)) 16 | import qualified SDL 17 | import qualified Data.Vector as V 18 | 19 | import Paths_sdl2 (getDataFileName) 20 | 21 | #if !MIN_VERSION_base(4,8,0) 22 | import Control.Applicative 23 | import Data.Foldable 24 | #endif 25 | 26 | screenWidth, screenHeight :: CInt 27 | (screenWidth, screenHeight) = (640, 480) 28 | 29 | joystickDeadZone :: Int16 30 | joystickDeadZone = 8000 31 | 32 | data Texture = Texture SDL.Texture (V2 CInt) 33 | 34 | loadTexture :: SDL.Renderer -> FilePath -> IO Texture 35 | loadTexture r filePath = do 36 | surface <- getDataFileName filePath >>= SDL.loadBMP 37 | size <- SDL.surfaceDimensions surface 38 | let key = V4 0 maxBound maxBound maxBound 39 | SDL.surfaceColorKey surface $= Just key 40 | t <- SDL.createTextureFromSurface r surface 41 | SDL.freeSurface surface 42 | return (Texture t size) 43 | 44 | renderTexture :: SDL.Renderer -> Texture -> Point V2 CInt -> Maybe (SDL.Rectangle CInt) -> Maybe CDouble -> Maybe (Point V2 CInt) -> Maybe (V2 Bool) -> IO () 45 | renderTexture r (Texture t size) xy clip theta center flips = 46 | let dstSize = 47 | maybe size (\(SDL.Rectangle _ size') -> size') clip 48 | in SDL.copyEx r 49 | t 50 | clip 51 | (Just (SDL.Rectangle xy dstSize)) 52 | (fromMaybe 0 theta) 53 | center 54 | (fromMaybe (pure False) flips) 55 | 56 | textureSize :: Texture -> V2 CInt 57 | textureSize (Texture _ sz) = sz 58 | 59 | getJoystick :: IO SDL.Joystick 60 | getJoystick = do 61 | joysticks <- SDL.availableJoysticks 62 | joystick <- if V.length joysticks == 0 63 | then error "No joysticks connected!" 64 | else return (joysticks V.! 0) 65 | 66 | SDL.openJoystick joystick 67 | 68 | 69 | main :: IO () 70 | main = do 71 | SDL.initialize [SDL.InitVideo, SDL.InitJoystick] 72 | 73 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 74 | do renderQuality <- SDL.get SDL.HintRenderScaleQuality 75 | when (renderQuality /= SDL.ScaleLinear) $ 76 | putStrLn "Warning: Linear texture filtering not enabled!" 77 | 78 | window <- 79 | SDL.createWindow 80 | "SDL Tutorial" 81 | SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight} 82 | SDL.showWindow window 83 | 84 | renderer <- 85 | SDL.createRenderer 86 | window 87 | (-1) 88 | SDL.RendererConfig 89 | { SDL.rendererType = SDL.AcceleratedVSyncRenderer 90 | , SDL.rendererTargetTexture = False 91 | } 92 | 93 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 94 | 95 | arrowTexture <- loadTexture renderer "examples/lazyfoo/arrow.bmp" 96 | 97 | joystick <- getJoystick 98 | joystickID <- SDL.getJoystickID joystick 99 | 100 | let loop (xDir', yDir') = do 101 | events <- SDL.pollEvents 102 | 103 | let (Any quit, Last newDir) = 104 | foldMap (\case 105 | SDL.QuitEvent -> (Any True, mempty) 106 | SDL.KeyboardEvent e -> 107 | if | SDL.keyboardEventKeyMotion e == SDL.Pressed -> 108 | case SDL.keysymScancode (SDL.keyboardEventKeysym e) of 109 | SDL.ScancodeEscape -> (Any True, mempty) 110 | _ -> mempty 111 | | otherwise -> mempty 112 | SDL.JoyAxisEvent e -> 113 | if | SDL.joyAxisEventWhich e == joystickID -> 114 | (\x -> (mempty, Last $ Just x)) $ 115 | case SDL.joyAxisEventAxis e of 116 | 0 -> if | SDL.joyAxisEventValue e < -joystickDeadZone -> (-1, yDir') 117 | | SDL.joyAxisEventValue e > joystickDeadZone -> (1, yDir') 118 | | otherwise -> (0, yDir') 119 | 1 -> if | SDL.joyAxisEventValue e < -joystickDeadZone -> (xDir', -1) 120 | | SDL.joyAxisEventValue e > joystickDeadZone -> (xDir', 1) 121 | | otherwise -> (xDir', 0) 122 | _ -> (xDir', yDir') 123 | | otherwise -> mempty 124 | _ -> mempty) $ 125 | map SDL.eventPayload events 126 | 127 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 128 | SDL.clear renderer 129 | 130 | let dir@(xDir, yDir) = fromMaybe (xDir', yDir') newDir 131 | phi = if xDir == 0 && yDir == 0 132 | then 0 133 | else atan2 yDir xDir * (180.0 / pi) 134 | 135 | renderTexture renderer arrowTexture (P (fmap (`div` 2) (V2 screenWidth screenHeight) - fmap (`div` 2) (textureSize arrowTexture))) Nothing (Just phi) Nothing Nothing 136 | 137 | SDL.present renderer 138 | 139 | unless quit $ loop dir 140 | 141 | loop (0, 0) 142 | 143 | SDL.closeJoystick joystick 144 | 145 | SDL.destroyRenderer renderer 146 | SDL.destroyWindow window 147 | SDL.quit 148 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson20.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiWayIf #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | module Lazyfoo.Lesson20 (main) where 6 | 7 | import Prelude hiding (any, mapM_) 8 | import Control.Monad hiding (mapM_) 9 | import Data.Maybe 10 | import Data.Monoid 11 | import Foreign.C.Types 12 | import SDL.Vect 13 | import SDL (($=)) 14 | import SDL.Haptic 15 | import qualified SDL 16 | import qualified Data.Vector as V 17 | 18 | import Paths_sdl2 (getDataFileName) 19 | 20 | #if !MIN_VERSION_base(4,8,0) 21 | import Control.Applicative 22 | import Data.Foldable 23 | #endif 24 | 25 | screenWidth, screenHeight :: CInt 26 | (screenWidth, screenHeight) = (640, 480) 27 | 28 | data Texture = Texture SDL.Texture (V2 CInt) 29 | 30 | loadTexture :: SDL.Renderer -> FilePath -> IO Texture 31 | loadTexture r filePath = do 32 | surface <- getDataFileName filePath >>= SDL.loadBMP 33 | size <- SDL.surfaceDimensions surface 34 | let key = V4 0 maxBound maxBound maxBound 35 | SDL.colorKey surface $= Just key 36 | t <- SDL.createTextureFromSurface r surface 37 | SDL.freeSurface surface 38 | return (Texture t size) 39 | 40 | renderTexture :: SDL.Renderer -> Texture -> Point V2 CInt -> Maybe (SDL.Rectangle CInt) -> Maybe CDouble -> Maybe (Point V2 CInt) -> Maybe (V2 Bool) -> IO () 41 | renderTexture r (Texture t size) xy clip theta center flips = 42 | let dstSize = 43 | maybe size (\(SDL.Rectangle _ size') -> size') clip 44 | in SDL.renderCopyEx r 45 | t 46 | clip 47 | (Just (SDL.Rectangle xy dstSize)) 48 | (fromMaybe 0 theta) 49 | center 50 | (fromMaybe (pure False) flips) 51 | 52 | getJoystick :: IO SDL.Joystick 53 | getJoystick = do 54 | joysticks <- SDL.availableJoysticks 55 | joystick <- if V.length joysticks == 0 56 | then error "No joysticks connected!" 57 | else return (joysticks V.! 0) 58 | 59 | SDL.openJoystick joystick 60 | 61 | main :: IO () 62 | main = do 63 | SDL.initialize [SDL.InitVideo, SDL.InitJoystick, SDL.InitHaptic] 64 | 65 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 66 | do renderQuality <- SDL.get SDL.HintRenderScaleQuality 67 | when (renderQuality /= SDL.ScaleLinear) $ 68 | putStrLn "Warning: Linear texture filtering not enabled!" 69 | 70 | window <- 71 | SDL.createWindow 72 | "SDL Tutorial" 73 | SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight} 74 | SDL.showWindow window 75 | 76 | renderer <- 77 | SDL.createRenderer 78 | window 79 | (-1) 80 | SDL.RendererConfig 81 | { SDL.rendererType = SDL.AcceleratedVSyncRenderer 82 | , SDL.rendererTargetTexture = False 83 | } 84 | 85 | SDL.renderDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 86 | 87 | rumbleTexture <- loadTexture renderer "examples/lazyfoo/rumble.bmp" 88 | 89 | joystick <- getJoystick 90 | hapticDevice <- SDL.openHaptic (SDL.OpenHapticJoystick joystick) 91 | SDL.hapticRumbleInit hapticDevice 92 | 93 | let loop = do 94 | events <- SDL.pollEvents 95 | 96 | let (Any quit, Any buttonDown) = 97 | foldMap (\case 98 | SDL.QuitEvent -> (Any True, mempty) 99 | SDL.KeyboardEvent e -> 100 | if | SDL.keyboardEventKeyMotion e == SDL.Pressed -> 101 | case SDL.keysymScancode (SDL.keyboardEventKeysym e) of 102 | SDL.ScancodeEscape -> (Any True, mempty) 103 | _ -> mempty 104 | | otherwise -> mempty 105 | SDL.JoyButtonEvent e -> 106 | if | SDL.joyButtonEventState e /= 0 -> (mempty, Any True) 107 | | otherwise -> mempty 108 | _ -> mempty) $ 109 | map SDL.eventPayload events 110 | 111 | when buttonDown $ SDL.hapticRumblePlay hapticDevice 0.75 500 112 | 113 | SDL.renderDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 114 | SDL.renderClear renderer 115 | 116 | renderTexture renderer rumbleTexture (P $ V2 0 0) Nothing Nothing Nothing Nothing 117 | 118 | SDL.renderPresent renderer 119 | 120 | unless quit loop 121 | 122 | loop 123 | 124 | SDL.closeHaptic hapticDevice 125 | SDL.closeJoystick joystick 126 | 127 | SDL.destroyRenderer renderer 128 | SDL.destroyWindow window 129 | SDL.quit 130 | -------------------------------------------------------------------------------- /examples/lazyfoo/Lesson43.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module Lazyfoo.Lesson43 (main) where 5 | 6 | import Prelude hiding (any, mapM_) 7 | import Control.Monad hiding (mapM_) 8 | import Data.Foldable hiding (elem) 9 | import Data.Maybe 10 | import Foreign.C.Types 11 | import SDL.Vect 12 | import SDL (($=)) 13 | import qualified SDL 14 | 15 | #if !MIN_VERSION_base(4,8,0) 16 | import Control.Applicative 17 | #endif 18 | 19 | screenWidth, screenHeight :: CInt 20 | (screenWidth, screenHeight) = (640, 480) 21 | 22 | data Texture = Texture SDL.Texture (V2 CInt) 23 | 24 | createBlank :: SDL.Renderer -> V2 CInt -> SDL.TextureAccess -> IO Texture 25 | createBlank r sz access = Texture <$> SDL.createTexture r SDL.RGBA8888 access sz <*> pure sz 26 | 27 | renderTexture :: SDL.Renderer -> Texture -> Point V2 CInt -> Maybe (SDL.Rectangle CInt) -> Maybe CDouble -> Maybe (Point V2 CInt) -> Maybe (V2 Bool) -> IO () 28 | renderTexture r (Texture t size) xy clip theta center flips = 29 | let dstSize = 30 | maybe size (\(SDL.Rectangle _ size') -> size') clip 31 | in SDL.copyEx r 32 | t 33 | clip 34 | (Just (SDL.Rectangle xy dstSize)) 35 | (fromMaybe 0 theta) 36 | center 37 | (fromMaybe (pure False) flips) 38 | 39 | setAsRenderTarget :: SDL.Renderer -> Maybe Texture -> IO () 40 | setAsRenderTarget r Nothing = SDL.rendererRenderTarget r $= Nothing 41 | setAsRenderTarget r (Just (Texture t _)) = SDL.rendererRenderTarget r $= Just t 42 | 43 | main :: IO () 44 | main = do 45 | SDL.initialize [SDL.InitVideo] 46 | 47 | SDL.HintRenderScaleQuality $= SDL.ScaleLinear 48 | do renderQuality <- SDL.get SDL.HintRenderScaleQuality 49 | when (renderQuality /= SDL.ScaleLinear) $ 50 | putStrLn "Warning: Linear texture filtering not enabled!" 51 | 52 | window <- 53 | SDL.createWindow 54 | "SDL Tutorial" 55 | SDL.defaultWindow {SDL.windowInitialSize = V2 screenWidth screenHeight} 56 | SDL.showWindow window 57 | 58 | renderer <- 59 | SDL.createRenderer 60 | window 61 | (-1) 62 | SDL.RendererConfig 63 | { SDL.rendererType = SDL.AcceleratedVSyncRenderer 64 | , SDL.rendererTargetTexture = False 65 | } 66 | 67 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 68 | 69 | targetTexture <- createBlank renderer (V2 screenWidth screenHeight) SDL.TextureAccessTarget 70 | 71 | let 72 | screenCenter = P (V2 (screenWidth `div` 2) (screenHeight `div` 2)) 73 | 74 | loop theta = do 75 | events <- map SDL.eventPayload <$> SDL.pollEvents 76 | let quit = SDL.QuitEvent `elem` events 77 | 78 | setAsRenderTarget renderer (Just targetTexture) 79 | 80 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 81 | SDL.clear renderer 82 | 83 | SDL.rendererDrawColor renderer $= V4 maxBound 0 0 maxBound 84 | SDL.fillRect renderer (Just $ SDL.Rectangle (P $ V2 (screenWidth `div` 4) (screenHeight `div` 4)) 85 | (V2 (screenWidth `div` 2) (screenHeight `div` 2))) 86 | 87 | SDL.rendererDrawColor renderer $= V4 0 0 maxBound maxBound 88 | SDL.drawRect renderer (Just (SDL.Rectangle (P $ V2 (screenWidth `div` 6) (screenHeight `div` 6)) 89 | (V2 (screenWidth * 2 `div` 3) (screenHeight * 2 `div` 3)))) 90 | 91 | SDL.rendererDrawColor renderer $= V4 0 maxBound 0 maxBound 92 | SDL.drawLine renderer (P (V2 0 (screenHeight `div` 2))) (P (V2 screenWidth (screenHeight `div` 2))) 93 | 94 | SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound 95 | for_ [0, 4 .. screenHeight] $ \i -> 96 | SDL.drawPoint renderer (P (V2 (screenWidth `div` 2) i)) 97 | 98 | setAsRenderTarget renderer Nothing 99 | 100 | renderTexture renderer targetTexture 0 Nothing (Just (fromIntegral theta)) (Just screenCenter) Nothing 101 | 102 | SDL.present renderer 103 | 104 | unless quit (loop (theta + 2 `mod` 360)) 105 | 106 | loop (0 :: Int) 107 | 108 | SDL.destroyWindow window 109 | SDL.quit 110 | -------------------------------------------------------------------------------- /examples/lazyfoo/animation.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/animation.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/arrow.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/arrow.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/background.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/background.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/button.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/button.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/colors.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/colors.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/dots.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/dots.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/down.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/down.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/fadein.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/fadein.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/fadeout.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/fadeout.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/foo.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/foo.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/hello_world.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/hello_world.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/left.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/left.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/press.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/press.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/right.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/right.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/rumble.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/rumble.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/stretch.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/stretch.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/texture.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/texture.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/up.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/up.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/viewport.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/viewport.bmp -------------------------------------------------------------------------------- /examples/lazyfoo/x.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/lazyfoo/x.bmp -------------------------------------------------------------------------------- /examples/twinklebear/Lesson01.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module TwinkleBear.Lesson01 (main) where 3 | 4 | 5 | import Prelude hiding (init) 6 | import SDL.Vect 7 | import qualified SDL 8 | 9 | import Paths_sdl2 (getDataFileName) 10 | 11 | main :: IO () 12 | main = do 13 | SDL.initializeAll 14 | 15 | let winConfig = SDL.defaultWindow { SDL.windowPosition = SDL.Absolute (P (V2 100 100)) 16 | , SDL.windowInitialSize = V2 640 480 } 17 | 18 | rdrConfig = SDL.RendererConfig { SDL.rendererType = SDL.AcceleratedVSyncRenderer 19 | , SDL.rendererTargetTexture = True } 20 | 21 | window <- SDL.createWindow "Hello World!" winConfig 22 | renderer <- SDL.createRenderer window (-1) rdrConfig 23 | 24 | bmp <- getDataFileName "examples/twinklebear/hello.bmp" >>= SDL.loadBMP 25 | tex <- SDL.createTextureFromSurface renderer bmp 26 | SDL.freeSurface bmp 27 | 28 | SDL.clear renderer 29 | SDL.copy renderer tex Nothing Nothing 30 | SDL.present renderer 31 | 32 | SDL.delay 2000 33 | 34 | SDL.destroyTexture tex 35 | SDL.destroyRenderer renderer 36 | SDL.destroyWindow window 37 | 38 | SDL.quit 39 | -------------------------------------------------------------------------------- /examples/twinklebear/Lesson02.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module TwinkleBear.Lesson02 (main) where 4 | 5 | import Prelude hiding (init) 6 | import Control.Monad 7 | import Foreign.C.Types 8 | import SDL.Vect 9 | import qualified SDL 10 | 11 | import Paths_sdl2 (getDataFileName) 12 | 13 | #if !MIN_VERSION_base(4,8,0) 14 | import Control.Applicative 15 | #endif 16 | 17 | screenWidth, screenHeight :: CInt 18 | (screenWidth, screenHeight) = (640, 480) 19 | 20 | 21 | data RenderPos = Centered | At (Point V2 CInt) 22 | 23 | 24 | loadTexture :: SDL.Renderer -> FilePath -> IO SDL.Texture 25 | loadTexture renderer path = do 26 | bmp <- SDL.loadBMP path 27 | SDL.createTextureFromSurface renderer bmp <* SDL.freeSurface bmp 28 | 29 | 30 | renderTexture :: SDL.Renderer -> SDL.Texture -> RenderPos -> IO () 31 | renderTexture renderer tex pos = do 32 | ti <- SDL.queryTexture tex 33 | let (w, h) = (SDL.textureWidth ti, SDL.textureHeight ti) 34 | pos' = case pos of 35 | At p -> p 36 | Centered -> let cntr a b = (a - b) `div` 2 37 | in P $ V2 (cntr screenWidth w) (cntr screenHeight h) 38 | extent = V2 w h 39 | SDL.copy renderer tex Nothing (Just $ SDL.Rectangle pos' extent) 40 | 41 | 42 | renderTiledBackground :: SDL.Renderer -> SDL.Texture -> IO () 43 | renderTiledBackground renderer tex = do 44 | ti <- SDL.queryTexture tex 45 | let (w, h) = (SDL.textureWidth ti, SDL.textureHeight ti) 46 | grid = [ At . P $ V2 (x*w) (y*h) | x <- [ 0..screenWidth `div` w ], 47 | y <- [ 0..screenHeight `div` h ]] 48 | forM_ grid (renderTexture renderer tex) 49 | 50 | 51 | main :: IO () 52 | main = do 53 | SDL.initializeAll 54 | 55 | let winConfig = SDL.defaultWindow { SDL.windowInitialSize = V2 screenWidth screenHeight } 56 | rdrConfig = SDL.defaultRenderer { SDL.rendererType = SDL.AcceleratedRenderer } 57 | 58 | window <- SDL.createWindow "Lesson 2" winConfig 59 | renderer <- SDL.createRenderer window (-1) rdrConfig 60 | 61 | background <- getDataFileName "examples/twinklebear/background.bmp" >>= loadTexture renderer 62 | image <- getDataFileName "examples/twinklebear/smiley.bmp" >>= loadTexture renderer 63 | 64 | renderTiledBackground renderer background 65 | renderTexture renderer image Centered 66 | SDL.present renderer 67 | 68 | SDL.delay 2000 69 | 70 | SDL.destroyTexture image 71 | SDL.destroyTexture background 72 | SDL.destroyRenderer renderer 73 | SDL.destroyWindow window 74 | 75 | SDL.quit 76 | -------------------------------------------------------------------------------- /examples/twinklebear/Lesson04.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module TwinkleBear.Lesson04 (main) where 4 | 5 | 6 | import Prelude hiding (init) 7 | import Control.Monad 8 | import Foreign.C.Types 9 | import SDL.Vect 10 | import qualified SDL 11 | 12 | import Paths_sdl2 (getDataFileName) 13 | 14 | #if !MIN_VERSION_base(4,8,0) 15 | import Control.Applicative 16 | #endif 17 | 18 | screenWidth, screenHeight :: CInt 19 | (screenWidth, screenHeight) = (640, 480) 20 | 21 | 22 | data RenderPos = Centered | At (Point V2 CInt) 23 | 24 | 25 | loadTexture :: SDL.Renderer -> FilePath -> IO SDL.Texture 26 | loadTexture renderer path = do 27 | bmp <- SDL.loadBMP path 28 | SDL.createTextureFromSurface renderer bmp <* SDL.freeSurface bmp 29 | 30 | 31 | renderTexture :: SDL.Renderer -> SDL.Texture -> RenderPos -> IO () 32 | renderTexture renderer tex pos = do 33 | ti <- SDL.queryTexture tex 34 | let (w, h) = (SDL.textureWidth ti, SDL.textureHeight ti) 35 | pos' = case pos of 36 | At p -> p 37 | Centered -> let cntr a b = (a - b) `div` 2 38 | in P $ V2 (cntr screenWidth w) (cntr screenHeight h) 39 | extent = V2 w h 40 | SDL.copy renderer tex Nothing (Just $ SDL.Rectangle pos' extent) 41 | 42 | 43 | main :: IO () 44 | main = do 45 | SDL.initialize [ SDL.InitVideo ] 46 | 47 | let winConfig = SDL.defaultWindow { SDL.windowInitialSize = V2 screenWidth screenHeight } 48 | 49 | window <- SDL.createWindow "Lesson 4" winConfig 50 | renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer 51 | 52 | image <- getDataFileName "examples/twinklebear/event-driven.bmp" >>= loadTexture renderer 53 | 54 | let loop = do 55 | renderTexture renderer image Centered 56 | SDL.present renderer 57 | 58 | quit <- fmap (\ev -> case SDL.eventPayload ev of 59 | SDL.QuitEvent -> True 60 | SDL.KeyboardEvent e -> SDL.keyboardEventKeyMotion e == SDL.Pressed 61 | SDL.MouseButtonEvent e -> SDL.mouseButtonEventMotion e == SDL.Pressed 62 | _ -> False) SDL.waitEvent 63 | 64 | unless quit loop 65 | 66 | loop 67 | 68 | SDL.destroyTexture image 69 | SDL.destroyRenderer renderer 70 | SDL.destroyWindow window 71 | 72 | SDL.quit 73 | -------------------------------------------------------------------------------- /examples/twinklebear/Lesson04a.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE MultiWayIf #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | module TwinkleBear.Lesson04a (main) where 7 | 8 | 9 | import Prelude hiding (init) 10 | import Control.Monad 11 | import Data.Monoid 12 | import Foreign.C.Types 13 | import SDL.Vect 14 | import qualified SDL 15 | 16 | import Paths_sdl2 (getDataFileName) 17 | 18 | #if !MIN_VERSION_base(4,8,0) 19 | import Control.Applicative 20 | import Data.Foldable 21 | #endif 22 | 23 | screenWidth, screenHeight :: CInt 24 | (screenWidth, screenHeight) = (640, 480) 25 | 26 | 27 | data RenderPos = Centered | At (Point V2 CInt) 28 | 29 | 30 | loadTexture :: SDL.Renderer -> FilePath -> IO SDL.Texture 31 | loadTexture renderer path = do 32 | bmp <- SDL.loadBMP path 33 | SDL.createTextureFromSurface renderer bmp <* SDL.freeSurface bmp 34 | 35 | 36 | renderTexture :: SDL.Renderer -> SDL.Texture -> RenderPos -> IO () 37 | renderTexture renderer tex pos = do 38 | ti <- SDL.queryTexture tex 39 | let (w, h) = (SDL.textureWidth ti, SDL.textureHeight ti) 40 | pos' = case pos of 41 | At p -> p 42 | Centered -> let cntr a b = (a - b) `div` 2 43 | in P $ V2 (cntr screenWidth w) (cntr screenHeight h) 44 | extent = V2 w h 45 | SDL.copy renderer tex Nothing (Just $ SDL.Rectangle pos' extent) 46 | 47 | 48 | main :: IO () 49 | main = do 50 | SDL.initialize [ SDL.InitVideo ] 51 | 52 | let winConfig = SDL.defaultWindow { SDL.windowInitialSize = V2 screenWidth screenHeight } 53 | 54 | window <- SDL.createWindow "Lesson 4a" winConfig 55 | renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer 56 | 57 | image <- getDataFileName "examples/twinklebear/ladybeetle.bmp" >>= loadTexture renderer 58 | 59 | let loop imgPos = do 60 | events <- SDL.pollEvents 61 | 62 | let (Any quit, Sum posDelta) = 63 | foldMap (\case 64 | SDL.QuitEvent -> (Any True, mempty) 65 | SDL.KeyboardEvent e -> 66 | if | SDL.keyboardEventKeyMotion e == SDL.Pressed -> 67 | case SDL.keysymScancode (SDL.keyboardEventKeysym e) of 68 | SDL.ScancodeUp -> (Any False, Sum (V2 0 (-10))) 69 | SDL.ScancodeDown -> (Any False, Sum (V2 0 10 )) 70 | SDL.ScancodeLeft -> (Any False, Sum (V2 (-10) 0 )) 71 | SDL.ScancodeRight -> (Any False, Sum (V2 10 0 )) 72 | SDL.ScancodeQ -> (Any True, mempty) 73 | _ -> mempty 74 | | otherwise -> mempty 75 | _ -> mempty) $ 76 | map SDL.eventPayload events 77 | 78 | imgPos' = imgPos + posDelta 79 | 80 | SDL.clear renderer 81 | renderTexture renderer image $ At (P imgPos') 82 | SDL.present renderer 83 | 84 | unless quit $ loop imgPos' 85 | 86 | loop $ V2 100 100 87 | 88 | SDL.destroyTexture image 89 | SDL.destroyRenderer renderer 90 | SDL.destroyWindow window 91 | 92 | SDL.quit 93 | -------------------------------------------------------------------------------- /examples/twinklebear/Lesson05.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE MultiWayIf #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | module TwinkleBear.Lesson05 (main) where 7 | 8 | import Prelude hiding (init) 9 | import Control.Applicative 10 | import Control.Monad 11 | import Data.Monoid 12 | import Foreign.C.Types 13 | import SDL.Vect 14 | import qualified SDL 15 | 16 | import Paths_sdl2 (getDataFileName) 17 | 18 | #if !MIN_VERSION_base(4,8,0) 19 | import Data.Foldable 20 | #endif 21 | 22 | screenWidth, screenHeight :: CInt 23 | (screenWidth, screenHeight) = (640, 480) 24 | 25 | spriteWidth, spriteHeight :: CInt 26 | (spriteWidth, spriteHeight) = (100, 100) 27 | 28 | 29 | type ClipRect = Maybe (SDL.Rectangle CInt) 30 | 31 | data RenderPos = Centered | At (Point V2 CInt) 32 | 33 | 34 | loadTexture :: SDL.Renderer -> FilePath -> IO SDL.Texture 35 | loadTexture renderer path = do 36 | bmp <- SDL.loadBMP path 37 | SDL.createTextureFromSurface renderer bmp <* SDL.freeSurface bmp 38 | 39 | 40 | renderTexture :: SDL.Renderer -> SDL.Texture -> ClipRect -> RenderPos -> IO () 41 | renderTexture renderer tex clipRect pos = do 42 | ti <- SDL.queryTexture tex 43 | let (w, h) = (SDL.textureWidth ti, SDL.textureHeight ti) 44 | pos' = case pos of 45 | At p -> p 46 | Centered -> let cntr a b = (a - b) `div` 2 47 | in P $ V2 (cntr screenWidth w) (cntr screenHeight h) 48 | extent = V2 w h 49 | SDL.copy renderer tex clipRect (Just $ SDL.Rectangle pos' extent) 50 | 51 | 52 | main :: IO () 53 | main = do 54 | SDL.initialize [ SDL.InitVideo ] 55 | 56 | let winConfig = SDL.defaultWindow { SDL.windowInitialSize = V2 screenWidth screenHeight } 57 | 58 | window <- SDL.createWindow "Lesson 5" winConfig 59 | renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer 60 | 61 | spriteSheet <- getDataFileName "examples/twinklebear/spritesheet.bmp" >>= loadTexture renderer 62 | 63 | let mkSprite x y = SDL.Rectangle (P (V2 (x * spriteWidth) (y * spriteHeight))) (V2 spriteWidth spriteHeight) 64 | spriteOne = mkSprite 0 0 65 | spriteTwo = mkSprite 0 1 66 | spriteThree = mkSprite 1 0 67 | spriteFour = mkSprite 1 1 68 | 69 | let loop spriteRect = do 70 | events <- SDL.pollEvents 71 | 72 | let (Any quit, Last newSpriteRect) = 73 | foldMap (\case 74 | SDL.QuitEvent -> (Any True, mempty) 75 | SDL.KeyboardEvent e -> 76 | if | SDL.keyboardEventKeyMotion e == SDL.Pressed -> 77 | case SDL.keysymScancode (SDL.keyboardEventKeysym e) of 78 | SDL.Scancode1 -> (Any False, Last (Just spriteOne)) 79 | SDL.Scancode2 -> (Any False, Last (Just spriteTwo)) 80 | SDL.Scancode3 -> (Any False, Last (Just spriteThree)) 81 | SDL.Scancode4 -> (Any False, Last (Just spriteFour)) 82 | SDL.ScancodeQ -> (Any True, mempty) 83 | _ -> mempty 84 | | otherwise -> mempty 85 | _ -> mempty) $ 86 | map SDL.eventPayload events 87 | 88 | spriteRect' = newSpriteRect <|> spriteRect 89 | 90 | SDL.clear renderer 91 | renderTexture renderer spriteSheet spriteRect' Centered 92 | SDL.present renderer 93 | 94 | unless quit $ loop spriteRect' 95 | 96 | loop $ Just spriteOne 97 | 98 | SDL.destroyRenderer renderer 99 | SDL.destroyWindow window 100 | 101 | SDL.quit 102 | -------------------------------------------------------------------------------- /examples/twinklebear/background.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/twinklebear/background.bmp -------------------------------------------------------------------------------- /examples/twinklebear/event-driven.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/twinklebear/event-driven.bmp -------------------------------------------------------------------------------- /examples/twinklebear/hello.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/twinklebear/hello.bmp -------------------------------------------------------------------------------- /examples/twinklebear/ladybeetle.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/twinklebear/ladybeetle.bmp -------------------------------------------------------------------------------- /examples/twinklebear/smiley.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/twinklebear/smiley.bmp -------------------------------------------------------------------------------- /examples/twinklebear/spritesheet.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-game/sdl2/cde36f4bfc6a362f67c843b3af4fcc872fa12ea1/examples/twinklebear/spritesheet.bmp -------------------------------------------------------------------------------- /include/sdlhelper.h: -------------------------------------------------------------------------------- 1 | #ifndef _HS_SDL2_HELPER_H_ 2 | #define _HS_SDL2_HELPER_H_ 3 | 4 | #include 5 | #include "SDL.h" 6 | 7 | int SDLHelper_GetEventBufferSize(void); 8 | SDL_Event *SDLHelper_GetEventBuffer(void); 9 | void SDLHelper_JoystickGetDeviceGUID (int device_index, SDL_JoystickGUID *guid); 10 | void SDLHelper_JoystickGetGUID (SDL_Joystick *joystick, SDL_JoystickGUID *guid); 11 | void SDLHelper_JoystickGetGUIDFromString (const char *pchGUID, SDL_JoystickGUID *guid); 12 | void SDLHelper_JoystickGetGUIDString (const SDL_JoystickGUID *guid, char *gszGUID, int cbGUID); 13 | 14 | void SDLHelper_GameControllerGetBindForAxis (SDL_GameController *gamecontroller, SDL_GameControllerAxis axis, SDL_GameControllerButtonBind *bind); 15 | void SDLHelper_GameControllerGetBindForButton (SDL_GameController *gamecontroller, SDL_GameControllerButton button, SDL_GameControllerButtonBind *bind); 16 | char *SDLHelper_GameControllerMappingForGUID (const SDL_JoystickGUID *guid); 17 | 18 | void SDLHelper_LogMessage (int category, SDL_LogPriority priority, const char *str); 19 | 20 | int SDLHelper_RWclose (SDL_RWops *ctx); 21 | size_t SDLHelper_RWread (SDL_RWops *ctx, void *ptr, size_t size, size_t maxnum); 22 | Sint64 SDLHelper_RWseek (SDL_RWops *ctx, Sint64 offset, int whence); 23 | Sint64 SDLHelper_RWtell (SDL_RWops *ctx); 24 | size_t SDLHelper_RWwrite (SDL_RWops *ctx, const void *ptr, size_t size, size_t num); 25 | 26 | int SDLHelper_SetError(const char *str); 27 | 28 | #endif 29 | -------------------------------------------------------------------------------- /scripts/find_missing_symbols.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | if [ $# -ne 1 ]; then 4 | cat < 7 | 8 | e.g. $(basename $0) src/SDL 9 | EOF 10 | exit 1 11 | fi 12 | 13 | SRCPATH="$1" 14 | 15 | TMPFILE_RAW=$(mktemp) 16 | TMPFILE_HS=$(mktemp) 17 | 18 | find "$SRCPATH/Raw" -name \*.hs \ 19 | -exec sed -n -e 's/^.*ccall.*SDL_\([[:alpha:]]\)\([^ "]\+\).*$/\L\1\E\2/p' '{}' + | \ 20 | sort | uniq >> "$TMPFILE_RAW" 21 | 22 | find "$SRCPATH" -name \*.hs -and -not -path \*Raw\* \ 23 | -exec sed -n -e 's/^\s*\([^ ]\+\) ::.*$/\1/p' '{}' + | \ 24 | sort | uniq >> "$TMPFILE_HS" 25 | 26 | # Sorry for the python ;-) 27 | python < {}; 3 | haskellPackages = pkgs.haskellPackages.override { 4 | overrides = self: super: { 5 | sdl2 = self.callPackage ./. { SDL2 = pkgs.SDL2.dev; }; 6 | }; 7 | }; 8 | in haskellPackages.sdl2.env 9 | -------------------------------------------------------------------------------- /src/Data/Bitmask.hs: -------------------------------------------------------------------------------- 1 | module Data.Bitmask (foldFlags) where 2 | 3 | import Prelude hiding (foldl) 4 | 5 | import Data.Bits 6 | import Data.Foldable 7 | 8 | foldFlags :: (Bits b, Foldable f, Num b) => (flag -> b) -> f flag -> b 9 | foldFlags f = foldl (\a b -> a .|. f b) 0 10 | -------------------------------------------------------------------------------- /src/SDL.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | 3 | SDL (Simple DirectMedia Layer) is a library for cross-platform development of 4 | interactive applications. SDL provides routines for managing windows, rendering 5 | graphics, processing sound, collecting input data, and much more. The Haskell 6 | @sdl2@ library provides both a high- and low-level API to interface with 7 | SDL. This module exports the high-level API, whereas "SDL.Raw" provides the 8 | lower-level bindings. 9 | 10 | -} 11 | module SDL 12 | ( -- * Getting Started 13 | -- $gettingStarted 14 | 15 | -- * Initialization 16 | module SDL.Init 17 | 18 | -- * Modules 19 | , module SDL.Audio 20 | , module SDL.Event 21 | , module SDL.Filesystem 22 | , module SDL.Hint 23 | , module SDL.Input 24 | , module SDL.Power 25 | , module SDL.Time 26 | , module SDL.Vect 27 | , module SDL.Video 28 | 29 | -- * Error Handling 30 | , module SDL.Exception 31 | 32 | -- * Working with State Variables 33 | -- $stateVars 34 | , get, ($=), ($~) 35 | -- ** Strict modification 36 | , ($=!), ($~!) 37 | ) where 38 | 39 | import Data.StateVar 40 | import SDL.Audio 41 | import SDL.Event 42 | import SDL.Exception 43 | import SDL.Filesystem 44 | import SDL.Hint 45 | import SDL.Init 46 | import SDL.Input 47 | import SDL.Power 48 | import SDL.Time 49 | import SDL.Vect 50 | import SDL.Video 51 | 52 | {- $gettingStarted 53 | 54 | The "SDL" module exports a high-level Haskell-like abstraction to use the library. SDL is a cross-platform development library designed to provide low level access to audio, keyboard, mouse, joystick, and graphics hardware via OpenGL and Direct3D. 55 | 56 | To get started, import "SDL" and begin by initializing the subsystems you need: 57 | 58 | @ 59 | import "SDL" 60 | 61 | main :: IO () 62 | main = do 63 | 'initializeAll' 64 | @ 65 | 66 | Next, you can create a 'Window' by using 'createWindow' 67 | 68 | @ 69 | window <- 'createWindow' "My SDL Application" 'defaultWindow' 70 | @ 71 | 72 | If you wish to use SDL's 2D graphics API, you can also create a 'Renderer': 73 | 74 | @ 75 | renderer <- 'createRenderer' window (-1) 'defaultRenderer' 76 | @ 77 | 78 | Then, we enter our main application loop: 79 | 80 | @ 81 | appLoop renderer 82 | @ 83 | 84 | Finally, once our appLoop has returned we destroy the 'Window' using 'destroyWindow': 85 | 86 | @ 87 | 'destroyWindow' window 88 | @ 89 | 90 | For the body of your application, we enter a loop. Inside this loop you should begin by collecting all events that 91 | have happened - these events will inform you about information such as key presses and mouse movement: 92 | 93 | @ 94 | appLoop :: 'Renderer' -> IO () 95 | appLoop renderer = do 96 | events <- 'pollEvents' 97 | @ 98 | 99 | Here @events@ is a list of 'Event' values. For our application we will check if the user pressed the q key, indicating they wish to quit the application 100 | 101 | @ 102 | let eventIsQPress event = 103 | case 'eventPayload' event of 104 | 'KeyboardEvent' keyboardEvent -> 105 | 'keyboardEventKeyMotion' keyboardEvent == 'Pressed' && 106 | 'keysymKeycode' ('keyboardEventKeysym' keyboardEvent) == 'KeycodeQ' 107 | _ -> False 108 | qPressed = any eventIsQPress events 109 | @ 110 | 111 | In our @appLoop@ we process events and then update the screen accordingly. Here we simply use the 'Renderer' 112 | to clear the screen to blue: 113 | 114 | @ 115 | 'rendererDrawColor' renderer '$=' V4 0 0 255 255 116 | 'clear' renderer 117 | 'present' renderer 118 | @ 119 | 120 | If q was not pressed, we loop again. Otherwise, we exit the loop: 121 | 122 | @ 123 | unless qPressed (appLoop renderer) 124 | @ 125 | 126 | To recap, here is our full application 127 | 128 | @ 129 | 130 | \{\-\# LANGUAGE OverloadedStrings \#\-\} 131 | module "Main" where 132 | 133 | import "SDL" 134 | import "Linear" (V4(..)) 135 | import "Control.Monad" (unless) 136 | 137 | main :: IO () 138 | main = do 139 | 'initializeAll' 140 | window <- 'createWindow' "My SDL Application" 'defaultWindow' 141 | renderer <- 'createRenderer' window (-1) 'defaultRenderer' 142 | appLoop renderer 143 | destroyWindow window 144 | 145 | appLoop :: 'Renderer' -> IO () 146 | appLoop renderer = do 147 | events <- 'pollEvents' 148 | let eventIsQPress event = 149 | case 'eventPayload' event of 150 | 'KeyboardEvent' keyboardEvent -> 151 | 'keyboardEventKeyMotion' keyboardEvent == 'Pressed' && 152 | 'keysymKeycode' ('keyboardEventKeysym' keyboardEvent) == 'KeycodeQ' 153 | _ -> False 154 | qPressed = any eventIsQPress events 155 | 'rendererDrawColor' renderer '$=' V4 0 0 255 255 156 | 'clear' renderer 157 | 'present' renderer 158 | unless qPressed (appLoop renderer) 159 | @ 160 | 161 | -} 162 | 163 | {- $stateVars 164 | 165 | The SDL API is moderately stateful. For the places where there is state that can be both read and changed, we use an abstraction provided by "Data.StateVar". This module exposes the 'StateVar' type, which models a mutable variable. You can query the contents of a 'StateVar' with 'get', and you can replace the contents of 'StateVar' with the infix assignment operator '$='. 166 | 167 | -} 168 | -------------------------------------------------------------------------------- /src/SDL/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | module SDL.Exception 5 | ( SDLException(..) 6 | ) where 7 | 8 | import Control.Exception 9 | import Data.Data (Data) 10 | import Data.Text (Text) 11 | import Data.Typeable (Typeable) 12 | import GHC.Generics (Generic) 13 | 14 | -- | Error details about a failure to call an SDL routine. Almost all functions in this library have the 15 | -- ability to produce exceptions of this type. Inspection should help you learn more about what has 16 | -- gone wrong. 17 | data SDLException 18 | = -- | A call to a low-level SDL C function failed unexpectedly. 19 | SDLCallFailed 20 | {sdlExceptionCaller :: !Text 21 | -- ^ The Haskell routine that was trying to call a C function 22 | ,sdlFunction :: !Text 23 | -- ^ The C function that was called and produced an error 24 | ,sdlExceptionError :: !Text 25 | -- ^ SDL's understanding of what has gone wrong 26 | } 27 | | -- | An SDL C function was called with an unexpected argument. 28 | SDLUnexpectedArgument 29 | {sdlExceptionCaller :: !Text 30 | -- ^ The Haskell routine that was trying to call a C function 31 | ,sdlFunction :: !Text 32 | -- ^ The C function that was called and produced an error 33 | ,sdlUnknownValue :: !String 34 | -- ^ The argument that SDL failed to understand 35 | } 36 | | -- | A hint was attempted to be set, but SDL does not know about this hint. 37 | SDLUnknownHintValue 38 | {sdlHint :: !String 39 | -- ^ The hint that could not be set 40 | ,sdlUnknownValue :: !String 41 | -- ^ The value that could not be set 42 | } 43 | deriving (Data,Eq,Generic,Ord,Read,Show,Typeable) 44 | 45 | instance Exception SDLException 46 | -------------------------------------------------------------------------------- /src/SDL/Filesystem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP#-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module SDL.Filesystem 5 | ( -- * Filesystem Paths 6 | getBasePath 7 | , getPrefPath 8 | ) where 9 | 10 | import Control.Exception 11 | import Control.Monad.IO.Class (MonadIO, liftIO) 12 | import Data.Text (Text) 13 | import Foreign.Marshal.Alloc 14 | import SDL.Internal.Exception 15 | import qualified Data.ByteString as BS 16 | import qualified Data.Text.Encoding as Text 17 | import qualified SDL.Raw.Filesystem as Raw 18 | 19 | #if !MIN_VERSION_base(4,8,0) 20 | import Control.Applicative 21 | #endif 22 | 23 | -- | An absolute path to the application data directory. 24 | -- 25 | -- The path is guaranteed to end with a path separator. 26 | -- 27 | -- Throws 'SDLException' on failure, or if the platform does not implement this 28 | -- functionality. 29 | getBasePath :: MonadIO m => m Text 30 | getBasePath = liftIO $ mask_ $ do 31 | cpath <- throwIfNull "SDL.Filesystem.getBasePath" "SDL_GetBasePath" 32 | Raw.getBasePath 33 | finally (Text.decodeUtf8 <$> BS.packCString cpath) (free cpath) 34 | 35 | -- | A path to a unique per user and per application directory for the given 36 | -- organization and application name, intended for writing preferences and 37 | -- other personal files. 38 | -- 39 | -- The path is guaranteed to end with a path separator. 40 | -- 41 | -- You should assume the path returned by this function is the only safe place 42 | -- to write files to. 43 | -- 44 | -- Throws 'SDLException' on failure. 45 | getPrefPath :: MonadIO m => Text -> Text -> m Text 46 | getPrefPath organization application = liftIO $ mask_ $ do 47 | cpath <- throwIfNull "SDL.Filesystem.getPrefPath" "SDL_GetPrefPath" $ 48 | BS.useAsCString (Text.encodeUtf8 organization) $ \org -> 49 | BS.useAsCString (Text.encodeUtf8 application) $ \app -> 50 | Raw.getPrefPath org app 51 | finally (Text.decodeUtf8 <$> BS.packCString cpath) (free cpath) 52 | -------------------------------------------------------------------------------- /src/SDL/Haptic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE PatternSynonyms #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | 7 | module SDL.Haptic 8 | ( AvailableHapticDevice 9 | , availableHapticDeviceName 10 | , availableHapticDeviceIds 11 | , OpenHapticDevice(..) 12 | , openHaptic 13 | , closeHaptic 14 | , hapticRumbleInit 15 | , hapticRumblePlay 16 | , hapticRumbleStop 17 | , HapticDevice 18 | , hapticDeviceName 19 | , hapticDeviceNumAxes 20 | , Effect(..) 21 | , EffectEnvelope(..) 22 | , EffectType(..) 23 | , uploadEffect 24 | , runEffect 25 | ) where 26 | 27 | import Control.Monad.IO.Class (MonadIO, liftIO) 28 | import Data.Data (Data) 29 | import Data.Text (Text) 30 | import Data.Traversable (for) 31 | import Data.Typeable 32 | import Foreign 33 | import Foreign.C 34 | import GHC.Generics (Generic) 35 | import SDL.Internal.Types (Joystick(..)) 36 | import qualified Data.ByteString as BS 37 | import qualified Data.Text.Encoding as Text 38 | import qualified Data.Vector as V 39 | import qualified SDL.Exception as SDLEx 40 | import qualified SDL.Raw as Raw 41 | 42 | #if !MIN_VERSION_base(4,8,0) 43 | import Control.Applicative 44 | #endif 45 | 46 | data AvailableHapticDevice = AvailableHapticDevice 47 | { availableHapticDeviceName :: Text 48 | , availableHapticDeviceIndex :: CInt 49 | } deriving (Eq, Generic, Ord, Read, Show, Typeable) 50 | 51 | availableHapticDeviceIds :: MonadIO m => m (V.Vector AvailableHapticDevice) 52 | availableHapticDeviceIds = liftIO $ do 53 | n <- SDLEx.throwIfNeg "SDL.Haptic.availableHapticDevices" "SDL_NumHaptics" Raw.numHaptics 54 | fmap V.fromList $ 55 | for [0 .. (n - 1)] $ \i -> do 56 | cstr <- SDLEx.throwIfNull "SDL.Haptic.availableHapticDevices" "SDL_HapticName" $ 57 | Raw.hapticName i 58 | name <- Text.decodeUtf8 <$> BS.packCString cstr 59 | return (AvailableHapticDevice name i) 60 | 61 | data OpenHapticDevice = OpenHapticMouse | OpenHapticJoystick Joystick | OpenHapticDevice AvailableHapticDevice 62 | deriving (Eq, Generic, Ord, Show, Typeable) 63 | 64 | data HapticDevice = HapticDevice 65 | { hapticDevicePtr :: Raw.Haptic 66 | , hapticDeviceName :: Text 67 | , hapticDeviceNumAxes :: CInt 68 | } deriving (Eq, Ord, Show, Typeable) 69 | 70 | openHaptic :: MonadIO m => OpenHapticDevice -> m HapticDevice 71 | openHaptic o = liftIO $ do 72 | ptr <- 73 | case o of 74 | OpenHapticMouse -> 75 | SDLEx.throwIfNull "SDL.Haptic.openHaptic" "SDL_OpenHapticFromMouse" $ 76 | Raw.hapticOpenFromMouse 77 | 78 | OpenHapticJoystick j -> 79 | SDLEx.throwIfNull "SDL.Haptic.openHaptic" "SDL_OpenHapticFromJoystick" $ 80 | Raw.hapticOpenFromJoystick (joystickPtr j) 81 | 82 | OpenHapticDevice d -> 83 | SDLEx.throwIfNull "SDL.Haptic.openHaptic" "SDL_OpenHaptic" $ 84 | Raw.hapticOpen (availableHapticDeviceIndex d) 85 | 86 | i <- SDLEx.throwIfNeg "SDL.Haptic.openHaptic" "SDL_HapticIndex" $ 87 | Raw.hapticIndex ptr 88 | 89 | n <- do 90 | cstr <- SDLEx.throwIfNull "SDL.Haptic.openHaptic" "SDL_HapticName" $ 91 | Raw.hapticName i 92 | Text.decodeUtf8 <$> BS.packCString cstr 93 | 94 | axes <- SDLEx.throwIfNeg "SDL.Haptic.openHaptic" "SDL_HapticNumAxes" $ 95 | Raw.hapticNumAxes ptr 96 | 97 | return (HapticDevice ptr n axes) 98 | 99 | closeHaptic :: MonadIO m => HapticDevice -> m () 100 | closeHaptic (HapticDevice h _ _) = Raw.hapticClose h 101 | 102 | hapticRumbleInit :: MonadIO m => HapticDevice -> m () 103 | hapticRumbleInit (HapticDevice h _ _) = 104 | liftIO $ 105 | SDLEx.throwIfNeg_ "SDL.Haptic.hapticRumbleInit" "SDL_HapticRumbleInit" $ 106 | Raw.hapticRumbleInit h 107 | 108 | hapticRumblePlay :: MonadIO m => HapticDevice -> CFloat -> Word32 -> m () 109 | hapticRumblePlay (HapticDevice h _ _) strength length = 110 | liftIO $ 111 | SDLEx.throwIfNot0_ "SDL.Haptic.hapticRumblePlay" "SDL_HapticRumblePlay" $ 112 | Raw.hapticRumblePlay h strength length 113 | 114 | hapticRumbleStop :: MonadIO m => HapticDevice -> m () 115 | hapticRumbleStop (HapticDevice h _ _) = 116 | liftIO $ 117 | SDLEx.throwIfNot0_ "SDL.Haptic.hapticRumbleStop" "SDL_HapticRumbleStop" $ 118 | Raw.hapticRumbleStop h 119 | 120 | newtype EffectId = EffectId CInt 121 | 122 | uploadEffect :: (MonadIO m) => HapticDevice -> Effect -> m EffectId 123 | uploadEffect (HapticDevice h _ _) effect = 124 | liftIO (do ptr <- 125 | new (case effectType effect of 126 | HapticConstant dir lev (EffectEnvelope attackLen attackLev fadeLen fadeLev) -> 127 | Raw.HapticConstant {Raw.hapticEffectType = Raw.SDL_HAPTIC_CONSTANT 128 | ,Raw.hapticConstantLength = effectLength effect 129 | ,Raw.hapticConstantDelay = effectDelay effect 130 | ,Raw.hapticConstantButton = effectButton effect 131 | ,Raw.hapticConstantInterval = effectInterval effect 132 | ,Raw.hapticConstantLevel = lev 133 | ,Raw.hapticConstantAttackLength = attackLen 134 | ,Raw.hapticConstantAttackLevel = attackLev 135 | ,Raw.hapticConstantFadeLength = fadeLen 136 | ,Raw.hapticConstantFadeLevel = fadeLev 137 | ,Raw.hapticConstantDirection = dir} 138 | HapticPeriodic shape dir period mag offset phase (EffectEnvelope attackLen attackLev fadeLen fadeLev) -> 139 | Raw.HapticPeriodic {Raw.hapticEffectType = 140 | case shape of 141 | HapticSine -> 2 142 | ,Raw.hapticPeriodicLength = effectLength effect 143 | ,Raw.hapticPeriodicDelay = effectDelay effect 144 | ,Raw.hapticPeriodicButton = effectButton effect 145 | ,Raw.hapticPeriodicInterval = effectInterval effect 146 | , 147 | --,Raw.hapticPeriodicLevel = lev 148 | Raw.hapticPeriodicAttackLength = attackLen 149 | ,Raw.hapticPeriodicAttackLevel = attackLev 150 | ,Raw.hapticPeriodicFadeLength = fadeLen 151 | ,Raw.hapticPeriodicFadeLevel = fadeLev 152 | ,Raw.hapticPeriodicDirection = dir 153 | ,Raw.hapticPeriodicMagnitude = mag 154 | ,Raw.hapticPeriodicPeriod = period 155 | ,Raw.hapticPeriodicOffset = offset 156 | ,Raw.hapticPeriodicPhase = phase}) 157 | fmap EffectId 158 | (SDLEx.throwIfNeg "SDL.Haptic.uploadEffect" 159 | "SDL_HapticNewEffect" 160 | (Raw.hapticNewEffect h ptr))) 161 | 162 | runEffect :: (Functor m, MonadIO m) => HapticDevice -> EffectId -> Word32 -> m () 163 | runEffect (HapticDevice h _ _) (EffectId e) x = 164 | SDLEx.throwIfNeg_ "SDL.Haptic.runEffect" 165 | "SDL_HapticRunEffect" 166 | (Raw.hapticRunEffect h e x) 167 | 168 | data EffectEnvelope = EffectEnvelope 169 | { envelopeAttackLength :: Word16 170 | , envelopeAttackLevel :: Word16 171 | , envelopeFadeLength :: Word16 172 | , envelopeFadeLevel :: Word16 173 | } deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) 174 | 175 | data Effect = Haptic 176 | { effectLength :: Word32 177 | , effectDelay :: Word16 178 | , effectButton :: Word16 179 | , effectInterval :: Word16 180 | , effectType :: EffectType 181 | } deriving (Eq, Generic, Show, Typeable) 182 | 183 | data EffectShape 184 | = HapticSine 185 | | HapticSquare 186 | | HapticTriangle 187 | | HapticSawtoothUp 188 | | HapticSawtoothDown 189 | deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) 190 | 191 | data ConditionType = Spring | Damper | Inertia | Friction 192 | deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) 193 | 194 | data EffectType 195 | = HapticConstant {hapticConstantDirection :: Raw.HapticDirection 196 | ,hapticConstantLevel :: Int16 197 | ,hapticConstantEnvelope :: EffectEnvelope} 198 | | HapticPeriodic {hapticPeriodicShape :: EffectShape 199 | ,hapticPeriodicDirection :: Raw.HapticDirection 200 | ,hapticPeriodicPeriod :: Word16 201 | ,hapticPeriodicMagnitude :: Int16 202 | ,hapticPeriodicOffset :: Int16 203 | ,hapticPeriodicPhase :: Word16 204 | ,hapticPeriodicEnvelope :: EffectEnvelope} 205 | | HapticCondition {hapticConditionType :: ConditionType 206 | ,hapticConditionRightSat :: [Word16] 207 | ,hapticConditionLeftSat :: [Word16] 208 | ,hapticConditionRightCoeff :: [Int16] 209 | ,hapticConditionLeftCoeff :: [Int16] 210 | ,hapticConditionDeadband :: [Word16] 211 | ,hapticConditionCenter :: [Int16]} 212 | | HapticRamp {hapticRampDirection :: Raw.HapticDirection 213 | ,hapticRampStart :: Int16 214 | ,hapticRampEnd :: Int16 215 | ,hapticRampEnvelope :: EffectEnvelope} 216 | | HapticLeftRight {hapticLeftRightLength :: Word32 217 | ,hapticLeftRightLargeMagnitude :: Word16 218 | ,hapticLeftRightSmallMagnitude :: Word16} 219 | | HapticCustom {hapticCustomDirection :: Raw.HapticDirection 220 | ,hapticCustomChannels :: Word8 221 | ,hapticCustomPeriod :: Word16 222 | ,hapticCustomSamples :: V.Vector Word16 223 | ,hapticCustomEnvelope :: EffectEnvelope} 224 | deriving (Eq, Generic, Show, Typeable) 225 | -------------------------------------------------------------------------------- /src/SDL/Init.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | 8 | module SDL.Init 9 | ( initialize 10 | , initializeAll 11 | , InitFlag(..) 12 | , quit 13 | , version 14 | ) where 15 | 16 | import Control.Monad.IO.Class (MonadIO, liftIO) 17 | import Data.Bitmask (foldFlags) 18 | import Data.Data (Data) 19 | import Data.Typeable 20 | import Data.Word 21 | import Foreign.Marshal.Alloc 22 | import Foreign.Storable 23 | import GHC.Generics 24 | import SDL.Internal.Exception 25 | import SDL.Internal.Numbered 26 | import qualified SDL.Raw as Raw 27 | 28 | #if !MIN_VERSION_base(4,8,0) 29 | import Data.Foldable 30 | #endif 31 | 32 | data InitFlag 33 | = InitTimer 34 | | InitAudio 35 | | InitVideo 36 | | InitJoystick 37 | | InitHaptic 38 | | InitGameController 39 | | InitEvents 40 | deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) 41 | 42 | instance ToNumber InitFlag Word32 where 43 | toNumber InitTimer = Raw.SDL_INIT_TIMER 44 | toNumber InitAudio = Raw.SDL_INIT_AUDIO 45 | toNumber InitVideo = Raw.SDL_INIT_VIDEO 46 | toNumber InitJoystick = Raw.SDL_INIT_JOYSTICK 47 | toNumber InitHaptic = Raw.SDL_INIT_HAPTIC 48 | toNumber InitGameController = Raw.SDL_INIT_GAMECONTROLLER 49 | toNumber InitEvents = Raw.SDL_INIT_EVENTS 50 | 51 | -- | Initializes SDL and the given subsystems. Do not call any SDL functions 52 | -- prior to this one, unless otherwise documented that you may do so. 53 | -- 54 | -- You may call this function again with additional subsystems to initialize. 55 | -- 56 | -- Throws 'SDLEx.SDLException' if initialization fails. 57 | initialize :: (Foldable f, Functor m, MonadIO m) => f InitFlag -> m () 58 | initialize flags = 59 | throwIfNeg_ "SDL.Init.init" "SDL_Init" $ 60 | Raw.init (foldFlags toNumber flags) 61 | 62 | -- | Equivalent to @'initialize' ['minBound' .. 'maxBound']@. 63 | initializeAll :: (Functor m, MonadIO m) => m () 64 | initializeAll = initialize [minBound .. maxBound] 65 | 66 | -- | Quit and shutdown SDL, freeing any resources that may have been in use. 67 | -- Do not call any SDL functions after you've called this function, unless 68 | -- otherwise documented that you may do so. 69 | quit :: MonadIO m => m () 70 | quit = Raw.quit 71 | 72 | -- | The major, minor, and patch versions of the SDL library linked with. 73 | -- Does not require initialization. 74 | version :: (Integral a, MonadIO m) => m (a, a, a) 75 | version = liftIO $ do 76 | Raw.Version major minor patch <- alloca $ \v -> Raw.getVersion v >> peek v 77 | return (fromIntegral major, fromIntegral minor, fromIntegral patch) 78 | -------------------------------------------------------------------------------- /src/SDL/Input.hs: -------------------------------------------------------------------------------- 1 | module SDL.Input 2 | ( module SDL.Input.Joystick 3 | , module SDL.Input.Keyboard 4 | , module SDL.Input.Mouse 5 | ) where 6 | 7 | 8 | import SDL.Input.Joystick 9 | import SDL.Input.Keyboard 10 | import SDL.Input.Mouse 11 | -------------------------------------------------------------------------------- /src/SDL/Input/Joystick.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE PatternSynonyms #-} 7 | 8 | module SDL.Input.Joystick 9 | ( numJoysticks 10 | , availableJoysticks 11 | , JoystickDevice(..) 12 | 13 | , openJoystick 14 | , closeJoystick 15 | 16 | , getJoystickID 17 | , Joystick 18 | , JoyButtonState(..) 19 | , buttonPressed 20 | , ballDelta 21 | , axisPosition 22 | , numAxes 23 | , numButtons 24 | , numBalls 25 | , JoyHatPosition(..) 26 | , getHat 27 | , numHats 28 | , JoyDeviceConnection(..) 29 | ) where 30 | 31 | import Control.Monad.IO.Class (MonadIO, liftIO) 32 | import Data.Data (Data) 33 | import Data.Int 34 | import Data.Text (Text) 35 | import Data.Traversable (for) 36 | import Data.Typeable 37 | import Data.Word 38 | import Foreign.C.Types 39 | import Foreign.Marshal.Alloc 40 | import Foreign.Storable 41 | import GHC.Generics (Generic) 42 | import SDL.Vect 43 | import SDL.Internal.Exception 44 | import SDL.Internal.Numbered 45 | import SDL.Internal.Types 46 | import qualified Data.ByteString as BS 47 | import qualified Data.Text.Encoding as Text 48 | import qualified Data.Vector as V 49 | import qualified SDL.Raw as Raw 50 | 51 | #if !MIN_VERSION_base(4,8,0) 52 | import Control.Applicative 53 | #endif 54 | 55 | -- | A description of joystick that can be opened using 'openJoystick'. To retrieve a list of 56 | -- connected joysticks, use 'availableJoysticks'. 57 | data JoystickDevice = JoystickDevice 58 | { joystickDeviceName :: Text 59 | , joystickDeviceId :: CInt 60 | } deriving (Eq, Generic, Read, Ord, Show, Typeable) 61 | 62 | -- | Identifies the state of a joystick button. 63 | data JoyButtonState = JoyButtonPressed | JoyButtonReleased 64 | deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) 65 | 66 | instance FromNumber JoyButtonState Word8 where 67 | fromNumber n = case n of 68 | Raw.SDL_PRESSED -> JoyButtonPressed 69 | Raw.SDL_RELEASED -> JoyButtonReleased 70 | _ -> JoyButtonReleased 71 | 72 | -- | Count the number of joysticks attached to the system. 73 | -- 74 | -- See @@ for C documentation. 75 | numJoysticks :: MonadIO m => m (CInt) 76 | numJoysticks = throwIfNeg "SDL.Input.Joystick.availableJoysticks" "SDL_NumJoysticks" Raw.numJoysticks 77 | 78 | -- | Enumerate all connected joysticks, retrieving a description of each. 79 | availableJoysticks :: MonadIO m => m (V.Vector JoystickDevice) 80 | availableJoysticks = liftIO $ do 81 | n <- numJoysticks 82 | fmap (V.fromList) $ 83 | for [0 .. (n - 1)] $ \i -> do 84 | cstr <- 85 | throwIfNull "SDL.Input.Joystick.availableJoysticks" "SDL_JoystickNameForIndex" $ 86 | Raw.joystickNameForIndex i 87 | name <- Text.decodeUtf8 <$> BS.packCString cstr 88 | return (JoystickDevice name i) 89 | 90 | -- | Open a joystick so that you can start receiving events from interaction with this joystick. 91 | -- 92 | -- See @@ for C documentation. 93 | openJoystick :: (Functor m,MonadIO m) 94 | => JoystickDevice -- ^ The device to open. Use 'availableJoysticks' to find 'JoystickDevices's 95 | -> m Joystick 96 | openJoystick (JoystickDevice _ x) = 97 | fmap Joystick $ 98 | throwIfNull "SDL.Input.Joystick.openJoystick" "SDL_OpenJoystick" $ 99 | Raw.joystickOpen x 100 | 101 | -- | Close a joystick previously opened with 'openJoystick'. 102 | -- 103 | -- See @@ for C documentation. 104 | closeJoystick :: MonadIO m => Joystick -> m () 105 | closeJoystick (Joystick j) = Raw.joystickClose j 106 | 107 | -- | Get the instance ID of an opened joystick. The instance ID is used to identify the joystick 108 | -- in future SDL events. 109 | -- 110 | -- See @@ for C documentation. 111 | getJoystickID :: MonadIO m => Joystick -> m Raw.JoystickID 112 | getJoystickID (Joystick j) = 113 | throwIfNeg "SDL.Input.Joystick.getJoystickID" "SDL_JoystickInstanceID" $ 114 | Raw.joystickInstanceID j 115 | 116 | -- | Determine if a given button is currently held. 117 | -- 118 | -- See @@ for C documentation. 119 | buttonPressed :: (Functor m, MonadIO m) 120 | => Joystick 121 | -> CInt -- ^ The index of the button. You can use 'numButtons' to determine how many buttons a given joystick has. 122 | -> m Bool 123 | buttonPressed (Joystick j) buttonIndex = (== 1) <$> Raw.joystickGetButton j buttonIndex 124 | 125 | -- | Get the ball axis change since the last poll. 126 | -- 127 | -- See @@ for C documentation. 128 | ballDelta :: MonadIO m 129 | => Joystick 130 | -> CInt -- ^ The index of the joystick ball. You can use 'numBalls' to determine how many balls a given joystick has. 131 | -> m (V2 CInt) 132 | ballDelta (Joystick j) ballIndex = liftIO $ 133 | alloca $ \xptr -> 134 | alloca $ \yptr -> do 135 | throwIfNeg_ "SDL.Input.Joystick.ballDelta" "SDL_JoystickGetBall" $ 136 | Raw.joystickGetBall j ballIndex xptr yptr 137 | 138 | V2 <$> peek xptr <*> peek yptr 139 | 140 | -- | Get the current state of an axis control on a joystick. 141 | -- 142 | -- Returns a 16-bit signed integer representing the current position of the axis. The state is a value ranging from -32768 to 32767. 143 | -- 144 | -- 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. 145 | -- 146 | -- Some joysticks use axes 2 and 3 for extra buttons. 147 | -- 148 | -- See @@ for C documentation. 149 | axisPosition :: MonadIO m => Joystick -> CInt -> m Int16 150 | axisPosition (Joystick j) axisIndex = Raw.joystickGetAxis j axisIndex 151 | 152 | -- | Get the number of general axis controls on a joystick. 153 | -- 154 | -- See @@ for C documentation. 155 | numAxes :: (MonadIO m) => Joystick -> m CInt 156 | numAxes (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numAxis" "SDL_JoystickNumAxes" (Raw.joystickNumAxes j) 157 | 158 | -- | Get the number of buttons on a joystick. 159 | -- 160 | -- See @@ for C documentation. 161 | numButtons :: (MonadIO m) => Joystick -> m CInt 162 | numButtons (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numButtons" "SDL_JoystickNumButtons" (Raw.joystickNumButtons j) 163 | 164 | -- | Get the number of trackballs on a joystick. 165 | -- 166 | -- See @@ for C documentation. 167 | numBalls :: (MonadIO m) => Joystick -> m CInt 168 | numBalls (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numBalls" "SDL_JoystickNumBalls" (Raw.joystickNumBalls j) 169 | 170 | -- | Identifies the state of the POV hat on a joystick. 171 | data JoyHatPosition 172 | = HatCentered -- ^ Centered position 173 | | HatUp -- ^ Up position 174 | | HatRight -- ^ Right position 175 | | HatDown -- ^ Down position 176 | | HatLeft -- ^ Left position 177 | | HatRightUp -- ^ Right-up position 178 | | HatRightDown -- ^ Right-down position 179 | | HatLeftUp -- ^ Left-up position 180 | | HatLeftDown -- ^ Left-down position 181 | deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) 182 | 183 | instance FromNumber JoyHatPosition Word8 where 184 | fromNumber n = case n of 185 | Raw.SDL_HAT_CENTERED -> HatCentered 186 | Raw.SDL_HAT_UP -> HatUp 187 | Raw.SDL_HAT_RIGHT -> HatRight 188 | Raw.SDL_HAT_DOWN -> HatDown 189 | Raw.SDL_HAT_LEFT -> HatLeft 190 | Raw.SDL_HAT_RIGHTUP -> HatRightUp 191 | Raw.SDL_HAT_RIGHTDOWN -> HatRightDown 192 | Raw.SDL_HAT_LEFTUP -> HatLeftUp 193 | Raw.SDL_HAT_LEFTDOWN -> HatLeftDown 194 | _ -> HatCentered 195 | 196 | -- | Get current position of a POV hat on a joystick. 197 | -- 198 | -- See @@ for C documentation. 199 | getHat :: (Functor m, MonadIO m) 200 | => Joystick 201 | -> CInt -- ^ The index of the POV hat. You can use 'numHats' to determine how many POV hats a given joystick has. 202 | -> m JoyHatPosition 203 | getHat (Joystick j) hatIndex = fromNumber <$> Raw.joystickGetHat j hatIndex 204 | 205 | -- | Get the number of POV hats on a joystick. 206 | -- 207 | -- See @@ for C documentation. 208 | numHats :: (MonadIO m) => Joystick -> m CInt 209 | numHats (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numHats" "SDL_JoystickNumHats" (Raw.joystickNumHats j) 210 | 211 | -- | Identifies whether a joystick has been connected or disconnected. 212 | data JoyDeviceConnection = JoyDeviceAdded | JoyDeviceRemoved 213 | deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) 214 | 215 | instance FromNumber JoyDeviceConnection Word32 where 216 | fromNumber n = case n of 217 | Raw.SDL_JOYDEVICEADDED -> JoyDeviceAdded 218 | Raw.SDL_JOYDEVICEREMOVED -> JoyDeviceRemoved 219 | _ -> JoyDeviceAdded 220 | -------------------------------------------------------------------------------- /src/SDL/Input/Keyboard.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | 6 | module SDL.Input.Keyboard 7 | ( -- * Keyboard Modifiers 8 | getModState 9 | , KeyModifier(..) 10 | 11 | , getKeyboardState 12 | 13 | -- * Text Input 14 | , startTextInput 15 | , stopTextInput 16 | 17 | -- * Screen Keyboard 18 | , hasScreenKeyboardSupport 19 | , isScreenKeyboardShown 20 | 21 | -- * Scancodes 22 | , getScancodeName 23 | , Scancode(..) 24 | 25 | -- * Keycodes 26 | , Keycode(..) 27 | 28 | -- * Keysym 29 | , Keysym(..) 30 | 31 | -- * Keycodes and Scancodes 32 | , module SDL.Input.Keyboard.Codes 33 | ) where 34 | 35 | import Control.Monad.IO.Class (MonadIO, liftIO) 36 | import Data.Bits 37 | import Data.Data (Data) 38 | import Data.Typeable 39 | import Data.Word 40 | import Foreign.C.String 41 | import Foreign.Marshal.Alloc 42 | import Foreign.Marshal.Array 43 | import Foreign.Storable 44 | import GHC.Generics (Generic) 45 | import SDL.Input.Keyboard.Codes 46 | import SDL.Internal.Numbered 47 | import SDL.Internal.Types 48 | import qualified Data.Vector as V 49 | import qualified SDL.Raw.Enum as Raw 50 | import qualified SDL.Raw.Event as Raw 51 | import qualified SDL.Raw.Types as Raw 52 | 53 | #if !MIN_VERSION_base(4,8,0) 54 | import Control.Applicative 55 | #endif 56 | 57 | -- | Get the current key modifier state for the keyboard. The key modifier state is a mask special keys that are held down. 58 | -- 59 | -- See @@ for C documentation. 60 | getModState :: (Functor m, MonadIO m) => m KeyModifier 61 | getModState = fromNumber <$> Raw.getModState 62 | 63 | -- | Information about which keys are currently held down. Use 'getModState' to generate this information. 64 | data KeyModifier = KeyModifier 65 | { keyModifierLeftShift :: Bool 66 | , keyModifierRightShift :: Bool 67 | , keyModifierLeftCtrl :: Bool 68 | , keyModifierRightCtrl :: Bool 69 | , keyModifierLeftAlt :: Bool 70 | , keyModifierRightAlt :: Bool 71 | , keyModifierLeftGUI :: Bool 72 | , keyModifierRightGUI :: Bool 73 | , keyModifierNumLock :: Bool 74 | , keyModifierCapsLock :: Bool 75 | , keyModifierAltGr :: Bool 76 | } deriving (Data, Eq, Ord, Read, Generic, Show, Typeable) 77 | 78 | instance FromNumber KeyModifier Word32 where 79 | fromNumber m' = let m = m' in KeyModifier 80 | { keyModifierLeftShift = m .&. Raw.KMOD_LSHIFT > 0 81 | , keyModifierRightShift = m .&. Raw.KMOD_RSHIFT > 0 82 | , keyModifierLeftCtrl = m .&. Raw.KMOD_LCTRL > 0 83 | , keyModifierRightCtrl = m .&. Raw.KMOD_RCTRL > 0 84 | , keyModifierLeftAlt = m .&. Raw.KMOD_LALT > 0 85 | , keyModifierRightAlt = m .&. Raw.KMOD_RALT > 0 86 | , keyModifierLeftGUI = m .&. Raw.KMOD_LGUI > 0 87 | , keyModifierRightGUI = m .&. Raw.KMOD_RGUI > 0 88 | , keyModifierNumLock = m .&. Raw.KMOD_NUM > 0 89 | , keyModifierCapsLock = m .&. Raw.KMOD_CAPS > 0 90 | , keyModifierAltGr = m .&. Raw.KMOD_MODE > 0 91 | } 92 | 93 | instance ToNumber KeyModifier Word32 where 94 | toNumber m = foldr (.|.) 0 95 | [ if keyModifierLeftShift m then Raw.KMOD_LSHIFT else 0 96 | , if keyModifierRightShift m then Raw.KMOD_RSHIFT else 0 97 | , if keyModifierLeftCtrl m then Raw.KMOD_LCTRL else 0 98 | , if keyModifierRightCtrl m then Raw.KMOD_RCTRL else 0 99 | , if keyModifierLeftAlt m then Raw.KMOD_LALT else 0 100 | , if keyModifierRightAlt m then Raw.KMOD_RALT else 0 101 | , if keyModifierLeftGUI m then Raw.KMOD_LGUI else 0 102 | , if keyModifierRightGUI m then Raw.KMOD_RGUI else 0 103 | , if keyModifierNumLock m then Raw.KMOD_NUM else 0 104 | , if keyModifierCapsLock m then Raw.KMOD_CAPS else 0 105 | , if keyModifierAltGr m then Raw.KMOD_MODE else 0 106 | ] 107 | 108 | -- | Set the rectangle used to type text inputs and start accepting text input 109 | -- events. 110 | -- 111 | -- See @@ for C documentation. 112 | startTextInput :: MonadIO m => Raw.Rect -> m () 113 | startTextInput rect = liftIO $ do 114 | alloca $ \ptr -> do 115 | poke ptr rect 116 | Raw.setTextInputRect ptr 117 | Raw.startTextInput 118 | 119 | -- | Stop receiving any text input events. 120 | -- 121 | -- See @@ for C documentation. 122 | stopTextInput :: MonadIO m => m () 123 | stopTextInput = Raw.stopTextInput 124 | 125 | -- | Check whether the platform has screen keyboard support. 126 | -- 127 | -- See @@ for C documentation. 128 | hasScreenKeyboardSupport :: MonadIO m => m Bool 129 | hasScreenKeyboardSupport = Raw.hasScreenKeyboardSupport 130 | 131 | -- | Check whether the screen keyboard is shown for the given window. 132 | -- 133 | -- See @@ for C documentation. 134 | isScreenKeyboardShown :: MonadIO m => Window -> m Bool 135 | isScreenKeyboardShown (Window w) = Raw.isScreenKeyboardShown w 136 | 137 | -- | Get a human-readable name for a scancode. If the scancode doesn't have a name this function returns the empty string. 138 | -- 139 | -- See @@ for C documentation. 140 | getScancodeName :: MonadIO m => Scancode -> m String 141 | getScancodeName scancode = liftIO $ do 142 | name <- Raw.getScancodeName $ toNumber scancode 143 | peekCString name 144 | 145 | -- | Information about a key press or key release event. 146 | data Keysym = Keysym 147 | { keysymScancode :: Scancode 148 | -- ^ The keyboard 'Scancode' 149 | , keysymKeycode :: Keycode 150 | -- ^ SDL's virtual key representation for this key 151 | , keysymModifier :: KeyModifier 152 | -- ^ A set of modifiers that were held at the time this data was generated 153 | } deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) 154 | 155 | -- | Get a snapshot of the current state of the keyboard. 156 | -- 157 | -- This computation generates a mapping from 'Scancode' to 'Bool' - evaluating the function at specific 'Scancode's will inform you as to whether or not that key was held down when 'getKeyboardState' was called. 158 | -- 159 | -- See @@ for C documentation. 160 | getKeyboardState :: MonadIO m => m (Scancode -> Bool) 161 | getKeyboardState = liftIO $ do 162 | alloca $ \nkeys -> do 163 | keyptr <- Raw.getKeyboardState nkeys 164 | n <- peek nkeys 165 | keys <- V.fromList <$> peekArray (fromIntegral n) keyptr 166 | return $ \scancode -> 1 == keys V.! fromIntegral (toNumber scancode) 167 | -------------------------------------------------------------------------------- /src/SDL/Internal/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module SDL.Internal.Exception 4 | ( fromC 5 | , getError 6 | , throwIf 7 | , throwIf_ 8 | , throwIf0 9 | , throwIfNeg 10 | , throwIfNeg_ 11 | , throwIfNot0 12 | , throwIfNot0_ 13 | , throwIfNull 14 | ) where 15 | 16 | import Control.Exception 17 | import Data.Maybe (fromMaybe) 18 | import Control.Monad 19 | import Control.Monad.IO.Class (MonadIO, liftIO) 20 | import Data.Text (Text) 21 | import Foreign (Ptr, nullPtr) 22 | import SDL.Exception 23 | import qualified Data.ByteString as BS 24 | import qualified Data.Text.Encoding as Text 25 | import qualified SDL.Raw as Raw 26 | 27 | #if !MIN_VERSION_base(4,8,0) 28 | import Control.Applicative 29 | #endif 30 | 31 | getError :: MonadIO m => m Text 32 | getError = liftIO $ do 33 | cstr <- Raw.getError 34 | Text.decodeUtf8 <$> BS.packCString cstr 35 | 36 | {-# INLINE throwIf #-} 37 | throwIf :: MonadIO m => (a -> Bool) -> Text -> Text -> m a -> m a 38 | throwIf f caller funName m = do 39 | a <- m 40 | liftIO $ when (f a) $ 41 | (SDLCallFailed caller funName <$> getError) >>= throwIO 42 | return a 43 | 44 | {-# INLINE throwIf_ #-} 45 | throwIf_ :: MonadIO m => (a -> Bool) -> Text -> Text -> m a -> m () 46 | throwIf_ f caller funName m = throwIf f caller funName m >> return () 47 | 48 | {-# INLINE throwIfNeg #-} 49 | throwIfNeg :: (MonadIO m, Num a, Ord a) => Text -> Text -> m a -> m a 50 | throwIfNeg = throwIf (< 0) 51 | 52 | {-# INLINE throwIfNeg_ #-} 53 | throwIfNeg_ :: (MonadIO m, Num a, Ord a) => Text -> Text -> m a -> m () 54 | throwIfNeg_ = throwIf_ (< 0) 55 | 56 | {-# INLINE throwIfNull #-} 57 | throwIfNull :: (MonadIO m) => Text -> Text -> m (Ptr a) -> m (Ptr a) 58 | throwIfNull = throwIf (== nullPtr) 59 | 60 | {-# INLINE throwIf0 #-} 61 | throwIf0 :: (Eq a, MonadIO m, Num a) => Text -> Text -> m a -> m a 62 | throwIf0 = throwIf (== 0) 63 | 64 | {-# INLINE throwIfNot0 #-} 65 | throwIfNot0 :: (Eq a, MonadIO m, Num a) => Text -> Text -> m a -> m a 66 | throwIfNot0 = throwIf (/= 0) 67 | 68 | {-# INLINE throwIfNot0_ #-} 69 | throwIfNot0_ :: (Eq a, MonadIO m, Num a) => Text -> Text -> m a -> m () 70 | throwIfNot0_ = throwIf_ (/= 0) 71 | 72 | fromC :: Show a => Text -> Text -> (a -> Maybe b) -> a -> b 73 | fromC caller funName f x = 74 | fromMaybe (throw (SDLUnexpectedArgument caller 75 | funName 76 | (show x))) 77 | (f x) 78 | -------------------------------------------------------------------------------- /src/SDL/Internal/Numbered.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | module SDL.Internal.Numbered 3 | ( FromNumber(..) 4 | , ToNumber(..) 5 | ) where 6 | 7 | class (Integral b) => FromNumber a b | a -> b where 8 | fromNumber :: b -> a 9 | 10 | class (Integral b) => ToNumber a b | a -> b where 11 | toNumber :: a -> b 12 | -------------------------------------------------------------------------------- /src/SDL/Internal/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | module SDL.Internal.Types 4 | ( Joystick(..) 5 | , GameController(..) 6 | , Window(..) 7 | , Renderer(..) 8 | ) where 9 | 10 | import Data.Data (Data) 11 | import Data.Typeable 12 | import GHC.Generics (Generic) 13 | 14 | import qualified SDL.Raw as Raw 15 | 16 | newtype Joystick = Joystick { joystickPtr :: Raw.Joystick } 17 | deriving (Data, Eq, Generic, Ord, Show, Typeable) 18 | 19 | newtype GameController = GameController 20 | { gameControllerPtr :: Raw.GameController } 21 | deriving (Data, Eq, Generic, Ord, Show, Typeable) 22 | 23 | newtype Window = Window (Raw.Window) 24 | deriving (Data, Eq, Generic, Ord, Show, Typeable) 25 | 26 | -- | An SDL rendering device. This can be created with 'SDL.Video.createRenderer'. 27 | newtype Renderer = Renderer Raw.Renderer 28 | deriving (Data, Eq, Generic, Ord, Show, Typeable) 29 | -------------------------------------------------------------------------------- /src/SDL/Power.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | module SDL.Power 7 | ( -- * Power Status 8 | getPowerInfo 9 | , PowerState(..) 10 | , BatteryState(..) 11 | , Charge(..) 12 | ) where 13 | 14 | import Control.Applicative 15 | import Control.Monad.IO.Class (MonadIO, liftIO) 16 | import Data.Data (Data) 17 | import Data.Typeable 18 | import Foreign.C.Types 19 | import Foreign.Marshal.Alloc 20 | import Foreign.Marshal.Utils 21 | import Foreign.Storable 22 | import GHC.Generics (Generic) 23 | 24 | import qualified SDL.Raw as Raw 25 | 26 | -- | Current power supply details. 27 | -- 28 | -- Throws 'SDLException' if the current power state can not be determined. 29 | -- 30 | -- See @@ for C documentation. 31 | getPowerInfo :: (Functor m, MonadIO m) => m PowerState 32 | getPowerInfo = 33 | liftIO $ 34 | alloca $ \secsPtr -> 35 | alloca $ \pctPtr -> do 36 | state <- Raw.getPowerInfo secsPtr pctPtr 37 | let peekCharge = liftA2 Charge (maybePeek peek secsPtr) (maybePeek peek pctPtr) 38 | case state of 39 | Raw.SDL_POWERSTATE_ON_BATTERY -> fmap (Battery Draining) peekCharge 40 | Raw.SDL_POWERSTATE_CHARGING -> fmap (Battery Charging) peekCharge 41 | Raw.SDL_POWERSTATE_CHARGED -> fmap (Battery Charged) peekCharge 42 | Raw.SDL_POWERSTATE_NO_BATTERY -> pure Mains 43 | _ -> pure UnknownPowerState 44 | 45 | -- | Information about the power supply for the user's environment 46 | data PowerState 47 | = Battery BatteryState Charge 48 | -- ^ The user is on a battery powered device. See 'BatteryState' for charge information, and 'Charge' for charge information 49 | | Mains 50 | -- ^ The user is on a device connected to the mains. 51 | | UnknownPowerState 52 | -- ^ SDL could not determine the power for the device. 53 | deriving (Eq, Generic, Ord, Read, Show, Typeable) 54 | 55 | -- | Information on battery consumption for battery powered devices 56 | data BatteryState 57 | = Draining 58 | -- ^ The battery is currently being drained. 59 | | Charged 60 | -- ^ The battery is fully charged. 61 | | Charging 62 | -- ^ The device is plugged in and the battery is charging. 63 | deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) 64 | 65 | -- | Information about how much charge a battery has. 66 | data Charge = 67 | Charge {chargeSecondsLeft :: Maybe CInt -- ^ How many seconds of battery life is left 68 | ,chargePercent :: Maybe CInt -- ^ The percentage of battery charged 69 | } 70 | deriving (Eq, Generic, Ord, Read, Show, Typeable) 71 | -------------------------------------------------------------------------------- /src/SDL/Raw.hs: -------------------------------------------------------------------------------- 1 | -- | Raw low-level FFI bindings to the sdl2 C library. Ease of use is not a 2 | -- design factor, use "SDL" instead if you can. 3 | module SDL.Raw ( 4 | module SDL.Raw.Audio, 5 | module SDL.Raw.Basic, 6 | module SDL.Raw.Enum, 7 | module SDL.Raw.Error, 8 | module SDL.Raw.Event, 9 | module SDL.Raw.Filesystem, 10 | module SDL.Raw.Haptic, 11 | module SDL.Raw.Platform, 12 | module SDL.Raw.Power, 13 | module SDL.Raw.Thread, 14 | module SDL.Raw.Timer, 15 | module SDL.Raw.Types, 16 | module SDL.Raw.Video 17 | ) where 18 | 19 | import SDL.Raw.Audio 20 | import SDL.Raw.Basic 21 | import SDL.Raw.Enum 22 | import SDL.Raw.Error 23 | import SDL.Raw.Event 24 | import SDL.Raw.Filesystem 25 | import SDL.Raw.Haptic 26 | import SDL.Raw.Platform 27 | import SDL.Raw.Power 28 | import SDL.Raw.Thread 29 | import SDL.Raw.Timer 30 | import SDL.Raw.Types 31 | import SDL.Raw.Video 32 | -------------------------------------------------------------------------------- /src/SDL/Raw/Audio.hs: -------------------------------------------------------------------------------- 1 | module SDL.Raw.Audio ( 2 | -- * Audio Device Management, Playing and Recording 3 | audioInit, 4 | audioQuit, 5 | buildAudioCVT, 6 | clearQueuedAudio, 7 | closeAudio, 8 | closeAudioDevice, 9 | convertAudio, 10 | freeWAV, 11 | getAudioDeviceName, 12 | getAudioDeviceStatus, 13 | getAudioDriver, 14 | getAudioStatus, 15 | getCurrentAudioDriver, 16 | getNumAudioDevices, 17 | getNumAudioDrivers, 18 | getQueuedAudioSize, 19 | loadWAV, 20 | loadWAV_RW, 21 | lockAudio, 22 | lockAudioDevice, 23 | mixAudio, 24 | mixAudioFormat, 25 | openAudio, 26 | openAudioDevice, 27 | pauseAudio, 28 | pauseAudioDevice, 29 | queueAudio, 30 | unlockAudio, 31 | unlockAudioDevice 32 | ) where 33 | 34 | import Control.Monad.IO.Class 35 | import Data.Word 36 | import Foreign.C.String 37 | import Foreign.C.Types 38 | import Foreign.Ptr 39 | import SDL.Raw.Enum 40 | import SDL.Raw.Filesystem 41 | import SDL.Raw.Types 42 | 43 | foreign import ccall "SDL.h SDL_AudioInit" audioInitFFI :: CString -> IO CInt 44 | foreign import ccall "SDL.h SDL_AudioQuit" audioQuitFFI :: IO () 45 | foreign import ccall "SDL.h SDL_BuildAudioCVT" buildAudioCVTFFI :: Ptr AudioCVT -> AudioFormat -> Word8 -> CInt -> AudioFormat -> Word8 -> CInt -> IO CInt 46 | foreign import ccall "SDL.h SDL_ClearQueuedAudio" clearQueuedAudioFFI :: AudioDeviceID -> IO () 47 | foreign import ccall "SDL.h SDL_CloseAudio" closeAudioFFI :: IO () 48 | foreign import ccall "SDL.h SDL_CloseAudioDevice" closeAudioDeviceFFI :: AudioDeviceID -> IO () 49 | foreign import ccall "SDL.h SDL_ConvertAudio" convertAudioFFI :: Ptr AudioCVT -> IO CInt 50 | foreign import ccall "SDL.h SDL_FreeWAV" freeWAVFFI :: Ptr Word8 -> IO () 51 | foreign import ccall "SDL.h SDL_GetAudioDeviceName" getAudioDeviceNameFFI :: CInt -> CInt -> IO CString 52 | foreign import ccall "SDL.h SDL_GetAudioDeviceStatus" getAudioDeviceStatusFFI :: AudioDeviceID -> IO AudioStatus 53 | foreign import ccall "SDL.h SDL_GetAudioDriver" getAudioDriverFFI :: CInt -> IO CString 54 | foreign import ccall "SDL.h SDL_GetAudioStatus" getAudioStatusFFI :: IO AudioStatus 55 | foreign import ccall "SDL.h SDL_GetCurrentAudioDriver" getCurrentAudioDriverFFI :: IO CString 56 | foreign import ccall "SDL.h SDL_GetNumAudioDevices" getNumAudioDevicesFFI :: CInt -> IO CInt 57 | foreign import ccall "SDL.h SDL_GetNumAudioDrivers" getNumAudioDriversFFI :: IO CInt 58 | foreign import ccall "SDL.h SDL_GetQueuedAudioSize" getQueuedAudioSizeFFI :: AudioDeviceID -> IO Word32 59 | foreign import ccall "SDL.h SDL_LoadWAV_RW" loadWAV_RWFFI :: Ptr RWops -> CInt -> Ptr AudioSpec -> Ptr (Ptr Word8) -> Ptr Word32 -> IO (Ptr AudioSpec) 60 | foreign import ccall "SDL.h SDL_LockAudio" lockAudioFFI :: IO () 61 | foreign import ccall "SDL.h SDL_LockAudioDevice" lockAudioDeviceFFI :: AudioDeviceID -> IO () 62 | foreign import ccall "SDL.h SDL_MixAudio" mixAudioFFI :: Ptr Word8 -> Ptr Word8 -> Word32 -> CInt -> IO () 63 | foreign import ccall "SDL.h SDL_MixAudioFormat" mixAudioFormatFFI :: Ptr Word8 -> Ptr Word8 -> AudioFormat -> Word32 -> CInt -> IO () 64 | foreign import ccall "SDL.h SDL_OpenAudio" openAudioFFI :: Ptr AudioSpec -> Ptr AudioSpec -> IO CInt 65 | foreign import ccall "SDL.h SDL_OpenAudioDevice" openAudioDeviceFFI :: CString -> CInt -> Ptr AudioSpec -> Ptr AudioSpec -> CInt -> IO AudioDeviceID 66 | foreign import ccall "SDL.h SDL_PauseAudio" pauseAudioFFI :: CInt -> IO () 67 | foreign import ccall "SDL.h SDL_PauseAudioDevice" pauseAudioDeviceFFI :: AudioDeviceID -> CInt -> IO () 68 | foreign import ccall "SDL.h SDL_QueueAudio" queueAudioFFI :: AudioDeviceID -> Ptr () -> Word32 -> IO CInt 69 | foreign import ccall "SDL.h SDL_UnlockAudio" unlockAudioFFI :: IO () 70 | foreign import ccall "SDL.h SDL_UnlockAudioDevice" unlockAudioDeviceFFI :: AudioDeviceID -> IO () 71 | 72 | audioInit :: MonadIO m => CString -> m CInt 73 | audioInit v1 = liftIO $ audioInitFFI v1 74 | {-# INLINE audioInit #-} 75 | 76 | audioQuit :: MonadIO m => m () 77 | audioQuit = liftIO audioQuitFFI 78 | {-# INLINE audioQuit #-} 79 | 80 | buildAudioCVT :: MonadIO m => Ptr AudioCVT -> AudioFormat -> Word8 -> CInt -> AudioFormat -> Word8 -> CInt -> m CInt 81 | buildAudioCVT v1 v2 v3 v4 v5 v6 v7 = liftIO $ buildAudioCVTFFI v1 v2 v3 v4 v5 v6 v7 82 | {-# INLINE buildAudioCVT #-} 83 | 84 | clearQueuedAudio :: MonadIO m => AudioDeviceID -> m () 85 | clearQueuedAudio v1 = liftIO $ clearQueuedAudioFFI v1 86 | {-# INLINE clearQueuedAudio #-} 87 | 88 | closeAudio :: MonadIO m => m () 89 | closeAudio = liftIO closeAudioFFI 90 | {-# INLINE closeAudio #-} 91 | 92 | closeAudioDevice :: MonadIO m => AudioDeviceID -> m () 93 | closeAudioDevice v1 = liftIO $ closeAudioDeviceFFI v1 94 | {-# INLINE closeAudioDevice #-} 95 | 96 | convertAudio :: MonadIO m => Ptr AudioCVT -> m CInt 97 | convertAudio v1 = liftIO $ convertAudioFFI v1 98 | {-# INLINE convertAudio #-} 99 | 100 | freeWAV :: MonadIO m => Ptr Word8 -> m () 101 | freeWAV v1 = liftIO $ freeWAVFFI v1 102 | {-# INLINE freeWAV #-} 103 | 104 | getAudioDeviceName :: MonadIO m => CInt -> CInt -> m CString 105 | getAudioDeviceName v1 v2 = liftIO $ getAudioDeviceNameFFI v1 v2 106 | {-# INLINE getAudioDeviceName #-} 107 | 108 | getAudioDeviceStatus :: MonadIO m => AudioDeviceID -> m AudioStatus 109 | getAudioDeviceStatus v1 = liftIO $ getAudioDeviceStatusFFI v1 110 | {-# INLINE getAudioDeviceStatus #-} 111 | 112 | getAudioDriver :: MonadIO m => CInt -> m CString 113 | getAudioDriver v1 = liftIO $ getAudioDriverFFI v1 114 | {-# INLINE getAudioDriver #-} 115 | 116 | getAudioStatus :: MonadIO m => m AudioStatus 117 | getAudioStatus = liftIO getAudioStatusFFI 118 | {-# INLINE getAudioStatus #-} 119 | 120 | getCurrentAudioDriver :: MonadIO m => m CString 121 | getCurrentAudioDriver = liftIO getCurrentAudioDriverFFI 122 | {-# INLINE getCurrentAudioDriver #-} 123 | 124 | getNumAudioDevices :: MonadIO m => CInt -> m CInt 125 | getNumAudioDevices v1 = liftIO $ getNumAudioDevicesFFI v1 126 | {-# INLINE getNumAudioDevices #-} 127 | 128 | getNumAudioDrivers :: MonadIO m => m CInt 129 | getNumAudioDrivers = liftIO getNumAudioDriversFFI 130 | {-# INLINE getNumAudioDrivers #-} 131 | 132 | getQueuedAudioSize :: MonadIO m => AudioDeviceID -> m Word32 133 | getQueuedAudioSize v1 = liftIO $ getQueuedAudioSizeFFI v1 134 | {-# INLINE getQueuedAudioSize #-} 135 | 136 | loadWAV :: MonadIO m => CString -> Ptr AudioSpec -> Ptr (Ptr Word8) -> Ptr Word32 -> m (Ptr AudioSpec) 137 | loadWAV file spec audio_buf audio_len = liftIO $ do 138 | rw <- withCString "rb" $ rwFromFile file 139 | loadWAV_RW rw 1 spec audio_buf audio_len 140 | {-# INLINE loadWAV #-} 141 | 142 | loadWAV_RW :: MonadIO m => Ptr RWops -> CInt -> Ptr AudioSpec -> Ptr (Ptr Word8) -> Ptr Word32 -> m (Ptr AudioSpec) 143 | loadWAV_RW v1 v2 v3 v4 v5 = liftIO $ loadWAV_RWFFI v1 v2 v3 v4 v5 144 | {-# INLINE loadWAV_RW #-} 145 | 146 | lockAudio :: MonadIO m => m () 147 | lockAudio = liftIO lockAudioFFI 148 | {-# INLINE lockAudio #-} 149 | 150 | lockAudioDevice :: MonadIO m => AudioDeviceID -> m () 151 | lockAudioDevice v1 = liftIO $ lockAudioDeviceFFI v1 152 | {-# INLINE lockAudioDevice #-} 153 | 154 | mixAudio :: MonadIO m => Ptr Word8 -> Ptr Word8 -> Word32 -> CInt -> m () 155 | mixAudio v1 v2 v3 v4 = liftIO $ mixAudioFFI v1 v2 v3 v4 156 | {-# INLINE mixAudio #-} 157 | 158 | mixAudioFormat :: MonadIO m => Ptr Word8 -> Ptr Word8 -> AudioFormat -> Word32 -> CInt -> m () 159 | mixAudioFormat v1 v2 v3 v4 v5 = liftIO $ mixAudioFormatFFI v1 v2 v3 v4 v5 160 | {-# INLINE mixAudioFormat #-} 161 | 162 | openAudio :: MonadIO m => Ptr AudioSpec -> Ptr AudioSpec -> m CInt 163 | openAudio v1 v2 = liftIO $ openAudioFFI v1 v2 164 | {-# INLINE openAudio #-} 165 | 166 | openAudioDevice :: MonadIO m => CString -> CInt -> Ptr AudioSpec -> Ptr AudioSpec -> CInt -> m AudioDeviceID 167 | openAudioDevice v1 v2 v3 v4 v5 = liftIO $ openAudioDeviceFFI v1 v2 v3 v4 v5 168 | {-# INLINE openAudioDevice #-} 169 | 170 | pauseAudio :: MonadIO m => CInt -> m () 171 | pauseAudio v1 = liftIO $ pauseAudioFFI v1 172 | {-# INLINE pauseAudio #-} 173 | 174 | pauseAudioDevice :: MonadIO m => AudioDeviceID -> CInt -> m () 175 | pauseAudioDevice v1 v2 = liftIO $ pauseAudioDeviceFFI v1 v2 176 | {-# INLINE pauseAudioDevice #-} 177 | 178 | queueAudio :: MonadIO m => AudioDeviceID -> Ptr () -> Word32 -> m CInt 179 | queueAudio v1 v2 v3 = liftIO $ queueAudioFFI v1 v2 v3 180 | {-# INLINE queueAudio #-} 181 | 182 | unlockAudio :: MonadIO m => m () 183 | unlockAudio = liftIO unlockAudioFFI 184 | {-# INLINE unlockAudio #-} 185 | 186 | unlockAudioDevice :: MonadIO m => AudioDeviceID -> m () 187 | unlockAudioDevice v1 = liftIO $ unlockAudioDeviceFFI v1 188 | {-# INLINE unlockAudioDevice #-} 189 | -------------------------------------------------------------------------------- /src/SDL/Raw/Basic.hs: -------------------------------------------------------------------------------- 1 | module SDL.Raw.Basic ( 2 | -- * Initialization and Shutdown 3 | init, 4 | initSubSystem, 5 | quit, 6 | quitSubSystem, 7 | setMainReady, 8 | wasInit, 9 | 10 | -- * Memory Management 11 | free, 12 | 13 | -- * Configuration Variables 14 | addHintCallback, 15 | clearHints, 16 | delHintCallback, 17 | getHint, 18 | setHint, 19 | setHintWithPriority, 20 | 21 | -- * Log Handling 22 | log, 23 | logCritical, 24 | logDebug, 25 | logError, 26 | logGetOutputFunction, 27 | logGetPriority, 28 | logInfo, 29 | logMessage, 30 | logResetPriorities, 31 | logSetAllPriority, 32 | logSetOutputFunction, 33 | logSetPriority, 34 | logVerbose, 35 | logWarn, 36 | 37 | -- * Assertions 38 | -- | Use Haskell's own assertion primitives rather than SDL's. 39 | 40 | -- * Querying SDL Version 41 | getRevision, 42 | getRevisionNumber, 43 | getVersion 44 | ) where 45 | 46 | import Control.Monad.IO.Class 47 | import Foreign.C.String 48 | import Foreign.C.Types 49 | import Foreign.Ptr 50 | import SDL.Raw.Enum 51 | import SDL.Raw.Types 52 | import Prelude hiding (init, log) 53 | 54 | foreign import ccall "SDL.h SDL_Init" initFFI :: InitFlag -> IO CInt 55 | foreign import ccall "SDL.h SDL_InitSubSystem" initSubSystemFFI :: InitFlag -> IO CInt 56 | foreign import ccall "SDL.h SDL_Quit" quitFFI :: IO () 57 | foreign import ccall "SDL.h SDL_QuitSubSystem" quitSubSystemFFI :: InitFlag -> IO () 58 | foreign import ccall "SDL.h SDL_SetMainReady" setMainReadyFFI :: IO () 59 | foreign import ccall "SDL.h SDL_WasInit" wasInitFFI :: InitFlag -> IO InitFlag 60 | 61 | foreign import ccall "SDL.h SDL_free" freeFFI :: Ptr () -> IO () 62 | 63 | foreign import ccall "SDL.h SDL_AddHintCallback" addHintCallbackFFI :: CString -> HintCallback -> Ptr () -> IO () 64 | foreign import ccall "SDL.h SDL_ClearHints" clearHintsFFI :: IO () 65 | foreign import ccall "SDL.h SDL_DelHintCallback" delHintCallbackFFI :: CString -> HintCallback -> Ptr () -> IO () 66 | foreign import ccall "SDL.h SDL_GetHint" getHintFFI :: CString -> IO CString 67 | foreign import ccall "SDL.h SDL_SetHint" setHintFFI :: CString -> CString -> IO Bool 68 | foreign import ccall "SDL.h SDL_SetHintWithPriority" setHintWithPriorityFFI :: CString -> CString -> HintPriority -> IO Bool 69 | 70 | foreign import ccall "SDL.h SDL_LogGetOutputFunction" logGetOutputFunctionFFI :: Ptr LogOutputFunction -> Ptr (Ptr ()) -> IO () 71 | foreign import ccall "SDL.h SDL_LogGetPriority" logGetPriorityFFI :: CInt -> IO LogPriority 72 | foreign import ccall "sdlhelper.c SDLHelper_LogMessage" logMessageFFI :: CInt -> LogPriority -> CString -> IO () 73 | foreign import ccall "SDL.h SDL_LogResetPriorities" logResetPrioritiesFFI :: IO () 74 | foreign import ccall "SDL.h SDL_LogSetAllPriority" logSetAllPriorityFFI :: LogPriority -> IO () 75 | foreign import ccall "SDL.h SDL_LogSetOutputFunction" logSetOutputFunctionFFI :: LogOutputFunction -> Ptr () -> IO () 76 | foreign import ccall "SDL.h SDL_LogSetPriority" logSetPriorityFFI :: CInt -> LogPriority -> IO () 77 | 78 | foreign import ccall "SDL.h SDL_GetRevision" getRevisionFFI :: IO CString 79 | foreign import ccall "SDL.h SDL_GetRevisionNumber" getRevisionNumberFFI :: IO CInt 80 | foreign import ccall "SDL.h SDL_GetVersion" getVersionFFI :: Ptr Version -> IO () 81 | 82 | init :: MonadIO m => InitFlag -> m CInt 83 | init v1 = liftIO $ initFFI v1 84 | {-# INLINE init #-} 85 | 86 | initSubSystem :: MonadIO m => InitFlag -> m CInt 87 | initSubSystem v1 = liftIO $ initSubSystemFFI v1 88 | {-# INLINE initSubSystem #-} 89 | 90 | quit :: MonadIO m => m () 91 | quit = liftIO quitFFI 92 | {-# INLINE quit #-} 93 | 94 | quitSubSystem :: MonadIO m => InitFlag -> m () 95 | quitSubSystem v1 = liftIO $ quitSubSystemFFI v1 96 | {-# INLINE quitSubSystem #-} 97 | 98 | setMainReady :: MonadIO m => m () 99 | setMainReady = liftIO setMainReadyFFI 100 | {-# INLINE setMainReady #-} 101 | 102 | wasInit :: MonadIO m => InitFlag -> m InitFlag 103 | wasInit v1 = liftIO $ wasInitFFI v1 104 | {-# INLINE wasInit #-} 105 | 106 | free :: MonadIO m => Ptr () -> m () 107 | free v1 = liftIO $ freeFFI v1 108 | {-# INLINE free #-} 109 | 110 | addHintCallback :: MonadIO m => CString -> HintCallback -> Ptr () -> m () 111 | addHintCallback v1 v2 v3 = liftIO $ addHintCallbackFFI v1 v2 v3 112 | {-# INLINE addHintCallback #-} 113 | 114 | clearHints :: MonadIO m => m () 115 | clearHints = liftIO clearHintsFFI 116 | {-# INLINE clearHints #-} 117 | 118 | delHintCallback :: MonadIO m => CString -> HintCallback -> Ptr () -> m () 119 | delHintCallback v1 v2 v3 = liftIO $ delHintCallbackFFI v1 v2 v3 120 | {-# INLINE delHintCallback #-} 121 | 122 | getHint :: MonadIO m => CString -> m CString 123 | getHint v1 = liftIO $ getHintFFI v1 124 | {-# INLINE getHint #-} 125 | 126 | setHint :: MonadIO m => CString -> CString -> m Bool 127 | setHint v1 v2 = liftIO $ setHintFFI v1 v2 128 | {-# INLINE setHint #-} 129 | 130 | setHintWithPriority :: MonadIO m => CString -> CString -> HintPriority -> m Bool 131 | setHintWithPriority v1 v2 v3 = liftIO $ setHintWithPriorityFFI v1 v2 v3 132 | {-# INLINE setHintWithPriority #-} 133 | 134 | log :: CString -> IO () 135 | log = logMessage SDL_LOG_CATEGORY_APPLICATION SDL_LOG_PRIORITY_INFO 136 | {-# INLINE log #-} 137 | 138 | logCritical :: CInt -> CString -> IO () 139 | logCritical category = logMessage category SDL_LOG_PRIORITY_CRITICAL 140 | {-# INLINE logCritical #-} 141 | 142 | logDebug :: CInt -> CString -> IO () 143 | logDebug category = logMessage category SDL_LOG_PRIORITY_DEBUG 144 | {-# INLINE logDebug #-} 145 | 146 | logError :: CInt -> CString -> IO () 147 | logError category = logMessage category SDL_LOG_PRIORITY_ERROR 148 | {-# INLINE logError #-} 149 | 150 | logGetOutputFunction :: MonadIO m => Ptr LogOutputFunction -> Ptr (Ptr ()) -> m () 151 | logGetOutputFunction v1 v2 = liftIO $ logGetOutputFunctionFFI v1 v2 152 | {-# INLINE logGetOutputFunction #-} 153 | 154 | logGetPriority :: MonadIO m => CInt -> m LogPriority 155 | logGetPriority v1 = liftIO $ logGetPriorityFFI v1 156 | {-# INLINE logGetPriority #-} 157 | 158 | logInfo :: CInt -> CString -> IO () 159 | logInfo category = logMessage category SDL_LOG_PRIORITY_INFO 160 | {-# INLINE logInfo #-} 161 | 162 | logMessage :: MonadIO m => CInt -> LogPriority -> CString -> m () 163 | logMessage v1 v2 v3 = liftIO $ logMessageFFI v1 v2 v3 164 | {-# INLINE logMessage #-} 165 | 166 | logResetPriorities :: MonadIO m => m () 167 | logResetPriorities = liftIO logResetPrioritiesFFI 168 | {-# INLINE logResetPriorities #-} 169 | 170 | logSetAllPriority :: MonadIO m => LogPriority -> m () 171 | logSetAllPriority v1 = liftIO $ logSetAllPriorityFFI v1 172 | {-# INLINE logSetAllPriority #-} 173 | 174 | logSetOutputFunction :: MonadIO m => LogOutputFunction -> Ptr () -> m () 175 | logSetOutputFunction v1 v2 = liftIO $ logSetOutputFunctionFFI v1 v2 176 | {-# INLINE logSetOutputFunction #-} 177 | 178 | logSetPriority :: MonadIO m => CInt -> LogPriority -> m () 179 | logSetPriority v1 v2 = liftIO $ logSetPriorityFFI v1 v2 180 | {-# INLINE logSetPriority #-} 181 | 182 | logVerbose :: CInt -> CString -> IO () 183 | logVerbose category = logMessage category SDL_LOG_PRIORITY_VERBOSE 184 | {-# INLINE logVerbose #-} 185 | 186 | logWarn :: CInt -> CString -> IO () 187 | logWarn category = logMessage category SDL_LOG_PRIORITY_WARN 188 | {-# INLINE logWarn #-} 189 | 190 | getRevision :: MonadIO m => m CString 191 | getRevision = liftIO getRevisionFFI 192 | {-# INLINE getRevision #-} 193 | 194 | getRevisionNumber :: MonadIO m => m CInt 195 | getRevisionNumber = liftIO getRevisionNumberFFI 196 | {-# INLINE getRevisionNumber #-} 197 | 198 | getVersion :: MonadIO m => Ptr Version -> m () 199 | getVersion v1 = liftIO $ getVersionFFI v1 200 | {-# INLINE getVersion #-} 201 | -------------------------------------------------------------------------------- /src/SDL/Raw/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | module SDL.Raw.Error ( 3 | -- * Error Handling 4 | SDLError(..), 5 | throwError, 6 | 7 | -- * Manual Error Handling 8 | clearError, 9 | getError, 10 | setError 11 | ) where 12 | 13 | import Control.Exception 14 | import Control.Monad.Catch 15 | import Control.Monad.IO.Class 16 | import Data.Typeable 17 | import Foreign.C.String 18 | import Foreign.C.Types 19 | 20 | -- | Note: the 'CString' is only valid until the next SDL function call. If you 21 | -- need to preserve the error message, make a copy of it. 22 | newtype SDLError = SDLError CString 23 | deriving (Eq, Show, Typeable) 24 | 25 | instance Exception SDLError 26 | 27 | foreign import ccall "SDL.h SDL_ClearError" clearErrorFFI :: IO () 28 | foreign import ccall "SDL.h SDL_GetError" getErrorFFI :: IO CString 29 | foreign import ccall "sdlhelper.c SDLHelper_SetError" setErrorFFI :: CString -> IO CInt 30 | 31 | throwError :: (MonadThrow m, MonadIO m) => m () 32 | throwError = getError >>= throwM . SDLError 33 | 34 | clearError :: MonadIO m => m () 35 | clearError = liftIO clearErrorFFI 36 | {-# INLINE clearError #-} 37 | 38 | getError :: MonadIO m => m CString 39 | getError = liftIO getErrorFFI 40 | {-# INLINE getError #-} 41 | 42 | setError :: MonadIO m => CString -> m CInt 43 | setError v1 = liftIO $ setErrorFFI v1 44 | {-# INLINE setError #-} 45 | -------------------------------------------------------------------------------- /src/SDL/Raw/Filesystem.hs: -------------------------------------------------------------------------------- 1 | module SDL.Raw.Filesystem ( 2 | -- * Filesystem Paths 3 | getBasePath, 4 | getPrefPath, 5 | 6 | -- * File I/O Abstraction 7 | allocRW, 8 | freeRW, 9 | rwFromConstMem, 10 | rwFromFP, 11 | rwFromFile, 12 | rwFromMem, 13 | rwClose, 14 | rwRead, 15 | rwSeek, 16 | rwTell, 17 | rwWrite, 18 | readBE16, 19 | readBE32, 20 | readBE64, 21 | readLE16, 22 | readLE32, 23 | readLE64, 24 | writeBE16, 25 | writeBE32, 26 | writeBE64, 27 | writeLE16, 28 | writeLE32, 29 | writeLE64 30 | ) where 31 | 32 | import Control.Monad.IO.Class 33 | import Data.Int 34 | import Data.Word 35 | import Foreign.C.String 36 | import Foreign.C.Types 37 | import Foreign.Ptr 38 | import SDL.Raw.Types 39 | 40 | foreign import ccall "SDL.h SDL_GetBasePath" getBasePathFFI :: IO CString 41 | foreign import ccall "SDL.h SDL_GetPrefPath" getPrefPathFFI :: CString -> CString -> IO CString 42 | 43 | foreign import ccall "SDL.h SDL_AllocRW" allocRWFFI :: IO (Ptr RWops) 44 | foreign import ccall "SDL.h SDL_FreeRW" freeRWFFI :: Ptr RWops -> IO () 45 | foreign import ccall "SDL.h SDL_RWFromConstMem" rwFromConstMemFFI :: Ptr () -> CInt -> IO (Ptr RWops) 46 | foreign import ccall "SDL.h SDL_RWFromFP" rwFromFPFFI :: Ptr () -> Bool -> IO (Ptr RWops) 47 | foreign import ccall "SDL.h SDL_RWFromFile" rwFromFileFFI :: CString -> CString -> IO (Ptr RWops) 48 | foreign import ccall "SDL.h SDL_RWFromMem" rwFromMemFFI :: Ptr () -> CInt -> IO (Ptr RWops) 49 | foreign import ccall "sdlhelper.h SDLHelper_RWclose" rwCloseFFI :: Ptr RWops -> IO CInt 50 | foreign import ccall "sdlhelper.h SDLHelper_RWread" rwReadFFI :: Ptr RWops -> Ptr () -> CSize -> CSize -> IO CSize 51 | foreign import ccall "sdlhelper.h SDLHelper_RWseek" rwSeekFFI :: Ptr RWops -> Int64 -> CInt -> IO Int64 52 | foreign import ccall "sdlhelper.h SDLHelper_RWtell" rwTellFFI :: Ptr RWops -> IO Int64 53 | foreign import ccall "sdlhelper.h SDLHelper_RWwrite" rwWriteFFI :: Ptr RWops -> Ptr () -> CSize -> CSize -> IO CSize 54 | foreign import ccall "SDL.h SDL_ReadBE16" readBE16FFI :: Ptr RWops -> IO Word16 55 | foreign import ccall "SDL.h SDL_ReadBE32" readBE32FFI :: Ptr RWops -> IO Word32 56 | foreign import ccall "SDL.h SDL_ReadBE64" readBE64FFI :: Ptr RWops -> IO Word64 57 | foreign import ccall "SDL.h SDL_ReadLE16" readLE16FFI :: Ptr RWops -> IO Word16 58 | foreign import ccall "SDL.h SDL_ReadLE32" readLE32FFI :: Ptr RWops -> IO Word32 59 | foreign import ccall "SDL.h SDL_ReadLE64" readLE64FFI :: Ptr RWops -> IO Word64 60 | foreign import ccall "SDL.h SDL_WriteBE16" writeBE16FFI :: Ptr RWops -> Word16 -> IO CSize 61 | foreign import ccall "SDL.h SDL_WriteBE32" writeBE32FFI :: Ptr RWops -> Word32 -> IO CSize 62 | foreign import ccall "SDL.h SDL_WriteBE64" writeBE64FFI :: Ptr RWops -> Word64 -> IO CSize 63 | foreign import ccall "SDL.h SDL_WriteLE16" writeLE16FFI :: Ptr RWops -> Word16 -> IO CSize 64 | foreign import ccall "SDL.h SDL_WriteLE32" writeLE32FFI :: Ptr RWops -> Word32 -> IO CSize 65 | foreign import ccall "SDL.h SDL_WriteLE64" writeLE64FFI :: Ptr RWops -> Word64 -> IO CSize 66 | 67 | getBasePath :: MonadIO m => m CString 68 | getBasePath = liftIO getBasePathFFI 69 | {-# INLINE getBasePath #-} 70 | 71 | getPrefPath :: MonadIO m => CString -> CString -> m CString 72 | getPrefPath v1 v2 = liftIO $ getPrefPathFFI v1 v2 73 | {-# INLINE getPrefPath #-} 74 | 75 | allocRW :: MonadIO m => m (Ptr RWops) 76 | allocRW = liftIO allocRWFFI 77 | {-# INLINE allocRW #-} 78 | 79 | freeRW :: MonadIO m => Ptr RWops -> m () 80 | freeRW v1 = liftIO $ freeRWFFI v1 81 | {-# INLINE freeRW #-} 82 | 83 | rwFromConstMem :: MonadIO m => Ptr () -> CInt -> m (Ptr RWops) 84 | rwFromConstMem v1 v2 = liftIO $ rwFromConstMemFFI v1 v2 85 | {-# INLINE rwFromConstMem #-} 86 | 87 | rwFromFP :: MonadIO m => Ptr () -> Bool -> m (Ptr RWops) 88 | rwFromFP v1 v2 = liftIO $ rwFromFPFFI v1 v2 89 | {-# INLINE rwFromFP #-} 90 | 91 | rwFromFile :: MonadIO m => CString -> CString -> m (Ptr RWops) 92 | rwFromFile v1 v2 = liftIO $ rwFromFileFFI v1 v2 93 | {-# INLINE rwFromFile #-} 94 | 95 | rwFromMem :: MonadIO m => Ptr () -> CInt -> m (Ptr RWops) 96 | rwFromMem v1 v2 = liftIO $ rwFromMemFFI v1 v2 97 | {-# INLINE rwFromMem #-} 98 | 99 | rwClose :: MonadIO m => Ptr RWops -> m CInt 100 | rwClose v1 = liftIO $ rwCloseFFI v1 101 | {-# INLINE rwClose #-} 102 | 103 | rwRead :: MonadIO m => Ptr RWops -> Ptr () -> CSize -> CSize -> m CSize 104 | rwRead v1 v2 v3 v4 = liftIO $ rwReadFFI v1 v2 v3 v4 105 | {-# INLINE rwRead #-} 106 | 107 | rwSeek :: MonadIO m => Ptr RWops -> Int64 -> CInt -> m Int64 108 | rwSeek v1 v2 v3 = liftIO $ rwSeekFFI v1 v2 v3 109 | {-# INLINE rwSeek #-} 110 | 111 | rwTell :: MonadIO m => Ptr RWops -> m Int64 112 | rwTell v1 = liftIO $ rwTellFFI v1 113 | {-# INLINE rwTell #-} 114 | 115 | rwWrite :: MonadIO m => Ptr RWops -> Ptr () -> CSize -> CSize -> m CSize 116 | rwWrite v1 v2 v3 v4 = liftIO $ rwWriteFFI v1 v2 v3 v4 117 | {-# INLINE rwWrite #-} 118 | 119 | readBE16 :: MonadIO m => Ptr RWops -> m Word16 120 | readBE16 v1 = liftIO $ readBE16FFI v1 121 | {-# INLINE readBE16 #-} 122 | 123 | readBE32 :: MonadIO m => Ptr RWops -> m Word32 124 | readBE32 v1 = liftIO $ readBE32FFI v1 125 | {-# INLINE readBE32 #-} 126 | 127 | readBE64 :: MonadIO m => Ptr RWops -> m Word64 128 | readBE64 v1 = liftIO $ readBE64FFI v1 129 | {-# INLINE readBE64 #-} 130 | 131 | readLE16 :: MonadIO m => Ptr RWops -> m Word16 132 | readLE16 v1 = liftIO $ readLE16FFI v1 133 | {-# INLINE readLE16 #-} 134 | 135 | readLE32 :: MonadIO m => Ptr RWops -> m Word32 136 | readLE32 v1 = liftIO $ readLE32FFI v1 137 | {-# INLINE readLE32 #-} 138 | 139 | readLE64 :: MonadIO m => Ptr RWops -> m Word64 140 | readLE64 v1 = liftIO $ readLE64FFI v1 141 | {-# INLINE readLE64 #-} 142 | 143 | writeBE16 :: MonadIO m => Ptr RWops -> Word16 -> m CSize 144 | writeBE16 v1 v2 = liftIO $ writeBE16FFI v1 v2 145 | {-# INLINE writeBE16 #-} 146 | 147 | writeBE32 :: MonadIO m => Ptr RWops -> Word32 -> m CSize 148 | writeBE32 v1 v2 = liftIO $ writeBE32FFI v1 v2 149 | {-# INLINE writeBE32 #-} 150 | 151 | writeBE64 :: MonadIO m => Ptr RWops -> Word64 -> m CSize 152 | writeBE64 v1 v2 = liftIO $ writeBE64FFI v1 v2 153 | {-# INLINE writeBE64 #-} 154 | 155 | writeLE16 :: MonadIO m => Ptr RWops -> Word16 -> m CSize 156 | writeLE16 v1 v2 = liftIO $ writeLE16FFI v1 v2 157 | {-# INLINE writeLE16 #-} 158 | 159 | writeLE32 :: MonadIO m => Ptr RWops -> Word32 -> m CSize 160 | writeLE32 v1 v2 = liftIO $ writeLE32FFI v1 v2 161 | {-# INLINE writeLE32 #-} 162 | 163 | writeLE64 :: MonadIO m => Ptr RWops -> Word64 -> m CSize 164 | writeLE64 v1 v2 = liftIO $ writeLE64FFI v1 v2 165 | {-# INLINE writeLE64 #-} 166 | -------------------------------------------------------------------------------- /src/SDL/Raw/Haptic.hs: -------------------------------------------------------------------------------- 1 | module SDL.Raw.Haptic ( 2 | -- * Force Feedback Support 3 | hapticClose, 4 | hapticDestroyEffect, 5 | hapticEffectSupported, 6 | hapticGetEffectStatus, 7 | hapticIndex, 8 | hapticName, 9 | hapticNewEffect, 10 | hapticNumAxes, 11 | hapticNumEffects, 12 | hapticNumEffectsPlaying, 13 | hapticOpen, 14 | hapticOpenFromJoystick, 15 | hapticOpenFromMouse, 16 | hapticOpened, 17 | hapticPause, 18 | hapticQuery, 19 | hapticRumbleInit, 20 | hapticRumblePlay, 21 | hapticRumbleStop, 22 | hapticRumbleSupported, 23 | hapticRunEffect, 24 | hapticSetAutocenter, 25 | hapticSetGain, 26 | hapticStopAll, 27 | hapticStopEffect, 28 | hapticUnpause, 29 | hapticUpdateEffect, 30 | joystickIsHaptic, 31 | mouseIsHaptic, 32 | numHaptics 33 | ) where 34 | 35 | import Control.Monad.IO.Class 36 | import Data.Word 37 | import Foreign.C.String 38 | import Foreign.C.Types 39 | import Foreign.Ptr 40 | import SDL.Raw.Types 41 | 42 | foreign import ccall "SDL.h SDL_HapticClose" hapticCloseFFI :: Haptic -> IO () 43 | foreign import ccall "SDL.h SDL_HapticDestroyEffect" hapticDestroyEffectFFI :: Haptic -> CInt -> IO () 44 | foreign import ccall "SDL.h SDL_HapticEffectSupported" hapticEffectSupportedFFI :: Haptic -> Ptr HapticEffect -> IO CInt 45 | foreign import ccall "SDL.h SDL_HapticGetEffectStatus" hapticGetEffectStatusFFI :: Haptic -> CInt -> IO CInt 46 | foreign import ccall "SDL.h SDL_HapticIndex" hapticIndexFFI :: Haptic -> IO CInt 47 | foreign import ccall "SDL.h SDL_HapticName" hapticNameFFI :: CInt -> IO CString 48 | foreign import ccall "SDL.h SDL_HapticNewEffect" hapticNewEffectFFI :: Haptic -> Ptr HapticEffect -> IO CInt 49 | foreign import ccall "SDL.h SDL_HapticNumAxes" hapticNumAxesFFI :: Haptic -> IO CInt 50 | foreign import ccall "SDL.h SDL_HapticNumEffects" hapticNumEffectsFFI :: Haptic -> IO CInt 51 | foreign import ccall "SDL.h SDL_HapticNumEffectsPlaying" hapticNumEffectsPlayingFFI :: Haptic -> IO CInt 52 | foreign import ccall "SDL.h SDL_HapticOpen" hapticOpenFFI :: CInt -> IO Haptic 53 | foreign import ccall "SDL.h SDL_HapticOpenFromJoystick" hapticOpenFromJoystickFFI :: Joystick -> IO Haptic 54 | foreign import ccall "SDL.h SDL_HapticOpenFromMouse" hapticOpenFromMouseFFI :: IO Haptic 55 | foreign import ccall "SDL.h SDL_HapticOpened" hapticOpenedFFI :: CInt -> IO CInt 56 | foreign import ccall "SDL.h SDL_HapticPause" hapticPauseFFI :: Haptic -> IO CInt 57 | foreign import ccall "SDL.h SDL_HapticQuery" hapticQueryFFI :: Haptic -> IO CUInt 58 | foreign import ccall "SDL.h SDL_HapticRumbleInit" hapticRumbleInitFFI :: Haptic -> IO CInt 59 | foreign import ccall "SDL.h SDL_HapticRumblePlay" hapticRumblePlayFFI :: Haptic -> CFloat -> Word32 -> IO CInt 60 | foreign import ccall "SDL.h SDL_HapticRumbleStop" hapticRumbleStopFFI :: Haptic -> IO CInt 61 | foreign import ccall "SDL.h SDL_HapticRumbleSupported" hapticRumbleSupportedFFI :: Haptic -> IO CInt 62 | foreign import ccall "SDL.h SDL_HapticRunEffect" hapticRunEffectFFI :: Haptic -> CInt -> Word32 -> IO CInt 63 | foreign import ccall "SDL.h SDL_HapticSetAutocenter" hapticSetAutocenterFFI :: Haptic -> CInt -> IO CInt 64 | foreign import ccall "SDL.h SDL_HapticSetGain" hapticSetGainFFI :: Haptic -> CInt -> IO CInt 65 | foreign import ccall "SDL.h SDL_HapticStopAll" hapticStopAllFFI :: Haptic -> IO CInt 66 | foreign import ccall "SDL.h SDL_HapticStopEffect" hapticStopEffectFFI :: Haptic -> CInt -> IO CInt 67 | foreign import ccall "SDL.h SDL_HapticUnpause" hapticUnpauseFFI :: Haptic -> IO CInt 68 | foreign import ccall "SDL.h SDL_HapticUpdateEffect" hapticUpdateEffectFFI :: Haptic -> CInt -> Ptr HapticEffect -> IO CInt 69 | foreign import ccall "SDL.h SDL_JoystickIsHaptic" joystickIsHapticFFI :: Joystick -> IO CInt 70 | foreign import ccall "SDL.h SDL_MouseIsHaptic" mouseIsHapticFFI :: IO CInt 71 | foreign import ccall "SDL.h SDL_NumHaptics" numHapticsFFI :: IO CInt 72 | 73 | hapticClose :: MonadIO m => Haptic -> m () 74 | hapticClose v1 = liftIO $ hapticCloseFFI v1 75 | {-# INLINE hapticClose #-} 76 | 77 | hapticDestroyEffect :: MonadIO m => Haptic -> CInt -> m () 78 | hapticDestroyEffect v1 v2 = liftIO $ hapticDestroyEffectFFI v1 v2 79 | {-# INLINE hapticDestroyEffect #-} 80 | 81 | hapticEffectSupported :: MonadIO m => Haptic -> Ptr HapticEffect -> m CInt 82 | hapticEffectSupported v1 v2 = liftIO $ hapticEffectSupportedFFI v1 v2 83 | {-# INLINE hapticEffectSupported #-} 84 | 85 | hapticGetEffectStatus :: MonadIO m => Haptic -> CInt -> m CInt 86 | hapticGetEffectStatus v1 v2 = liftIO $ hapticGetEffectStatusFFI v1 v2 87 | {-# INLINE hapticGetEffectStatus #-} 88 | 89 | hapticIndex :: MonadIO m => Haptic -> m CInt 90 | hapticIndex v1 = liftIO $ hapticIndexFFI v1 91 | {-# INLINE hapticIndex #-} 92 | 93 | hapticName :: MonadIO m => CInt -> m CString 94 | hapticName v1 = liftIO $ hapticNameFFI v1 95 | {-# INLINE hapticName #-} 96 | 97 | hapticNewEffect :: MonadIO m => Haptic -> Ptr HapticEffect -> m CInt 98 | hapticNewEffect v1 v2 = liftIO $ hapticNewEffectFFI v1 v2 99 | {-# INLINE hapticNewEffect #-} 100 | 101 | hapticNumAxes :: MonadIO m => Haptic -> m CInt 102 | hapticNumAxes v1 = liftIO $ hapticNumAxesFFI v1 103 | {-# INLINE hapticNumAxes #-} 104 | 105 | hapticNumEffects :: MonadIO m => Haptic -> m CInt 106 | hapticNumEffects v1 = liftIO $ hapticNumEffectsFFI v1 107 | {-# INLINE hapticNumEffects #-} 108 | 109 | hapticNumEffectsPlaying :: MonadIO m => Haptic -> m CInt 110 | hapticNumEffectsPlaying v1 = liftIO $ hapticNumEffectsPlayingFFI v1 111 | {-# INLINE hapticNumEffectsPlaying #-} 112 | 113 | hapticOpen :: MonadIO m => CInt -> m Haptic 114 | hapticOpen v1 = liftIO $ hapticOpenFFI v1 115 | {-# INLINE hapticOpen #-} 116 | 117 | hapticOpenFromJoystick :: MonadIO m => Joystick -> m Haptic 118 | hapticOpenFromJoystick v1 = liftIO $ hapticOpenFromJoystickFFI v1 119 | {-# INLINE hapticOpenFromJoystick #-} 120 | 121 | hapticOpenFromMouse :: MonadIO m => m Haptic 122 | hapticOpenFromMouse = liftIO hapticOpenFromMouseFFI 123 | {-# INLINE hapticOpenFromMouse #-} 124 | 125 | hapticOpened :: MonadIO m => CInt -> m CInt 126 | hapticOpened v1 = liftIO $ hapticOpenedFFI v1 127 | {-# INLINE hapticOpened #-} 128 | 129 | hapticPause :: MonadIO m => Haptic -> m CInt 130 | hapticPause v1 = liftIO $ hapticPauseFFI v1 131 | {-# INLINE hapticPause #-} 132 | 133 | hapticQuery :: MonadIO m => Haptic -> m CUInt 134 | hapticQuery v1 = liftIO $ hapticQueryFFI v1 135 | {-# INLINE hapticQuery #-} 136 | 137 | hapticRumbleInit :: MonadIO m => Haptic -> m CInt 138 | hapticRumbleInit v1 = liftIO $ hapticRumbleInitFFI v1 139 | {-# INLINE hapticRumbleInit #-} 140 | 141 | hapticRumblePlay :: MonadIO m => Haptic -> CFloat -> Word32 -> m CInt 142 | hapticRumblePlay v1 v2 v3 = liftIO $ hapticRumblePlayFFI v1 v2 v3 143 | {-# INLINE hapticRumblePlay #-} 144 | 145 | hapticRumbleStop :: MonadIO m => Haptic -> m CInt 146 | hapticRumbleStop v1 = liftIO $ hapticRumbleStopFFI v1 147 | {-# INLINE hapticRumbleStop #-} 148 | 149 | hapticRumbleSupported :: MonadIO m => Haptic -> m CInt 150 | hapticRumbleSupported v1 = liftIO $ hapticRumbleSupportedFFI v1 151 | {-# INLINE hapticRumbleSupported #-} 152 | 153 | hapticRunEffect :: MonadIO m => Haptic -> CInt -> Word32 -> m CInt 154 | hapticRunEffect v1 v2 v3 = liftIO $ hapticRunEffectFFI v1 v2 v3 155 | {-# INLINE hapticRunEffect #-} 156 | 157 | hapticSetAutocenter :: MonadIO m => Haptic -> CInt -> m CInt 158 | hapticSetAutocenter v1 v2 = liftIO $ hapticSetAutocenterFFI v1 v2 159 | {-# INLINE hapticSetAutocenter #-} 160 | 161 | hapticSetGain :: MonadIO m => Haptic -> CInt -> m CInt 162 | hapticSetGain v1 v2 = liftIO $ hapticSetGainFFI v1 v2 163 | {-# INLINE hapticSetGain #-} 164 | 165 | hapticStopAll :: MonadIO m => Haptic -> m CInt 166 | hapticStopAll v1 = liftIO $ hapticStopAllFFI v1 167 | {-# INLINE hapticStopAll #-} 168 | 169 | hapticStopEffect :: MonadIO m => Haptic -> CInt -> m CInt 170 | hapticStopEffect v1 v2 = liftIO $ hapticStopEffectFFI v1 v2 171 | {-# INLINE hapticStopEffect #-} 172 | 173 | hapticUnpause :: MonadIO m => Haptic -> m CInt 174 | hapticUnpause v1 = liftIO $ hapticUnpauseFFI v1 175 | {-# INLINE hapticUnpause #-} 176 | 177 | hapticUpdateEffect :: MonadIO m => Haptic -> CInt -> Ptr HapticEffect -> m CInt 178 | hapticUpdateEffect v1 v2 v3 = liftIO $ hapticUpdateEffectFFI v1 v2 v3 179 | {-# INLINE hapticUpdateEffect #-} 180 | 181 | joystickIsHaptic :: MonadIO m => Joystick -> m CInt 182 | joystickIsHaptic v1 = liftIO $ joystickIsHapticFFI v1 183 | {-# INLINE joystickIsHaptic #-} 184 | 185 | mouseIsHaptic :: MonadIO m => m CInt 186 | mouseIsHaptic = liftIO mouseIsHapticFFI 187 | {-# INLINE mouseIsHaptic #-} 188 | 189 | numHaptics :: MonadIO m => m CInt 190 | numHaptics = liftIO numHapticsFFI 191 | {-# INLINE numHaptics #-} 192 | -------------------------------------------------------------------------------- /src/SDL/Raw/Platform.hs: -------------------------------------------------------------------------------- 1 | module SDL.Raw.Platform ( 2 | -- * Platform Detection 3 | getPlatform 4 | ) where 5 | 6 | import Control.Monad.IO.Class 7 | import Foreign.C.String 8 | 9 | foreign import ccall "SDL.h SDL_GetPlatform" getPlatformFFI :: IO CString 10 | 11 | getPlatform :: MonadIO m => m CString 12 | getPlatform = liftIO getPlatformFFI 13 | {-# INLINE getPlatform #-} 14 | -------------------------------------------------------------------------------- /src/SDL/Raw/Power.hs: -------------------------------------------------------------------------------- 1 | module SDL.Raw.Power ( 2 | -- * Power Management Status 3 | getPowerInfo 4 | ) where 5 | 6 | import Control.Monad.IO.Class 7 | import Foreign.C.Types 8 | import Foreign.Ptr 9 | import SDL.Raw.Enum 10 | 11 | foreign import ccall "SDL.h SDL_GetPowerInfo" getPowerInfoFFI :: Ptr CInt -> Ptr CInt -> IO PowerState 12 | 13 | getPowerInfo :: MonadIO m => Ptr CInt -> Ptr CInt -> m PowerState 14 | getPowerInfo v1 v2 = liftIO $ getPowerInfoFFI v1 v2 15 | {-# INLINE getPowerInfo #-} 16 | -------------------------------------------------------------------------------- /src/SDL/Raw/Thread.hs: -------------------------------------------------------------------------------- 1 | module SDL.Raw.Thread ( 2 | -- * Thread Management 3 | createThread, 4 | detachThread, 5 | getThreadID, 6 | getThreadName, 7 | setThreadPriority, 8 | tlsCreate, 9 | tlsGet, 10 | tlsSet, 11 | threadID, 12 | waitThread, 13 | 14 | -- * Thread Synchronization Primitives 15 | condBroadcast, 16 | condSignal, 17 | condWait, 18 | condWaitTimeout, 19 | createCond, 20 | createMutex, 21 | createSemaphore, 22 | destroyCond, 23 | destroyMutex, 24 | destroySemaphore, 25 | lockMutex, 26 | semPost, 27 | semTryWait, 28 | semValue, 29 | semWait, 30 | semWaitTimeout, 31 | tryLockMutex, 32 | unlockMutex, 33 | 34 | -- * Atomic Operations 35 | atomicAdd, 36 | atomicCAS, 37 | atomicCASPtr, 38 | atomicDecRef, 39 | atomicGet, 40 | atomicGetPtr, 41 | atomicIncRef, 42 | atomicLock, 43 | atomicSet, 44 | atomicSetPtr, 45 | atomicTryLock, 46 | atomicUnlock 47 | ) where 48 | 49 | import Control.Monad.IO.Class 50 | import Data.Word 51 | import Foreign.C.String 52 | import Foreign.C.Types 53 | import Foreign.Ptr 54 | import SDL.Raw.Enum 55 | import SDL.Raw.Types 56 | 57 | foreign import ccall "SDL.h SDL_CreateThread" createThreadFFI :: ThreadFunction -> CString -> IO (Ptr ()) 58 | foreign import ccall "SDL.h SDL_DetachThread" detachThreadFFI :: Ptr Thread -> IO () 59 | foreign import ccall "SDL.h SDL_GetThreadID" getThreadIDFFI :: Ptr Thread -> IO ThreadID 60 | foreign import ccall "SDL.h SDL_GetThreadName" getThreadNameFFI :: Ptr Thread -> IO CString 61 | foreign import ccall "SDL.h SDL_SetThreadPriority" setThreadPriorityFFI :: ThreadPriority -> IO CInt 62 | foreign import ccall "SDL.h SDL_TLSCreate" tlsCreateFFI :: IO TLSID 63 | foreign import ccall "SDL.h SDL_TLSGet" tlsGetFFI :: TLSID -> IO (Ptr ()) 64 | foreign import ccall "SDL.h SDL_TLSSet" tlsSetFFI :: TLSID -> Ptr () -> FunPtr (Ptr () -> IO ()) -> IO CInt 65 | foreign import ccall "SDL.h SDL_ThreadID" threadIDFFI :: IO ThreadID 66 | foreign import ccall "SDL.h SDL_WaitThread" waitThreadFFI :: Ptr Thread -> Ptr CInt -> IO () 67 | 68 | foreign import ccall "SDL.h SDL_CondBroadcast" condBroadcastFFI :: Ptr Cond -> IO CInt 69 | foreign import ccall "SDL.h SDL_CondSignal" condSignalFFI :: Ptr Cond -> IO CInt 70 | foreign import ccall "SDL.h SDL_CondWait" condWaitFFI :: Ptr Cond -> Ptr Mutex -> IO CInt 71 | foreign import ccall "SDL.h SDL_CondWaitTimeout" condWaitTimeoutFFI :: Ptr Cond -> Ptr Mutex -> Word32 -> IO CInt 72 | foreign import ccall "SDL.h SDL_CreateCond" createCondFFI :: IO (Ptr Cond) 73 | foreign import ccall "SDL.h SDL_CreateMutex" createMutexFFI :: IO (Ptr Mutex) 74 | foreign import ccall "SDL.h SDL_CreateSemaphore" createSemaphoreFFI :: Word32 -> IO (Ptr Sem) 75 | foreign import ccall "SDL.h SDL_DestroyCond" destroyCondFFI :: Ptr Cond -> IO () 76 | foreign import ccall "SDL.h SDL_DestroyMutex" destroyMutexFFI :: Ptr Mutex -> IO () 77 | foreign import ccall "SDL.h SDL_DestroySemaphore" destroySemaphoreFFI :: Ptr Sem -> IO () 78 | foreign import ccall "SDL.h SDL_LockMutex" lockMutexFFI :: Ptr Mutex -> IO CInt 79 | foreign import ccall "SDL.h SDL_SemPost" semPostFFI :: Ptr Sem -> IO CInt 80 | foreign import ccall "SDL.h SDL_SemTryWait" semTryWaitFFI :: Ptr Sem -> IO CInt 81 | foreign import ccall "SDL.h SDL_SemValue" semValueFFI :: Ptr Sem -> IO Word32 82 | foreign import ccall "SDL.h SDL_SemWait" semWaitFFI :: Ptr Sem -> IO CInt 83 | foreign import ccall "SDL.h SDL_SemWaitTimeout" semWaitTimeoutFFI :: Ptr Sem -> Word32 -> IO CInt 84 | foreign import ccall "SDL.h SDL_TryLockMutex" tryLockMutexFFI :: Ptr Mutex -> IO CInt 85 | foreign import ccall "SDL.h SDL_UnlockMutex" unlockMutexFFI :: Ptr Mutex -> IO CInt 86 | 87 | foreign import ccall "SDL.h SDL_AtomicAdd" atomicAddFFI :: Ptr Atomic -> CInt -> IO CInt 88 | foreign import ccall "SDL.h SDL_AtomicCAS" atomicCASFFI :: Ptr Atomic -> CInt -> CInt -> IO Bool 89 | foreign import ccall "SDL.h SDL_AtomicCASPtr" atomicCASPtrFFI :: Ptr (Ptr ()) -> Ptr () -> Ptr () -> IO Bool 90 | foreign import ccall "SDL.h SDL_AtomicGet" atomicGetFFI :: Ptr Atomic -> IO CInt 91 | foreign import ccall "SDL.h SDL_AtomicGetPtr" atomicGetPtrFFI :: Ptr (Ptr ()) -> IO (Ptr ()) 92 | foreign import ccall "SDL.h SDL_AtomicLock" atomicLockFFI :: Ptr SpinLock -> IO () 93 | foreign import ccall "SDL.h SDL_AtomicSet" atomicSetFFI :: Ptr Atomic -> CInt -> IO CInt 94 | foreign import ccall "SDL.h SDL_AtomicSetPtr" atomicSetPtrFFI :: Ptr (Ptr ()) -> Ptr () -> IO (Ptr ()) 95 | foreign import ccall "SDL.h SDL_AtomicTryLock" atomicTryLockFFI :: Ptr SpinLock -> IO Bool 96 | foreign import ccall "SDL.h SDL_AtomicUnlock" atomicUnlockFFI :: Ptr SpinLock -> IO () 97 | 98 | createThread :: MonadIO m => ThreadFunction -> CString -> m (Ptr ()) 99 | createThread v1 v2 = liftIO $ createThreadFFI v1 v2 100 | {-# INLINE createThread #-} 101 | 102 | detachThread :: MonadIO m => Ptr Thread -> m () 103 | detachThread v1 = liftIO $ detachThreadFFI v1 104 | {-# INLINE detachThread #-} 105 | 106 | getThreadID :: MonadIO m => Ptr Thread -> m ThreadID 107 | getThreadID v1 = liftIO $ getThreadIDFFI v1 108 | {-# INLINE getThreadID #-} 109 | 110 | getThreadName :: MonadIO m => Ptr Thread -> m CString 111 | getThreadName v1 = liftIO $ getThreadNameFFI v1 112 | {-# INLINE getThreadName #-} 113 | 114 | setThreadPriority :: MonadIO m => ThreadPriority -> m CInt 115 | setThreadPriority v1 = liftIO $ setThreadPriorityFFI v1 116 | {-# INLINE setThreadPriority #-} 117 | 118 | tlsCreate :: MonadIO m => m TLSID 119 | tlsCreate = liftIO tlsCreateFFI 120 | {-# INLINE tlsCreate #-} 121 | 122 | tlsGet :: MonadIO m => TLSID -> m (Ptr ()) 123 | tlsGet v1 = liftIO $ tlsGetFFI v1 124 | {-# INLINE tlsGet #-} 125 | 126 | tlsSet :: MonadIO m => TLSID -> Ptr () -> FunPtr (Ptr () -> IO ()) -> m CInt 127 | tlsSet v1 v2 v3 = liftIO $ tlsSetFFI v1 v2 v3 128 | {-# INLINE tlsSet #-} 129 | 130 | threadID :: MonadIO m => m ThreadID 131 | threadID = liftIO threadIDFFI 132 | {-# INLINE threadID #-} 133 | 134 | waitThread :: MonadIO m => Ptr Thread -> Ptr CInt -> m () 135 | waitThread v1 v2 = liftIO $ waitThreadFFI v1 v2 136 | {-# INLINE waitThread #-} 137 | 138 | condBroadcast :: MonadIO m => Ptr Cond -> m CInt 139 | condBroadcast v1 = liftIO $ condBroadcastFFI v1 140 | {-# INLINE condBroadcast #-} 141 | 142 | condSignal :: MonadIO m => Ptr Cond -> m CInt 143 | condSignal v1 = liftIO $ condSignalFFI v1 144 | {-# INLINE condSignal #-} 145 | 146 | condWait :: MonadIO m => Ptr Cond -> Ptr Mutex -> m CInt 147 | condWait v1 v2 = liftIO $ condWaitFFI v1 v2 148 | {-# INLINE condWait #-} 149 | 150 | condWaitTimeout :: MonadIO m => Ptr Cond -> Ptr Mutex -> Word32 -> m CInt 151 | condWaitTimeout v1 v2 v3 = liftIO $ condWaitTimeoutFFI v1 v2 v3 152 | {-# INLINE condWaitTimeout #-} 153 | 154 | createCond :: MonadIO m => m (Ptr Cond) 155 | createCond = liftIO createCondFFI 156 | {-# INLINE createCond #-} 157 | 158 | createMutex :: MonadIO m => m (Ptr Mutex) 159 | createMutex = liftIO createMutexFFI 160 | {-# INLINE createMutex #-} 161 | 162 | createSemaphore :: MonadIO m => Word32 -> m (Ptr Sem) 163 | createSemaphore v1 = liftIO $ createSemaphoreFFI v1 164 | {-# INLINE createSemaphore #-} 165 | 166 | destroyCond :: MonadIO m => Ptr Cond -> m () 167 | destroyCond v1 = liftIO $ destroyCondFFI v1 168 | {-# INLINE destroyCond #-} 169 | 170 | destroyMutex :: MonadIO m => Ptr Mutex -> m () 171 | destroyMutex v1 = liftIO $ destroyMutexFFI v1 172 | {-# INLINE destroyMutex #-} 173 | 174 | destroySemaphore :: MonadIO m => Ptr Sem -> m () 175 | destroySemaphore v1 = liftIO $ destroySemaphoreFFI v1 176 | {-# INLINE destroySemaphore #-} 177 | 178 | lockMutex :: MonadIO m => Ptr Mutex -> m CInt 179 | lockMutex v1 = liftIO $ lockMutexFFI v1 180 | {-# INLINE lockMutex #-} 181 | 182 | semPost :: MonadIO m => Ptr Sem -> m CInt 183 | semPost v1 = liftIO $ semPostFFI v1 184 | {-# INLINE semPost #-} 185 | 186 | semTryWait :: MonadIO m => Ptr Sem -> m CInt 187 | semTryWait v1 = liftIO $ semTryWaitFFI v1 188 | {-# INLINE semTryWait #-} 189 | 190 | semValue :: MonadIO m => Ptr Sem -> m Word32 191 | semValue v1 = liftIO $ semValueFFI v1 192 | {-# INLINE semValue #-} 193 | 194 | semWait :: MonadIO m => Ptr Sem -> m CInt 195 | semWait v1 = liftIO $ semWaitFFI v1 196 | {-# INLINE semWait #-} 197 | 198 | semWaitTimeout :: MonadIO m => Ptr Sem -> Word32 -> m CInt 199 | semWaitTimeout v1 v2 = liftIO $ semWaitTimeoutFFI v1 v2 200 | {-# INLINE semWaitTimeout #-} 201 | 202 | tryLockMutex :: MonadIO m => Ptr Mutex -> m CInt 203 | tryLockMutex v1 = liftIO $ tryLockMutexFFI v1 204 | {-# INLINE tryLockMutex #-} 205 | 206 | unlockMutex :: MonadIO m => Ptr Mutex -> m CInt 207 | unlockMutex v1 = liftIO $ unlockMutexFFI v1 208 | {-# INLINE unlockMutex #-} 209 | 210 | atomicAdd :: MonadIO m => Ptr Atomic -> CInt -> m CInt 211 | atomicAdd v1 v2 = liftIO $ atomicAddFFI v1 v2 212 | {-# INLINE atomicAdd #-} 213 | 214 | atomicCAS :: MonadIO m => Ptr Atomic -> CInt -> CInt -> m Bool 215 | atomicCAS v1 v2 v3 = liftIO $ atomicCASFFI v1 v2 v3 216 | {-# INLINE atomicCAS #-} 217 | 218 | atomicCASPtr :: MonadIO m => Ptr (Ptr ()) -> Ptr () -> Ptr () -> m Bool 219 | atomicCASPtr v1 v2 v3 = liftIO $ atomicCASPtrFFI v1 v2 v3 220 | {-# INLINE atomicCASPtr #-} 221 | 222 | atomicDecRef :: Ptr Atomic -> IO Bool 223 | atomicDecRef a = do 224 | old <- atomicAdd a (-1) 225 | return $ old == 1 226 | {-# INLINE atomicDecRef #-} 227 | 228 | atomicGet :: MonadIO m => Ptr Atomic -> m CInt 229 | atomicGet v1 = liftIO $ atomicGetFFI v1 230 | {-# INLINE atomicGet #-} 231 | 232 | atomicGetPtr :: MonadIO m => Ptr (Ptr ()) -> m (Ptr ()) 233 | atomicGetPtr v1 = liftIO $ atomicGetPtrFFI v1 234 | {-# INLINE atomicGetPtr #-} 235 | 236 | atomicIncRef :: Ptr Atomic -> IO CInt 237 | atomicIncRef a = atomicAdd a 1 238 | {-# INLINE atomicIncRef #-} 239 | 240 | atomicLock :: MonadIO m => Ptr SpinLock -> m () 241 | atomicLock v1 = liftIO $ atomicLockFFI v1 242 | {-# INLINE atomicLock #-} 243 | 244 | atomicSet :: MonadIO m => Ptr Atomic -> CInt -> m CInt 245 | atomicSet v1 v2 = liftIO $ atomicSetFFI v1 v2 246 | {-# INLINE atomicSet #-} 247 | 248 | atomicSetPtr :: MonadIO m => Ptr (Ptr ()) -> Ptr () -> m (Ptr ()) 249 | atomicSetPtr v1 v2 = liftIO $ atomicSetPtrFFI v1 v2 250 | {-# INLINE atomicSetPtr #-} 251 | 252 | atomicTryLock :: MonadIO m => Ptr SpinLock -> m Bool 253 | atomicTryLock v1 = liftIO $ atomicTryLockFFI v1 254 | {-# INLINE atomicTryLock #-} 255 | 256 | atomicUnlock :: MonadIO m => Ptr SpinLock -> m () 257 | atomicUnlock v1 = liftIO $ atomicUnlockFFI v1 258 | {-# INLINE atomicUnlock #-} 259 | -------------------------------------------------------------------------------- /src/SDL/Raw/Timer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module SDL.Raw.Timer ( 4 | -- * Timer Support 5 | addTimer, 6 | delay, 7 | getPerformanceCounter, 8 | getPerformanceFrequency, 9 | getTicks, 10 | removeTimer 11 | 12 | #ifdef RECENT_ISH 13 | , getTicks64 14 | #endif 15 | ) where 16 | 17 | import Control.Monad.IO.Class 18 | import Data.Word 19 | import Foreign.C.Types 20 | import Foreign.Ptr 21 | import SDL.Raw.Types 22 | 23 | foreign import ccall "SDL.h SDL_AddTimer" addTimerFFI :: Word32 -> TimerCallback -> Ptr () -> IO TimerID 24 | foreign import ccall "SDL.h SDL_Delay" delayFFI :: Word32 -> IO () 25 | foreign import ccall "SDL.h SDL_GetPerformanceCounter" getPerformanceCounterFFI :: IO Word64 26 | foreign import ccall "SDL.h SDL_GetPerformanceFrequency" getPerformanceFrequencyFFI :: IO Word64 27 | foreign import ccall "SDL.h SDL_GetTicks" getTicksFFI :: IO Word32 28 | foreign import ccall "SDL.h SDL_RemoveTimer" removeTimerFFI :: TimerID -> IO Bool 29 | 30 | #ifdef RECENT_ISH 31 | foreign import ccall "SDL.h SDL_GetTicks64" getTicks64FFI :: IO Word64 32 | #endif 33 | 34 | addTimer :: MonadIO m => Word32 -> TimerCallback -> Ptr () -> m TimerID 35 | addTimer v1 v2 v3 = liftIO $ addTimerFFI v1 v2 v3 36 | {-# INLINE addTimer #-} 37 | 38 | delay :: MonadIO m => Word32 -> m () 39 | delay v1 = liftIO $ delayFFI v1 40 | {-# INLINE delay #-} 41 | 42 | getPerformanceCounter :: MonadIO m => m Word64 43 | getPerformanceCounter = liftIO getPerformanceCounterFFI 44 | {-# INLINE getPerformanceCounter #-} 45 | 46 | getPerformanceFrequency :: MonadIO m => m Word64 47 | getPerformanceFrequency = liftIO getPerformanceFrequencyFFI 48 | {-# INLINE getPerformanceFrequency #-} 49 | 50 | getTicks :: MonadIO m => m Word32 51 | getTicks = liftIO getTicksFFI 52 | {-# INLINE getTicks #-} 53 | 54 | removeTimer :: MonadIO m => TimerID -> m Bool 55 | removeTimer v1 = liftIO $ removeTimerFFI v1 56 | {-# INLINE removeTimer #-} 57 | 58 | #ifdef RECENT_ISH 59 | getTicks64 :: MonadIO m => m Word64 60 | getTicks64 = liftIO getTicks64FFI 61 | {-# INLINE getTicks64 #-} 62 | #endif 63 | -------------------------------------------------------------------------------- /src/SDL/Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE CPP #-} 6 | module SDL.Time 7 | ( -- * Time Measurement 8 | ticks 9 | , time 10 | 11 | -- * Timer 12 | , delay 13 | , TimerCallback 14 | , Timer 15 | , RetriggerTimer(..) 16 | , addTimer 17 | , removeTimer 18 | 19 | #ifdef RECENT_ISH 20 | , ticks64 21 | #endif 22 | ) where 23 | 24 | import Control.Monad.IO.Class (MonadIO, liftIO) 25 | import Data.Data (Data) 26 | import Data.Typeable 27 | import Data.Word 28 | import Foreign 29 | import GHC.Generics (Generic) 30 | 31 | import SDL.Internal.Exception 32 | 33 | import qualified SDL.Raw.Timer as Raw 34 | import qualified SDL.Raw.Types as Raw 35 | 36 | -- | Number of milliseconds since library initialization. 37 | -- 38 | -- See @@ for C documentation. 39 | ticks :: MonadIO m => m Word32 40 | ticks = Raw.getTicks 41 | 42 | -- | The current time in seconds since some arbitrary starting point (consist over the life of the application). 43 | -- 44 | -- This time is derived from the system's performance counter - see @@ and @@ for C documentation about the implementation. 45 | time :: (Fractional a, MonadIO m) => m a 46 | time = do 47 | freq <- Raw.getPerformanceFrequency 48 | cnt <- Raw.getPerformanceCounter 49 | return $ fromIntegral cnt / fromIntegral freq 50 | 51 | -- | Wait a specified number of milliseconds before returning. 52 | -- 53 | -- Users are generally recommended to use 'threadDelay' instead, to take advantage of the abilities of the Haskell runtime. 54 | -- 55 | -- See @@ for C documentation. 56 | delay :: MonadIO m => Word32 -> m () 57 | delay = Raw.delay 58 | 59 | -- | 'RetriggerTimer' allows a callback to inform SDL if the timer should be retriggered or cancelled 60 | data RetriggerTimer 61 | = Reschedule Word32 62 | -- ^ Retrigger the timer again in a given number of milliseconds. 63 | | Cancel 64 | -- ^ Cancel future invocations of this timer. 65 | deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) 66 | 67 | -- | A 'TimerCallback' is called with the interval size of the callback. It can return information as to whether or not the timer should continue to exist. 68 | type TimerCallback = Word32 -> IO RetriggerTimer 69 | 70 | -- | A timer created by 'addTimer'. This 'Timer' can be removed with 'removeTimer'. 71 | newtype Timer = 72 | Timer {runTimerRemoval :: IO Bool} 73 | 74 | -- | Set up a callback function to be run on a separate thread after the specified number of milliseconds has elapsed. 75 | -- 76 | -- See @@ for C documentation. 77 | addTimer :: MonadIO m => Word32 -> TimerCallback -> m Timer 78 | addTimer timeout callback = liftIO $ do 79 | cb <- Raw.mkTimerCallback wrappedCb 80 | tid <- throwIf0 "addTimer" "SDL_AddTimer" $ Raw.addTimer timeout cb nullPtr 81 | return (Timer $ auxRemove cb tid) 82 | where 83 | wrappedCb :: Word32 -> Ptr () -> IO Word32 84 | wrappedCb w _ = do 85 | next <- callback w 86 | return $ case next of 87 | Cancel -> 0 88 | Reschedule n -> n 89 | 90 | auxRemove :: Raw.TimerCallback -> Raw.TimerID -> IO Bool 91 | auxRemove cb tid = do 92 | isSuccess <- Raw.removeTimer tid 93 | if (isSuccess) 94 | then freeHaskellFunPtr cb >> return True 95 | else return False 96 | 97 | -- | Remove a 'Timer'. 98 | -- 99 | -- See @@ for C documentation. 100 | removeTimer :: MonadIO m => Timer -> m Bool 101 | removeTimer f = liftIO $ runTimerRemoval f 102 | 103 | #ifdef RECENT_ISH 104 | -- | Number of milliseconds since library initialization. 105 | -- 106 | -- See @@ for C documentation. 107 | ticks64 :: MonadIO m => m Word64 108 | ticks64 = Raw.getTicks64 109 | #endif 110 | -------------------------------------------------------------------------------- /src/SDL/Vect.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | SDL's vector representation. 4 | -- 5 | -- By default, re-exports the "Linear" and "Linear.Affine" modules from the 6 | -- 'linear' package. With the @no-linear@ Cabal flag, instead exports a 7 | -- duplicate implementation of the 'V2', 'V3', 'V4' and 'Point' types from 8 | -- "SDL.Internal.Vect", which provides as many instances as possible for those 9 | -- types while avoiding any additional dependencies. 10 | module SDL.Vect 11 | ( module Vect 12 | -- * Point 13 | , Point (..) 14 | -- * Vectors 15 | , V2 (..) 16 | , V3 (..) 17 | , V4 (..) 18 | ) where 19 | 20 | #if defined(nolinear) 21 | import SDL.Internal.Vect as Vect 22 | #else 23 | import Linear as Vect 24 | import Linear.Affine as Vect 25 | #endif 26 | -------------------------------------------------------------------------------- /src/SDL/Video/OpenGL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | 8 | module SDL.Video.OpenGL 9 | ( -- * Creating and Configuring OpenGL Contexts 10 | defaultOpenGL 11 | , OpenGLConfig(..) 12 | , GLContext 13 | , glCreateContext 14 | , Profile(..) 15 | , Mode(..) 16 | , glMakeCurrent 17 | , glDeleteContext 18 | 19 | -- * Querying for the drawable size without a Renderer 20 | , glGetDrawableSize 21 | 22 | -- * Swapping 23 | -- | The process of \"swapping\" means to move the back-buffer into the window contents itself. 24 | , glSwapWindow 25 | , SwapInterval(..) 26 | , swapInterval 27 | 28 | -- * Function Loading 29 | , Raw.glGetProcAddress 30 | ) where 31 | 32 | import Control.Monad.IO.Class (MonadIO, liftIO) 33 | import Data.Data (Data) 34 | import Data.StateVar 35 | import Data.Typeable 36 | import Foreign hiding (void, throwIfNull, throwIfNeg, throwIfNeg_) 37 | import Foreign.C.Types 38 | import GHC.Generics (Generic) 39 | import SDL.Vect 40 | import SDL.Internal.Exception 41 | import SDL.Internal.Numbered 42 | import SDL.Internal.Types 43 | import qualified SDL.Raw as Raw 44 | 45 | #if !MIN_VERSION_base(4,8,0) 46 | import Control.Applicative 47 | #endif 48 | 49 | -- | A set of default options for 'OpenGLConfig' 50 | -- 51 | -- @ 52 | -- 'defaultOpenGL' = 'OpenGLConfig' 53 | -- { 'glColorPrecision' = V4 8 8 8 0 54 | -- , 'glDepthPrecision' = 24 55 | -- , 'glStencilPrecision' = 8 56 | -- , 'glMultisampleSamples' = 1 57 | -- , 'glProfile' = 'Compatibility' 'Normal' 2 1 58 | -- } 59 | -- @ 60 | defaultOpenGL :: OpenGLConfig 61 | defaultOpenGL = OpenGLConfig 62 | { glColorPrecision = V4 8 8 8 0 63 | , glDepthPrecision = 24 64 | , glStencilPrecision = 8 65 | , glMultisampleSamples = 1 66 | , glProfile = Compatibility Normal 2 1 67 | } 68 | 69 | -- | Configuration used when creating an OpenGL rendering context. 70 | data OpenGLConfig = OpenGLConfig 71 | { glColorPrecision :: V4 CInt -- ^ Defaults to 'V4' @8 8 8 0@. 72 | , glDepthPrecision :: CInt -- ^ Defaults to @24@. 73 | , glStencilPrecision :: CInt -- ^ Defaults to @8@. 74 | , glMultisampleSamples :: CInt -- ^ Defaults to @1@. 75 | , glProfile :: Profile -- ^ Defaults to 'Compatibility' 'Normal' @2 1@. 76 | } deriving (Eq, Generic, Ord, Read, Show, Typeable) 77 | 78 | -- | The profile a driver should use when creating an OpenGL context. 79 | data Profile 80 | = Core Mode CInt CInt 81 | -- ^ Use the OpenGL core profile, with a given major and minor version 82 | | Compatibility Mode CInt CInt 83 | -- ^ Use the compatibilty profile with a given major and minor version. The compatibility profile allows you to use deprecated functions such as immediate mode 84 | | ES Mode CInt CInt 85 | -- ^ Use an OpenGL profile for embedded systems 86 | deriving (Eq, Generic, Ord, Read, Show, Typeable) 87 | 88 | -- | The mode a driver should use when creating an OpenGL context. 89 | data Mode 90 | = Normal 91 | -- ^ A normal profile with no special debugging support 92 | | Debug 93 | -- ^ Use a debug context, allowing the usage of extensions such as @GL_ARB_debug_output@ 94 | deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) 95 | 96 | -- | A created OpenGL context. 97 | newtype GLContext = GLContext Raw.GLContext 98 | deriving (Eq, Typeable) 99 | 100 | -- | Create a new OpenGL context and makes it the current context for the 101 | -- window. 102 | -- 103 | -- Throws 'SDLException' if the window wasn't configured with OpenGL 104 | -- support, or if context creation fails. 105 | -- 106 | -- See @@ for C documentation. 107 | glCreateContext :: (Functor m, MonadIO m) => Window -> m GLContext 108 | glCreateContext (Window w) = 109 | GLContext <$> throwIfNull "SDL.Video.glCreateContext" "SDL_GL_CreateContext" 110 | (Raw.glCreateContext w) 111 | 112 | -- | Set up an OpenGL context for rendering into an OpenGL window. 113 | -- 114 | -- Throws 'SDLException' on failure. 115 | -- 116 | -- See @@ for C documentation. 117 | glMakeCurrent :: (Functor m, MonadIO m) => Window -> GLContext -> m () 118 | glMakeCurrent (Window w) (GLContext ctx) = 119 | throwIfNeg_ "SDL.Video.OpenGL.glMakeCurrent" "SDL_GL_MakeCurrent" $ 120 | Raw.glMakeCurrent w ctx 121 | 122 | -- | Delete the given OpenGL context. 123 | -- 124 | -- You /must/ make sure that there are no pending commands in the OpenGL 125 | -- command queue, the driver may still be processing commands even if you have 126 | -- stopped issuing them! 127 | -- 128 | -- The @glFinish@ command will block until the command queue has been fully 129 | -- processed. You should call that function before deleting a context. 130 | -- 131 | -- See @@ for C documentation. 132 | glDeleteContext :: MonadIO m => GLContext -> m () 133 | glDeleteContext (GLContext ctx) = Raw.glDeleteContext ctx 134 | 135 | -- | Replace the contents of the front buffer with the back buffer's. The 136 | -- contents of the back buffer are undefined, clear them with @glClear@ or 137 | -- equivalent before drawing to them again. 138 | -- 139 | -- See @@ for C documentation. 140 | glSwapWindow :: MonadIO m => Window -> m () 141 | glSwapWindow (Window w) = Raw.glSwapWindow w 142 | 143 | -- | The swap interval for the current OpenGL context. 144 | data SwapInterval 145 | = ImmediateUpdates 146 | -- ^ No vertical retrace synchronization 147 | | SynchronizedUpdates 148 | -- ^ The buffer swap is synchronized with the vertical retrace 149 | | LateSwapTearing 150 | deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) 151 | 152 | instance ToNumber SwapInterval CInt where 153 | toNumber ImmediateUpdates = 0 154 | toNumber SynchronizedUpdates = 1 155 | toNumber LateSwapTearing = -1 156 | 157 | instance FromNumber SwapInterval CInt where 158 | fromNumber n' = 159 | case n' of 160 | 0 -> ImmediateUpdates 161 | 1 -> SynchronizedUpdates 162 | -1 -> LateSwapTearing 163 | _ -> 164 | error ("Unknown SwapInterval: " ++ show n') 165 | 166 | -- | Get or set the swap interval for the current OpenGL context. 167 | -- 168 | -- This 'StateVar' can be modified using '$=' and the current value retrieved with 'get'. 169 | -- 170 | -- See @@ and @@ for C documentation. 171 | swapInterval :: StateVar SwapInterval 172 | swapInterval = makeStateVar glGetSwapInterval glSetSwapInterval 173 | where 174 | glGetSwapInterval = fmap fromNumber $ Raw.glGetSwapInterval 175 | 176 | glSetSwapInterval i = 177 | throwIfNeg_ "SDL.Video.glSetSwapInterval" "SDL_GL_SetSwapInterval" $ 178 | Raw.glSetSwapInterval (toNumber i) 179 | 180 | -- | Get the size of a window's underlying drawable area in pixels (for use 181 | -- with glViewport). 182 | -- 183 | -- It may differ from 'SDL.Video.windowSize' if window was created with 'SDL.Video.windowHighDPI' flag. 184 | glGetDrawableSize :: MonadIO m => Window -> m (V2 CInt) 185 | glGetDrawableSize (Window w) = 186 | liftIO $ 187 | alloca $ \wptr -> 188 | alloca $ \hptr -> do 189 | Raw.glGetDrawableSize w wptr hptr 190 | V2 <$> peek wptr <*> peek hptr 191 | -------------------------------------------------------------------------------- /src/SDL/Video/Vulkan.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | 5 | module SDL.Video.Vulkan ( 6 | -- * Vulkan types 7 | VkInstance, VkSurfaceKHR, VkGetInstanceProcAddrFunc, 8 | -- * Vulkan loader 9 | vkLoadLibrary, vkUnloadLibrary, vkGetVkGetInstanceProcAddr, 10 | -- * Vulkan surface 11 | vkGetInstanceExtensions, vkCreateSurface, 12 | -- * Querying for the drawable size 13 | vkGetDrawableSize 14 | ) where 15 | 16 | import Control.Monad.IO.Class (MonadIO, liftIO) 17 | import Foreign hiding (throwIf_, throwIfNeg_) 18 | import Foreign.C.Types (CInt) 19 | import Foreign.C.String (CString, withCString) 20 | import SDL.Vect (V2 (V2)) 21 | import SDL.Internal.Exception (throwIf_, throwIfNeg_) 22 | import SDL.Internal.Types (Window (Window)) 23 | import SDL.Raw.Types (VkInstance, VkSurfaceKHR, VkGetInstanceProcAddrFunc) 24 | import qualified SDL.Raw as Raw 25 | 26 | #if !MIN_VERSION_base(4,8,0) 27 | import Control.Applicative 28 | #endif 29 | 30 | -- | Dynamically load a Vulkan loader library. 31 | -- 32 | -- If a filePath is 'Nothing', SDL will use the value of the environment variable 33 | -- SDL_VULKAN_LIBRARY, if set, otherwise it loads the default Vulkan 34 | -- loader library. 35 | -- 36 | -- This function should be called after initializing the video driver 37 | -- (i.e. 'SDL.Init.initialize' ['SDL.Init.InitVideo']), but before 38 | -- creating any windows with 'SDL.Video.windowGraphicsContext' = 'SDL.Video.VulkanContext'. 39 | -- 40 | -- If no Vulkan loader library is loaded, analogue of 'vkLoadLibrary' 'Nothing' 41 | -- will be automatically called by SDL C library upon creation of the first Vulkan window. 42 | -- 43 | -- Throws 'SDL.Exception.SDLException' if there are no working Vulkan drivers installed. 44 | vkLoadLibrary :: MonadIO m => Maybe FilePath -> m () 45 | vkLoadLibrary = \case 46 | Nothing -> liftIO . testNeg $ Raw.vkLoadLibrary nullPtr 47 | Just filePath -> liftIO . withCString filePath $ testNeg . Raw.vkLoadLibrary 48 | where 49 | testNeg = throwIfNeg_ "SDL.Video.Vulkan.vkLoadLibrary" "SDL_Vulkan_LoadLibrary" 50 | 51 | -- | Unload the Vulkan loader library previously loaded by 'vkLoadLibrary'. 52 | -- 53 | -- Analogue of this function will be automatically called by SDL C library 54 | -- after destruction of the last window with 55 | -- 'SDL.Video.windowGraphicsContext' = 'SDL.Video.VulkanContext'. 56 | vkUnloadLibrary :: MonadIO m => m () 57 | vkUnloadLibrary = Raw.vkUnloadLibrary 58 | 59 | foreign import ccall "dynamic" mkVkGetInstanceProcAddrFunc :: 60 | FunPtr VkGetInstanceProcAddrFunc -> VkGetInstanceProcAddrFunc 61 | 62 | -- | Get the vkGetInstanceProcAddr function, which can be used to obtain another Vulkan functions 63 | -- (see ). 64 | -- 65 | -- The 'vkGetVkGetInstanceProcAddr' function should be called after either calling 'vkLoadLibrary' 66 | -- function or creating first Vulkan window. 67 | vkGetVkGetInstanceProcAddr :: (Functor m, MonadIO m) => m VkGetInstanceProcAddrFunc 68 | vkGetVkGetInstanceProcAddr = mkVkGetInstanceProcAddrFunc <$> Raw.vkGetVkGetInstanceProcAddr 69 | 70 | -- | Get the names of the Vulkan instance extensions needed to create 71 | -- a surface with 'vkCreateSurface'. 72 | -- 73 | -- The extension names queried here must be enabled when calling vkCreateInstance 74 | -- (see ), 75 | -- otherwise 'vkCreateSurface' will fail. 76 | -- 77 | -- Window should have been created with 'SDL.Video.windowGraphicsContext' = 'SDL.Video.VulkanContext'. 78 | -- 79 | -- Throws 'SDL.Exception.SDLException' on failure. 80 | vkGetInstanceExtensions :: MonadIO m => Window -> m [CString] 81 | vkGetInstanceExtensions (Window w) = liftIO . alloca $ \countPtr -> do 82 | throwIf_ not "SDL.Video.Vulkan.vkGetInstanceExtensions (1)" "SDL_Vulkan_GetInstanceExtensions" $ 83 | Raw.vkGetInstanceExtensions w countPtr nullPtr 84 | count <- fromIntegral <$> peek countPtr 85 | allocaArray count $ \sPtr -> 86 | throwIf_ not "SDL.Video.Vulkan.vkGetInstanceExtensions (2)" "SDL_Vulkan_GetInstanceExtensions" 87 | (Raw.vkGetInstanceExtensions w countPtr sPtr) >> peekArray count sPtr 88 | 89 | -- | Create a Vulkan rendering surface for a window. 90 | -- 91 | -- Window should have been created with 'SDL.Video.windowGraphicsContext' = 'SDL.Video.VulkanContext'. 92 | -- 93 | -- Instance should have been created with the extensions returned 94 | -- by 'vkGetInstanceExtensions' enabled. 95 | -- 96 | -- Throws 'SDL.Exception.SDLException' on failure. 97 | vkCreateSurface :: MonadIO m => Window -> VkInstance -> m VkSurfaceKHR 98 | vkCreateSurface (Window w) vkInstance = liftIO . alloca $ \vkSurfacePtr -> 99 | throwIf_ not "SDL.Video.Vulkan.vkCreateSurface" "SDL_Vulkan_CreateSurface" 100 | (Raw.vkCreateSurface w vkInstance vkSurfacePtr) >> peek vkSurfacePtr 101 | 102 | -- | Get the size of a window's underlying drawable area in pixels (for use 103 | -- with setting viewport, scissor & etc). 104 | -- 105 | -- It may differ from 'SDL.Video.windowSize' if window was created with 'SDL.Video.windowHighDPI' flag. 106 | vkGetDrawableSize :: MonadIO m => Window -> m (V2 CInt) 107 | vkGetDrawableSize (Window w) = liftIO . alloca $ \wptr -> 108 | alloca $ \hptr -> do 109 | Raw.vkGetDrawableSize w wptr hptr 110 | V2 <$> peek wptr <*> peek hptr 111 | --------------------------------------------------------------------------------