{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
module SDL.Image
(
load
, decode
, loadTexture
, decodeTexture
, loadTGA
, decodeTGA
, loadTextureTGA
, decodeTextureTGA
, formattedAs
, format
, Format(..)
, initialize
, InitFlag(..)
, version
, quit
) where
import Control.Exception (bracket, throwIO)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Bits ((.|.))
import Data.ByteString (ByteString)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Data.List (find)
import Data.Text (pack)
import Foreign.C.String (withCString)
import Foreign.C.Types (CInt)
import Foreign.Ptr (Ptr, castPtr)
import Foreign.Storable (peek)
import GHC.Generics (Generic)
import SDL (Renderer, Texture, Surface(..), SDLException(..))
import SDL.ExceptionHelper (throwIfNull, throwIf_)
import SDL.Raw.Filesystem (rwFromFile, rwFromConstMem)
import SDL.Raw.Types (RWops)
import System.IO.Unsafe (unsafePerformIO)
import qualified SDL
import qualified SDL.Raw
import qualified SDL.Raw.Image
initialize :: (Foldable f, MonadIO m) => f InitFlag -> m ()
initialize flags = do
let cint = foldl (\a b -> a .|. flagToCInt b) 0 flags
throwIf_
(\result -> cint /= 0 && cint /= result)
"SDL.Image.initialize"
"IMG_Init"
(SDL.Raw.Image.init cint)
data InitFlag
= InitJPG
| InitPNG
| InitTIF
| InitWEBP
deriving (Eq, Enum, Ord, Bounded, Generic, Read, Show)
flagToCInt :: InitFlag -> CInt
flagToCInt =
\case
InitJPG -> SDL.Raw.Image.IMG_INIT_JPG
InitPNG -> SDL.Raw.Image.IMG_INIT_PNG
InitTIF -> SDL.Raw.Image.IMG_INIT_TIF
InitWEBP -> SDL.Raw.Image.IMG_INIT_WEBP
unmanaged :: Ptr SDL.Raw.Surface -> Surface
unmanaged p = Surface p Nothing
load :: MonadIO m => FilePath -> m Surface
load path =
fmap unmanaged .
throwIfNull "SDL.Image.load" "IMG_Load" .
liftIO $ withCString path SDL.Raw.Image.load
loadTexture :: MonadIO m => Renderer -> FilePath -> m Texture
loadTexture r path =
liftIO . bracket (load path) SDL.freeSurface $
SDL.createTextureFromSurface r
decode :: MonadIO m => ByteString -> m Surface
decode bytes = liftIO .
unsafeUseAsCStringLen bytes $ \(cstr, len) -> do
rw <- rwFromConstMem (castPtr cstr) (fromIntegral len)
fmap unmanaged .
throwIfNull "SDL.Image.decode" "IMG_Load_RW" $
SDL.Raw.Image.load_RW rw 0
decodeTexture :: MonadIO m => Renderer -> ByteString -> m Texture
decodeTexture r bytes =
liftIO . bracket (decode bytes) SDL.freeSurface $
SDL.createTextureFromSurface r
loadTGA :: MonadIO m => FilePath -> m Surface
loadTGA path =
fmap unmanaged .
throwIfNull "SDL.Image.loadTGA" "IMG_LoadTGA_RW" .
liftIO $ do
rw <- withCString "rb" $ withCString path . flip rwFromFile
SDL.Raw.Image.loadTGA_RW rw
loadTextureTGA :: MonadIO m => Renderer -> FilePath -> m Texture
loadTextureTGA r path =
liftIO . bracket (loadTGA path) SDL.freeSurface $
SDL.createTextureFromSurface r
decodeTGA :: MonadIO m => ByteString -> m Surface
decodeTGA bytes = liftIO .
unsafeUseAsCStringLen bytes $ \(cstr, len) -> do
rw <- rwFromConstMem (castPtr cstr) (fromIntegral len)
fmap unmanaged .
throwIfNull "SDL.Image.decodeTGA" "IMG_LoadTGA_RW" $
SDL.Raw.Image.loadTGA_RW rw
decodeTextureTGA :: MonadIO m => Renderer -> ByteString -> m Texture
decodeTextureTGA r bytes =
liftIO . bracket (decodeTGA bytes) SDL.freeSurface $
SDL.createTextureFromSurface r
formattedAs :: Format -> ByteString -> Bool
formattedAs f bytes = unsafePerformIO .
unsafeUseAsCStringLen bytes $ \(cstr, len) -> do
rw <- rwFromConstMem (castPtr cstr) (fromIntegral len)
formatPredicate f rw >>= \case
1 -> return True
0 -> return False
e -> do
let err = "Expected 1 or 0, got " `mappend` pack (show e) `mappend` "."
let fun = "IMG_is" `mappend` pack (show f)
throwIO $ SDLCallFailed "SDL.Image.formattedAs" fun err
format :: ByteString -> Maybe Format
format bytes = fst <$> find snd attempts
where
attempts = map (\f -> (f, formattedAs f bytes)) [minBound..]
data Format
= CUR
| ICO
| BMP
| PNM
| XPM
| XCF
| PCX
| GIF
| LBM
| XV
| JPG
| PNG
| TIF
| WEBP
deriving (Eq, Enum, Ord, Bounded, Generic, Read, Show)
formatPredicate :: MonadIO m => Format -> Ptr RWops -> m CInt
formatPredicate = \case
CUR -> SDL.Raw.Image.isCUR
ICO -> SDL.Raw.Image.isICO
BMP -> SDL.Raw.Image.isBMP
PNM -> SDL.Raw.Image.isPNM
XPM -> SDL.Raw.Image.isXPM
XCF -> SDL.Raw.Image.isXCF
PCX -> SDL.Raw.Image.isPCX
GIF -> SDL.Raw.Image.isGIF
LBM -> SDL.Raw.Image.isLBM
XV -> SDL.Raw.Image.isXV
JPG -> SDL.Raw.Image.isJPG
PNG -> SDL.Raw.Image.isPNG
TIF -> SDL.Raw.Image.isTIF
WEBP -> SDL.Raw.Image.isWEBP
version :: (Integral a, MonadIO m) => m (a, a, a)
version = liftIO $ do
SDL.Raw.Version major minor patch <- peek =<< SDL.Raw.Image.getVersion
return (fromIntegral major, fromIntegral minor, fromIntegral patch)
quit :: MonadIO m => m ()
quit = SDL.Raw.Image.quit