├── Setup.hs ├── .gitignore ├── LICENSE ├── README.md ├── .travis.yml ├── sdl2-image.cabal ├── example └── Example.hs └── src └── SDL ├── Raw ├── Helper.hs └── Image.hsc └── Image.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .virtualenv 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | .stack-work 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Siniša Biđin 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # sdl2-image 2 | 3 | [![Hackage](https://img.shields.io/hackage/v/sdl2-image.svg)](https://hackage.haskell.org/package/sdl2-image) 4 | [![Build Status](https://travis-ci.org/sbidin/sdl2-image.svg?branch=master)](https://travis-ci.org/sbidin/sdl2-image) 5 | 6 | #### Haskell bindings to SDL2_image 7 | 8 | Both the raw and the higher level bindings should allow you to use any aspect 9 | of the original SDL2_image library. Please report an issue if you encounter a 10 | bug or feel that something is missing. 11 | 12 | ##### Install 13 | 14 | ```bash 15 | cabal install sdl2-image 16 | ``` 17 | 18 | ##### Documentation 19 | 20 | For documentation, [visit Hackage](https://hackage.haskell.org/package/sdl2-image). 21 | 22 | The 23 | [original SDL2_image documentation](http://www.libsdl.org/projects/SDL_image/docs/SDL_image.html) 24 | can also help, as the bindings are close to a direct mapping. 25 | 26 | ##### Example 27 | 28 | A small example executable is included with the library. It loads and displays 29 | a given image. You can find it in the `example` directory. 30 | 31 | ```bash 32 | cd sdl2-image 33 | cabal run path/to/some/image.type 34 | ``` 35 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | 3 | sudo: required 4 | 5 | env: 6 | - GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 LD_LIBRARY_PATH=/usr/local/lib 7 | 8 | before_install: 9 | - cd .. 10 | 11 | # Install SDL. 12 | - wget -q http://www.libsdl.org/release/SDL2-2.0.3.tar.gz 13 | - tar xf SDL2-*.tar.gz 14 | - cd SDL2-* && ./configure && make && sudo make install && cd .. 15 | 16 | # Install SDL_image. 17 | - wget -q http://www.libsdl.org/projects/SDL_image/release/SDL2_image-2.0.0.tar.gz 18 | - tar xf SDL2_image-*.tar.gz 19 | - cd SDL2_image-* && ./configure && make && sudo make install && cd .. 20 | 21 | # Install GHC and cabal-install. 22 | - travis_retry sudo add-apt-repository -y ppa:hvr/ghc 23 | - travis_retry sudo apt-get update 24 | - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER happy-$HAPPYVER 25 | - export CABAL=/opt/cabal/bin/cabal-$CABALVER 26 | - export PATH=/opt/ghc/$GHCVER/bin:$PATH 27 | - rm -rf ~/.cabal 28 | - $CABAL update 29 | 30 | install: 31 | # Install haskell-game/sdl2. 32 | - git clone https://github.com/haskell-game/sdl2.git 33 | - cd sdl2 && $CABAL install --flags="no-linear" && cd .. 34 | 35 | script: 36 | - cd sdl2-image 37 | - $CABAL install --flags="example" 38 | -------------------------------------------------------------------------------- /sdl2-image.cabal: -------------------------------------------------------------------------------- 1 | name: sdl2-image 2 | version: 2.0.0 3 | synopsis: Bindings to SDL2_image. 4 | description: Haskell bindings to SDL2_image. 5 | license: MIT 6 | license-file: LICENSE 7 | author: Cai Lei , Siniša Biđin 8 | maintainer: Siniša Biđin 9 | copyright: Copyright © 2014 Cai Lei, Copyright © 2015 Siniša Biđin 10 | category: Image, Graphics, Foreign 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | 14 | source-repository head 15 | type: git 16 | location: https://github.com/sbidin/sdl2-image.git 17 | 18 | library 19 | ghc-options: -Wall 20 | 21 | exposed-modules: 22 | SDL.Image, 23 | SDL.Raw.Image 24 | 25 | other-modules: 26 | SDL.Raw.Helper 27 | 28 | hs-source-dirs: 29 | src 30 | 31 | pkgconfig-depends: 32 | sdl2 >= 2.0.3, 33 | SDL2_image >= 2.0.0 34 | 35 | build-depends: 36 | base >= 4.7 && < 5, 37 | bytestring >= 0.10.4.0, 38 | sdl2 >= 2.0, 39 | text >= 1.1.0.0, 40 | template-haskell 41 | 42 | default-language: 43 | Haskell2010 44 | 45 | if os(windows) 46 | cpp-options: -D_SDL_main_h -DSDL_main_h_ -DSDL_MAIN_HANDLED 47 | 48 | flag example 49 | description: Build the example executable 50 | default: False 51 | 52 | executable sdl2-image-example 53 | ghc-options: -Wall 54 | hs-source-dirs: example 55 | main-is: Example.hs 56 | default-language: Haskell2010 57 | 58 | if flag(example) 59 | build-depends: 60 | base >= 4.7 && < 5, 61 | sdl2 >= 2.0, 62 | sdl2-image, 63 | text >= 1.1.0.0 64 | else 65 | buildable: False 66 | -------------------------------------------------------------------------------- /example/Example.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | module Main where 5 | 6 | import Control.Concurrent (threadDelay) 7 | import Control.Monad (forM_) 8 | import Data.Text (Text) 9 | import Data.Text.IO (putStrLn) 10 | import Prelude hiding (putStrLn) 11 | import System.Environment (getArgs) 12 | import System.Exit (exitFailure) 13 | 14 | import qualified SDL 15 | import qualified SDL.Image 16 | 17 | -- A sequence of example actions to be perfomed and displayed. 18 | examples :: [(Text, SDL.Window -> FilePath -> IO ())] 19 | examples = [ 20 | 21 | ("Loading as surface, blitting", 22 | \window path -> do 23 | image <- SDL.Image.load path 24 | screen <- SDL.getWindowSurface window 25 | SDL.surfaceBlit image Nothing screen Nothing 26 | SDL.updateWindowSurface window 27 | SDL.freeSurface image), 28 | 29 | ("Loading as texture, rendering", 30 | \window path -> do 31 | r <- SDL.createRenderer window (-1) SDL.defaultRenderer 32 | texture <- SDL.Image.loadTexture r path 33 | SDL.clear r 34 | SDL.copy r texture Nothing Nothing 35 | SDL.present r 36 | SDL.destroyTexture texture)] 37 | 38 | main :: IO () 39 | main = do 40 | 41 | SDL.initialize [SDL.InitVideo] 42 | 43 | getArgs >>= \case 44 | 45 | [] -> do 46 | putStrLn "Usage: cabal run path/to/image.(png|jpg|...)" 47 | exitFailure 48 | 49 | (path:_) -> 50 | -- Run each of the examples within a newly-created window. 51 | forM_ examples $ \(name, action) -> do 52 | putStrLn name 53 | window <- SDL.createWindow name SDL.defaultWindow 54 | SDL.showWindow window 55 | action window path 56 | threadDelay 1000000 57 | SDL.destroyWindow window 58 | 59 | SDL.quit 60 | -------------------------------------------------------------------------------- /src/SDL/Raw/Helper.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | 3 | Module : SDL.Raw.Helper 4 | Copyright : (c) 2015 Siniša Biđin 5 | License : MIT 6 | Maintainer : sinisa@bidin.eu 7 | Stability : experimental 8 | 9 | Exposes a way to automatically generate a foreign import alongside its lifted, 10 | inlined MonadIO variant. Use this to simplify the package's SDL.Raw.* modules. 11 | 12 | -} 13 | 14 | {-# LANGUAGE BangPatterns #-} 15 | {-# LANGUAGE LambdaCase #-} 16 | {-# LANGUAGE TemplateHaskell #-} 17 | 18 | module SDL.Raw.Helper (liftF) where 19 | 20 | import Control.Monad (replicateM) 21 | import Control.Monad.IO.Class (MonadIO, liftIO) 22 | import Language.Haskell.TH 23 | 24 | -- | Given a name @fname@, a name of a C function @cname@ and the desired 25 | -- Haskell type @ftype@, this function generates: 26 | -- 27 | -- * A foreign import of @cname@, named as @fname'@. 28 | -- * An always-inline MonadIO version of @fname'@, named @fname@. 29 | liftF :: String -> String -> Q Type -> Q [Dec] 30 | liftF fname cname ftype = do 31 | let f' = mkName $ fname ++ "'" -- Direct binding. 32 | let f = mkName fname -- Lifted. 33 | t' <- ftype -- Type of direct binding. 34 | 35 | -- The generated function accepts n arguments. 36 | args <- replicateM (countArgs t') $ newName "x" 37 | 38 | -- If the function has no arguments, then we just liftIO it directly. 39 | -- However, this fails to typecheck without an explicit type signature. 40 | -- Therefore, we include one. TODO: Can we get rid of this? 41 | sigd <- case args of 42 | [] -> ((:[]) . SigD f) `fmap` liftType t' 43 | _ -> return [] 44 | 45 | return $ concat 46 | [ 47 | [ ForeignD $ ImportF CCall Safe cname f' t' 48 | , PragmaD $ InlineP f Inline FunLike AllPhases 49 | ] 50 | , sigd 51 | , [ FunD f 52 | [ Clause 53 | (map VarP args) 54 | (NormalB $ 'liftIO `applyTo` [f' `applyTo` map VarE args]) 55 | [] 56 | ] 57 | ] 58 | ] 59 | 60 | -- | How many arguments does a function of a given type take? 61 | countArgs :: Type -> Int 62 | countArgs = count 0 63 | where 64 | count !n = \case 65 | (AppT (AppT ArrowT _) t) -> count (n+1) t 66 | (ForallT _ _ t) -> count n t 67 | (SigT t _) -> count n t 68 | _ -> n 69 | 70 | -- | An expression where f is applied to n arguments. 71 | applyTo :: Name -> [Exp] -> Exp 72 | applyTo f [] = VarE f 73 | applyTo f es = loop (tail es) . AppE (VarE f) $ head es 74 | where 75 | loop as e = foldl AppE e as 76 | 77 | -- | Fuzzily speaking, converts a given IO type into a MonadIO m one. 78 | liftType :: Type -> Q Type 79 | liftType = \case 80 | AppT _ t -> do 81 | m <- newName "m" 82 | return $ 83 | ForallT 84 | [PlainTV m] 85 | [AppT (ConT ''MonadIO) $ VarT m] 86 | (AppT (VarT m) t) 87 | t -> return t 88 | -------------------------------------------------------------------------------- /src/SDL/Raw/Image.hsc: -------------------------------------------------------------------------------- 1 | {-| 2 | 3 | Module : SDL.Raw.Image 4 | Copyright : (c) 2015 Siniša Biđin 5 | License : MIT 6 | Maintainer : sinisa@bidin.eu 7 | Stability : experimental 8 | 9 | Raw bindings to the @SDL2_image@ library. No error-handling is done here. For 10 | more information about specific function behaviour, see the @SDL2_image@ 11 | documentation. 12 | 13 | -} 14 | 15 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 16 | 17 | {-# LANGUAGE PatternSynonyms #-} 18 | {-# LANGUAGE TemplateHaskell #-} 19 | 20 | module SDL.Raw.Image 21 | ( 22 | -- * Loading images 23 | Free 24 | , load 25 | , load_RW 26 | , Format 27 | , loadTyped_RW 28 | , loadCUR_RW 29 | , loadICO_RW 30 | , loadBMP_RW 31 | , loadPNM_RW 32 | , loadXPM_RW 33 | , loadXCF_RW 34 | , loadPCX_RW 35 | , loadGIF_RW 36 | , loadJPG_RW 37 | , loadTIF_RW 38 | , loadPNG_RW 39 | , loadTGA_RW 40 | , loadLBM_RW 41 | , loadXV_RW 42 | , loadWEBP_RW 43 | 44 | -- * Testing for formats 45 | , isCUR 46 | , isICO 47 | , isBMP 48 | , isPNM 49 | , isXPM 50 | , isXCF 51 | , isPCX 52 | , isGIF 53 | , isJPG 54 | , isTIF 55 | , isPNG 56 | , isLBM 57 | , isXV 58 | , isWEBP 59 | 60 | -- * Other 61 | , InitFlags 62 | , pattern IMG_INIT_JPG 63 | , pattern IMG_INIT_PNG 64 | , pattern IMG_INIT_TIF 65 | , pattern IMG_INIT_WEBP 66 | , init 67 | , getVersion 68 | , quit 69 | ) where 70 | 71 | #include "SDL_image.h" 72 | 73 | import Foreign.C.String (CString) 74 | import Foreign.C.Types (CInt(..)) 75 | import Foreign.Ptr (Ptr) 76 | import Prelude hiding (init) 77 | import SDL.Raw.Types (Version, Surface, RWops) 78 | import SDL.Raw.Helper (liftF) 79 | 80 | liftF "getVersion" "IMG_Linked_Version" 81 | [t|IO (Ptr Version)|] 82 | 83 | type InitFlags = CInt 84 | 85 | pattern IMG_INIT_JPG = #{const IMG_INIT_JPG} 86 | pattern IMG_INIT_PNG = #{const IMG_INIT_PNG} 87 | pattern IMG_INIT_TIF = #{const IMG_INIT_TIF} 88 | pattern IMG_INIT_WEBP = #{const IMG_INIT_WEBP} 89 | 90 | liftF "init" "IMG_Init" 91 | [t|InitFlags -> IO InitFlags|] 92 | 93 | liftF "quit" "IMG_Quit" 94 | [t|IO ()|] 95 | 96 | liftF "load" "IMG_Load" 97 | [t|CString -> IO (Ptr Surface)|] 98 | 99 | -- | Should the 'Ptr' 'RWops' be freed after an operation? 1 for yes, 0 for no. 100 | type Free = CInt 101 | 102 | liftF "load_RW" "IMG_Load_RW" 103 | [t|Ptr RWops -> Free -> IO (Ptr Surface)|] 104 | 105 | -- | A case-insensitive desired format, e.g. @\"jpg\"@ or @\"PNG\"@. 106 | type Format = CString 107 | 108 | liftF "loadTyped_RW" "IMG_LoadTyped_RW" 109 | [t|Ptr RWops -> Free -> Format -> IO (Ptr Surface)|] 110 | 111 | liftF "loadCUR_RW" "IMG_LoadCUR_RW" [t|Ptr RWops -> IO (Ptr Surface)|] 112 | liftF "loadICO_RW" "IMG_LoadICO_RW" [t|Ptr RWops -> IO (Ptr Surface)|] 113 | liftF "loadBMP_RW" "IMG_LoadBMP_RW" [t|Ptr RWops -> IO (Ptr Surface)|] 114 | liftF "loadPNM_RW" "IMG_LoadPNM_RW" [t|Ptr RWops -> IO (Ptr Surface)|] 115 | liftF "loadXPM_RW" "IMG_LoadXPM_RW" [t|Ptr RWops -> IO (Ptr Surface)|] 116 | liftF "loadXCF_RW" "IMG_LoadXCF_RW" [t|Ptr RWops -> IO (Ptr Surface)|] 117 | liftF "loadPCX_RW" "IMG_LoadPCX_RW" [t|Ptr RWops -> IO (Ptr Surface)|] 118 | liftF "loadGIF_RW" "IMG_LoadGIF_RW" [t|Ptr RWops -> IO (Ptr Surface)|] 119 | liftF "loadJPG_RW" "IMG_LoadJPG_RW" [t|Ptr RWops -> IO (Ptr Surface)|] 120 | liftF "loadTIF_RW" "IMG_LoadTIF_RW" [t|Ptr RWops -> IO (Ptr Surface)|] 121 | liftF "loadPNG_RW" "IMG_LoadPNG_RW" [t|Ptr RWops -> IO (Ptr Surface)|] 122 | liftF "loadTGA_RW" "IMG_LoadTGA_RW" [t|Ptr RWops -> IO (Ptr Surface)|] 123 | liftF "loadLBM_RW" "IMG_LoadLBM_RW" [t|Ptr RWops -> IO (Ptr Surface)|] 124 | liftF "loadXV_RW" "IMG_LoadXV_RW" [t|Ptr RWops -> IO (Ptr Surface)|] 125 | liftF "loadWEBP_RW" "IMG_LoadWEBP_RW" [t|Ptr RWops -> IO (Ptr Surface)|] 126 | 127 | liftF "isCUR" "IMG_isCUR" [t|Ptr RWops -> IO CInt|] 128 | liftF "isICO" "IMG_isICO" [t|Ptr RWops -> IO CInt|] 129 | liftF "isBMP" "IMG_isBMP" [t|Ptr RWops -> IO CInt|] 130 | liftF "isPNM" "IMG_isPNM" [t|Ptr RWops -> IO CInt|] 131 | liftF "isXPM" "IMG_isXPM" [t|Ptr RWops -> IO CInt|] 132 | liftF "isXCF" "IMG_isXCF" [t|Ptr RWops -> IO CInt|] 133 | liftF "isPCX" "IMG_isPCX" [t|Ptr RWops -> IO CInt|] 134 | liftF "isGIF" "IMG_isGIF" [t|Ptr RWops -> IO CInt|] 135 | liftF "isJPG" "IMG_isJPG" [t|Ptr RWops -> IO CInt|] 136 | liftF "isTIF" "IMG_isTIF" [t|Ptr RWops -> IO CInt|] 137 | liftF "isPNG" "IMG_isPNG" [t|Ptr RWops -> IO CInt|] 138 | liftF "isLBM" "IMG_isLBM" [t|Ptr RWops -> IO CInt|] 139 | liftF "isXV" "IMG_isXV" [t|Ptr RWops -> IO CInt|] 140 | liftF "isWEBP" "IMG_isWEBP" [t|Ptr RWops -> IO CInt|] 141 | -------------------------------------------------------------------------------- /src/SDL/Image.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | 3 | Module : SDL.Image 4 | Copyright : (c) 2015 Siniša Biđin 5 | License : MIT 6 | Maintainer : sinisa@bidin.eu 7 | Stability : experimental 8 | 9 | Bindings to the @SDL2_image@ library. These should allow you to load various 10 | types of images as @SDL@ 'Surface's, as well as detect image formats. 11 | 12 | You can safely assume that any monadic function listed here is capable of 13 | throwing an 'SDLException' in case it encounters an error. 14 | 15 | -} 16 | 17 | {-# LANGUAGE DeriveGeneric #-} 18 | {-# LANGUAGE LambdaCase #-} 19 | {-# LANGUAGE MultiParamTypeClasses #-} 20 | {-# LANGUAGE OverloadedStrings #-} 21 | 22 | module SDL.Image 23 | ( 24 | 25 | -- * Loading images 26 | -- 27 | -- | Use the following functions to read any @PNG@, @JPG@, @TIF@, @GIF@, 28 | -- @WEBP@, @CUR@, @ICO@, @BMP@, @PNM@, @XPM@, @XCF@, @PCX@ and @XV@ formatted 29 | -- data. 30 | -- 31 | -- If you have @TGA@-formatted data, you might wish to use the functions from 32 | -- the <#tga following section> instead. 33 | load 34 | , decode 35 | , loadTexture 36 | , decodeTexture 37 | 38 | -- * Loading TGA images 39 | -- 40 | -- | #tga# Since @TGA@ images don't contain a specific unique signature, the 41 | -- following functions might succeed even when given files not formatted as 42 | -- @TGA@ images. 43 | -- 44 | -- Only use these functions if you're certain the inputs are @TGA@-formatted, 45 | -- otherwise they'll throw an exception. 46 | , loadTGA 47 | , decodeTGA 48 | , loadTextureTGA 49 | , decodeTextureTGA 50 | 51 | -- * Format detection 52 | , formattedAs 53 | , format 54 | , Format(..) 55 | 56 | -- * Other 57 | , initialize 58 | , InitFlag(..) 59 | , version 60 | , quit 61 | ) where 62 | 63 | import Control.Exception (bracket, throwIO) 64 | import Control.Monad.IO.Class (MonadIO, liftIO) 65 | import Data.Bits ((.|.)) 66 | import Data.ByteString (ByteString) 67 | import Data.ByteString.Unsafe (unsafeUseAsCStringLen) 68 | import Data.List (find) 69 | import Data.Text (pack) 70 | import Foreign.C.String (withCString) 71 | import Foreign.C.Types (CInt) 72 | import Foreign.Ptr (Ptr, castPtr) 73 | import Foreign.Storable (peek) 74 | import GHC.Generics (Generic) 75 | import SDL (Renderer, Texture, Surface(..), SDLException(..)) 76 | import SDL.Internal.Exception (throwIfNull, throwIf_) 77 | import SDL.Raw.Filesystem (rwFromFile, rwFromConstMem) 78 | import SDL.Raw.Types (RWops) 79 | import System.IO.Unsafe (unsafePerformIO) 80 | 81 | import qualified SDL 82 | import qualified SDL.Raw 83 | import qualified SDL.Raw.Image 84 | 85 | -- | Initializes @SDL2_image@ by loading support for the chosen image formats. 86 | -- Explicit initialization is optional. 87 | -- 88 | -- You should call this function if you prefer to load image support yourself, 89 | -- at a time when your process isn't as busy. Otherwise, image support will be 90 | -- loaded dynamically when you attempt to load a @JPG@, @PNG@, @TIF@ or 91 | -- @WEBP@-formatted file. 92 | -- 93 | -- You may call this function multiple times. 94 | initialize :: (Foldable f, MonadIO m) => f InitFlag -> m () 95 | initialize flags = do 96 | let cint = foldl (\a b -> a .|. flagToCInt b) 0 flags 97 | throwIf_ 98 | (\result -> cint /= 0 && cint /= result) 99 | "SDL.Image.initialize" 100 | "IMG_Init" 101 | (SDL.Raw.Image.init cint) 102 | 103 | -- | Flags intended to be fed to 'initialize'. 104 | -- 105 | -- Each designates early loading of support for a particular image format. 106 | data InitFlag 107 | = InitJPG -- ^ Load support for reading @JPG@ files. 108 | | InitPNG -- ^ Same, but for @PNG@ files. 109 | | InitTIF -- ^ @TIF@ files. 110 | | InitWEBP -- ^ @WEBP@ files. 111 | deriving (Eq, Enum, Ord, Bounded, Generic, Read, Show) 112 | 113 | flagToCInt :: InitFlag -> CInt 114 | flagToCInt = 115 | \case 116 | InitJPG -> SDL.Raw.Image.IMG_INIT_JPG 117 | InitPNG -> SDL.Raw.Image.IMG_INIT_PNG 118 | InitTIF -> SDL.Raw.Image.IMG_INIT_TIF 119 | InitWEBP -> SDL.Raw.Image.IMG_INIT_WEBP 120 | 121 | -- | A helper for unmanaged 'Surface's, since it is not exposed by SDL itself. 122 | unmanaged :: Ptr SDL.Raw.Surface -> Surface 123 | unmanaged p = Surface p Nothing 124 | 125 | -- | Loads any given file of a supported image type as a 'Surface', including 126 | -- @TGA@ if the filename ends with @\".tga\"@. 127 | -- 128 | -- If you have @TGA@ files that don't have names ending with @\".tga\"@, use 129 | -- 'loadTGA' instead. 130 | load :: MonadIO m => FilePath -> m Surface 131 | load path = 132 | fmap unmanaged . 133 | throwIfNull "SDL.Image.load" "IMG_Load" . 134 | liftIO $ withCString path SDL.Raw.Image.load 135 | 136 | -- | Same as 'load', but returning a 'Texture' instead. 137 | -- 138 | -- For @TGA@ files not ending in ".tga", use 'loadTextureTGA' instead. 139 | loadTexture :: MonadIO m => Renderer -> FilePath -> m Texture 140 | loadTexture r path = 141 | liftIO . bracket (load path) SDL.freeSurface $ 142 | SDL.createTextureFromSurface r 143 | 144 | -- | Reads an image from a 'ByteString'. 145 | -- 146 | -- This will work for all supported image types, __except TGA__. If you need to 147 | -- decode a @TGA@ 'ByteString', use 'decodeTGA' instead. 148 | decode :: MonadIO m => ByteString -> m Surface 149 | decode bytes = liftIO . 150 | unsafeUseAsCStringLen bytes $ \(cstr, len) -> do 151 | rw <- rwFromConstMem (castPtr cstr) (fromIntegral len) 152 | fmap unmanaged . 153 | throwIfNull "SDL.Image.decode" "IMG_Load_RW" $ 154 | SDL.Raw.Image.load_RW rw 0 155 | 156 | -- | Same as 'decode', but returning a 'Texture' instead. 157 | -- 158 | -- If you need to decode a @TGA@ 'ByteString', use 'decodeTextureTGA' instead. 159 | decodeTexture :: MonadIO m => Renderer -> ByteString -> m Texture 160 | decodeTexture r bytes = 161 | liftIO . bracket (decode bytes) SDL.freeSurface $ 162 | SDL.createTextureFromSurface r 163 | 164 | -- | If your @TGA@ files aren't in a filename ending with @\".tga\"@, you can 165 | -- load them using this function. 166 | loadTGA :: MonadIO m => FilePath -> m Surface 167 | loadTGA path = 168 | fmap unmanaged . 169 | throwIfNull "SDL.Image.loadTGA" "IMG_LoadTGA_RW" . 170 | liftIO $ do 171 | rw <- withCString "rb" $ withCString path . flip rwFromFile 172 | SDL.Raw.Image.loadTGA_RW rw 173 | 174 | -- | Same as 'loadTGA', only returning a 'Texture' instead. 175 | loadTextureTGA :: MonadIO m => Renderer -> FilePath -> m Texture 176 | loadTextureTGA r path = 177 | liftIO . bracket (loadTGA path) SDL.freeSurface $ 178 | SDL.createTextureFromSurface r 179 | 180 | -- | Reads a @TGA@ image from a 'ByteString'. 181 | -- 182 | -- Assumes the input is a @TGA@-formatted image. 183 | decodeTGA :: MonadIO m => ByteString -> m Surface 184 | decodeTGA bytes = liftIO . 185 | unsafeUseAsCStringLen bytes $ \(cstr, len) -> do 186 | rw <- rwFromConstMem (castPtr cstr) (fromIntegral len) 187 | fmap unmanaged . 188 | throwIfNull "SDL.Image.decodeTGA" "IMG_LoadTGA_RW" $ 189 | SDL.Raw.Image.loadTGA_RW rw 190 | 191 | -- | Same as 'decodeTGA', but returns a 'Texture' instead. 192 | decodeTextureTGA :: MonadIO m => Renderer -> ByteString -> m Texture 193 | decodeTextureTGA r bytes = 194 | liftIO . bracket (decodeTGA bytes) SDL.freeSurface $ 195 | SDL.createTextureFromSurface r 196 | 197 | -- | Tests whether a 'ByteString' contains an image of a given format. 198 | formattedAs :: Format -> ByteString -> Bool 199 | formattedAs f bytes = unsafePerformIO . 200 | unsafeUseAsCStringLen bytes $ \(cstr, len) -> do 201 | rw <- rwFromConstMem (castPtr cstr) (fromIntegral len) 202 | formatPredicate f rw >>= \case 203 | 1 -> return True 204 | 0 -> return False 205 | e -> do 206 | let err = "Expected 1 or 0, got " `mappend` pack (show e) `mappend` "." 207 | let fun = "IMG_is" `mappend` pack (show f) 208 | throwIO $ SDLCallFailed "SDL.Image.formattedAs" fun err 209 | 210 | -- | Tries to detect the image format by attempting 'formattedAs' with each 211 | -- possible 'Format'. 212 | -- 213 | -- If you're trying to test for a specific format, use a specific 'formattedAs' 214 | -- directly instead. 215 | format :: ByteString -> Maybe Format 216 | format bytes = fst <$> find snd attempts 217 | where 218 | attempts = map (\f -> (f, formattedAs f bytes)) [minBound..] 219 | 220 | -- | Each of the supported image formats. 221 | data Format 222 | = CUR 223 | | ICO 224 | | BMP 225 | | PNM 226 | | XPM 227 | | XCF 228 | | PCX 229 | | GIF 230 | | LBM 231 | | XV 232 | | JPG 233 | | PNG 234 | | TIF 235 | | WEBP 236 | deriving (Eq, Enum, Ord, Bounded, Generic, Read, Show) 237 | 238 | -- Given an image format, return its raw predicate function. 239 | formatPredicate :: MonadIO m => Format -> Ptr RWops -> m CInt 240 | formatPredicate = \case 241 | CUR -> SDL.Raw.Image.isCUR 242 | ICO -> SDL.Raw.Image.isICO 243 | BMP -> SDL.Raw.Image.isBMP 244 | PNM -> SDL.Raw.Image.isPNM 245 | XPM -> SDL.Raw.Image.isXPM 246 | XCF -> SDL.Raw.Image.isXCF 247 | PCX -> SDL.Raw.Image.isPCX 248 | GIF -> SDL.Raw.Image.isGIF 249 | LBM -> SDL.Raw.Image.isLBM 250 | XV -> SDL.Raw.Image.isXV 251 | JPG -> SDL.Raw.Image.isJPG 252 | PNG -> SDL.Raw.Image.isPNG 253 | TIF -> SDL.Raw.Image.isTIF 254 | WEBP -> SDL.Raw.Image.isWEBP 255 | 256 | -- | Gets the major, minor, patch versions of the linked @SDL2_image@ library. 257 | version :: (Integral a, MonadIO m) => m (a, a, a) 258 | version = liftIO $ do 259 | SDL.Raw.Version major minor patch <- peek =<< SDL.Raw.Image.getVersion 260 | return (fromIntegral major, fromIntegral minor, fromIntegral patch) 261 | 262 | -- | Cleans up any loaded image libraries, freeing memory. You only need to 263 | -- call this function once. 264 | quit :: MonadIO m => m () 265 | quit = SDL.Raw.Image.quit 266 | --------------------------------------------------------------------------------