diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for sdl2-image + +## v2.1.0.0 + +* Compatibility with GHC-9 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015 Siniša Biđin +Copyright (c) 2015 Siniša Biđin, 2021 Daniel Firth Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,19 @@ +# sdl2-image + +[![Hackage](https://img.shields.io/hackage/v/sdl2-image.svg)](https://hackage.haskell.org/package/sdl2-image) +[![GitLab](https://gitlab.homotopic.tech/haskell/sdl2-image/badges/master/pipeline.svg)](https://gitlab.homotopic.tech/haskell/sdl2-image) + +Haskell bindings to SDL2_image. Provides both raw and high level bindings. + +The +[original SDL2_image documentation](http://www.libsdl.org/projects/SDL_image/docs/SDL_image.html) +can also help, as the bindings are close to a direct mapping. + +##### Example + +A small example executable is included with the library. It loads and displays +a given image. You can find it in the `example` directory. + +```bash +stack exec -- sdl2-image-example +``` diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/example/Example.hs b/example/Example.hs deleted file mode 100644 --- a/example/Example.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} - -module Main where - -import Control.Concurrent (threadDelay) -import Control.Monad (forM_) -import Data.Text (Text) -import Data.Text.IO (putStrLn) -import Prelude hiding (putStrLn) -import System.Environment (getArgs) -import System.Exit (exitFailure) - -import qualified SDL -import qualified SDL.Image - --- A sequence of example actions to be perfomed and displayed. -examples :: [(Text, SDL.Window -> FilePath -> IO ())] -examples = [ - - ("Loading as surface, blitting", - \window path -> do - image <- SDL.Image.load path - screen <- SDL.getWindowSurface window - SDL.surfaceBlit image Nothing screen Nothing - SDL.updateWindowSurface window - SDL.freeSurface image), - - ("Loading as texture, rendering", - \window path -> do - r <- SDL.createRenderer window (-1) SDL.defaultRenderer - texture <- SDL.Image.loadTexture r path - SDL.clear r - SDL.copy r texture Nothing Nothing - SDL.present r - SDL.destroyTexture texture)] - -main :: IO () -main = do - - SDL.initialize [SDL.InitVideo] - - getArgs >>= \case - - [] -> do - putStrLn "Usage: cabal run path/to/image.(png|jpg|...)" - exitFailure - - (path:_) -> - -- Run each of the examples within a newly-created window. - forM_ examples $ \(name, action) -> do - putStrLn name - window <- SDL.createWindow name SDL.defaultWindow - SDL.showWindow window - action window path - threadDelay 1000000 - SDL.destroyWindow window - - SDL.quit diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Concurrent (threadDelay) +import Control.Monad (forM_) +import Data.Text (Text) +import Data.Text.IO (putStrLn) +import qualified SDL +import qualified SDL.Image +import System.Environment (getArgs) +import System.Exit (exitFailure) +import Prelude hiding (putStrLn) + +-- A sequence of example actions to be perfomed and displayed. +examples :: [(Text, SDL.Window -> FilePath -> IO ())] +examples = + [ ( "Loading as surface, blitting", + \window path -> do + image <- SDL.Image.load path + screen <- SDL.getWindowSurface window + _ <- SDL.surfaceBlit image Nothing screen Nothing + SDL.updateWindowSurface window + SDL.freeSurface image + ), + ( "Loading as texture, rendering", + \window path -> do + r <- SDL.createRenderer window (-1) SDL.defaultRenderer + texture <- SDL.Image.loadTexture r path + SDL.clear r + SDL.copy r texture Nothing Nothing + SDL.present r + SDL.destroyTexture texture + ) + ] + +main :: IO () +main = do + SDL.initialize [SDL.InitVideo] + + getArgs >>= \case + [] -> do + putStrLn "Usage: cabal run path/to/image.(png|jpg|...)" + exitFailure + (path : _) -> + -- Run each of the examples within a newly-created window. + forM_ examples $ \(name, action) -> do + putStrLn name + window <- SDL.createWindow name SDL.defaultWindow + SDL.showWindow window + action window path + threadDelay 1000000 + SDL.destroyWindow window + + SDL.quit diff --git a/sdl2-image.cabal b/sdl2-image.cabal --- a/sdl2-image.cabal +++ b/sdl2-image.cabal @@ -1,64 +1,72 @@ -name: sdl2-image -version: 2.0.0 -synopsis: Bindings to SDL2_image. -description: Haskell bindings to SDL2_image. -license: MIT -license-file: LICENSE -author: Cai Lei , Siniša Biđin -maintainer: Siniša Biđin -copyright: Copyright © 2014 Cai Lei, Copyright © 2015 Siniša Biđin -category: Image, Graphics, Foreign -build-type: Simple -cabal-version: >=1.10 +cabal-version: 1.12 +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: sdl2-image +version: 2.1.0.0 +synopsis: Haskell bindings to SDL2_image +category: Graphics, Foreign, Image +bug-reports: https://gitlab.homotopic.tech/haskell/sdl2-image/issues +author: Cai Lei, + Siniša Biđin, + Daniel Firth +maintainer: Siniša Biđin , + Daniel Firth +copyright: 2014 Cal Lei, + 2015 Siniša Biđin, + 2021 Daniel Firth +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + source-repository head - type: git - location: https://github.com/sbidin/sdl2-image.git + type: git + location: https://gitlab.homotopic.tech/haskell/sdl2-image library - ghc-options: -Wall - exposed-modules: - SDL.Image, - SDL.Raw.Image - + SDL.Image + SDL.Raw.Helper + SDL.Raw.Image other-modules: - SDL.ExceptionHelper, - SDL.Raw.Helper - + Paths_sdl2_image hs-source-dirs: - src - + src + ghc-options: -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module -Wno-missing-import-lists -Wno-safe -Wno-unsafe + extra-libraries: + SDL2_image pkgconfig-depends: - sdl2 >= 2.0.3, - SDL2_image >= 2.0.0 - + sdl2 >= 2.0.3 + , SDL2_image >= 1.0.1 build-depends: - base >= 4.7 && < 5, - bytestring >= 0.10.4.0, - sdl2 >= 2.0, - text >= 1.1.0.0, - template-haskell, - transformers >= 0.2 - - default-language: - Haskell2010 - -flag example - description: Build the example executable - default: True + base >=4.9 && <5 + , bytestring >=0.10.4.0 + , sdl2 >=2.0.0 + , template-haskell >=2.10 + , text >=1.1.0.0 + default-language: Haskell2010 + autogen-modules: Paths_sdl2_image executable sdl2-image-example - ghc-options: -Wall - hs-source-dirs: example - main-is: Example.hs + main-is: Main.hs + other-modules: + Paths_sdl2_image + hs-source-dirs: + example + ghc-options: -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module -Wno-missing-import-lists -Wno-safe -Wno-unsafe -threaded -rtsopts -with-rtsopts=-N + extra-libraries: + SDL2_image + pkgconfig-depends: + sdl2 >= 2.0.3 + , SDL2_image >= 1.0.1 + build-depends: + base >=4.9 && <5 + , sdl2 >=2.0.0 + , sdl2-image + , text >=1.1.0.0 default-language: Haskell2010 - - if flag(example) - build-depends: - base >= 4.7 && < 5, - sdl2 >= 2.0, - sdl2-image, - text >= 1.1.0.0 - else - buildable: False diff --git a/src/SDL/ExceptionHelper.hs b/src/SDL/ExceptionHelper.hs deleted file mode 100644 --- a/src/SDL/ExceptionHelper.hs +++ /dev/null @@ -1,30 +0,0 @@ -module SDL.ExceptionHelper where - -import Control.Exception (throwIO) -import Control.Monad (when) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.ByteString (packCString) -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8) -import Foreign.Ptr (Ptr, nullPtr) -import SDL (SDLException(SDLCallFailed)) -import SDL.Raw (getError) - -throwIfNeg_ :: (MonadIO m, Num a, Ord a) => Text -> Text -> m a -> m () -throwIfNeg_ = throwIf_ (< 0) - -throwIfNull :: MonadIO m => Text -> Text -> m (Ptr a) -> m (Ptr a) -throwIfNull = throwIf (== nullPtr) - -throwIf :: MonadIO m => (a -> Bool) -> Text -> Text -> m a -> m a -throwIf f caller rawf act = do - result <- act - liftIO $ when (f result) $ do - err <- decodeUtf8 <$> (packCString =<< getError) - throwIO $ SDLCallFailed caller rawf err - return result - -throwIf_ :: MonadIO m => (a -> Bool) -> Text -> Text -> m a -> m () -throwIf_ f caller rawf act = do - _ <- throwIf f caller rawf act - return () diff --git a/src/SDL/Image.hs b/src/SDL/Image.hs --- a/src/SDL/Image.hs +++ b/src/SDL/Image.hs @@ -1,86 +1,86 @@ -{-| - -Module : SDL.Image -Copyright : (c) 2015 Siniša Biđin -License : MIT -Maintainer : sinisa@bidin.eu -Stability : experimental - -Bindings to the @SDL2_image@ library. These should allow you to load various -types of images as @SDL@ 'Surface's, as well as detect image formats. +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} -You can safely assume that any monadic function listed here is capable of -throwing an 'SDLException' in case it encounters an error. +-- | +-- +-- Module : SDL.Image +-- Copyright : (c) 2015 Siniša Biđin, 2021 Daniel Firth +-- License : MIT +-- Maintainer : sinisa@bidin.eu, dan.firth@homotopic.tech +-- Stability : experimental +-- +-- Bindings to the @SDL2_image@ library. These should allow you to load various +-- types of images as @SDL@ 'Surface's, as well as detect image formats. +-- +-- You can safely assume that any monadic function listed here is capable of +-- throwing an 'SDLException' in case it encounters an error. +module SDL.Image + ( -- * Loading images --} + -- -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} + -- | Use the following functions to read any @PNG@, @JPG@, @TIF@, @GIF@, + -- @WEBP@, @CUR@, @ICO@, @BMP@, @PNM@, @XPM@, @XCF@, @PCX@ and @XV@ formatted + -- data. + -- + -- If you have @TGA@-formatted data, you might wish to use the functions from + -- the <#tga following section> instead. + load, + decode, + loadTexture, + decodeTexture, -module SDL.Image - ( + -- * Loading TGA images - -- * Loading images - -- - -- | Use the following functions to read any @PNG@, @JPG@, @TIF@, @GIF@, - -- @WEBP@, @CUR@, @ICO@, @BMP@, @PNM@, @XPM@, @XCF@, @PCX@ and @XV@ formatted - -- data. - -- - -- If you have @TGA@-formatted data, you might wish to use the functions from - -- the <#tga following section> instead. - load - , decode - , loadTexture - , decodeTexture + -- - -- * Loading TGA images - -- - -- | #tga# Since @TGA@ images don't contain a specific unique signature, the - -- following functions might succeed even when given files not formatted as - -- @TGA@ images. - -- - -- Only use these functions if you're certain the inputs are @TGA@-formatted, - -- otherwise they'll throw an exception. - , loadTGA - , decodeTGA - , loadTextureTGA - , decodeTextureTGA + -- | #tga# Since @TGA@ images don't contain a specific unique signature, the + -- following functions might succeed even when given files not formatted as + -- @TGA@ images. + -- + -- Only use these functions if you're certain the inputs are @TGA@-formatted, + -- otherwise they'll throw an exception. + loadTGA, + decodeTGA, + loadTextureTGA, + decodeTextureTGA, - -- * Format detection - , formattedAs - , format - , Format(..) + -- * Format detection + formattedAs, + format, + Format (..), - -- * Other - , initialize - , InitFlag(..) - , version - , quit - ) where + -- * Other + initialize, + InitFlag (..), + version, + quit, + ) +where -import Control.Exception (bracket, throwIO) +import Control.Exception (bracket, throwIO) import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Bits ((.|.)) -import Data.ByteString (ByteString) +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 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, SDLException (..), Surface (..), Texture) import qualified SDL +import SDL.Internal.Exception (throwIfNull, throwIf_) import qualified SDL.Raw +import SDL.Raw.Filesystem (rwFromConstMem, rwFromFile) import qualified SDL.Raw.Image +import SDL.Raw.Types (RWops) +import System.IO.Unsafe (unsafePerformIO) -- | Initializes @SDL2_image@ by loading support for the chosen image formats. -- Explicit initialization is optional. @@ -104,18 +104,22 @@ -- -- Each designates early loading of support for a particular image format. data InitFlag - = InitJPG -- ^ Load support for reading @JPG@ files. - | InitPNG -- ^ Same, but for @PNG@ files. - | InitTIF -- ^ @TIF@ files. - | InitWEBP -- ^ @WEBP@ files. - deriving (Eq, Enum, Ord, Bounded, Generic, Read, Show) + = -- | Load support for reading @JPG@ files. + InitJPG + | -- | Same, but for @PNG@ files. + InitPNG + | -- | @TIF@ files. + InitTIF + | -- | @WEBP@ files. + InitWEBP + deriving stock (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 + 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 -- | A helper for unmanaged 'Surface's, since it is not exposed by SDL itself. @@ -129,9 +133,10 @@ -- 'loadTGA' instead. load :: MonadIO m => FilePath -> m Surface load path = - fmap unmanaged . - throwIfNull "SDL.Image.load" "IMG_Load" . - liftIO $ withCString path SDL.Raw.Image.load + fmap unmanaged + . throwIfNull "SDL.Image.load" "IMG_Load" + . liftIO + $ withCString path SDL.Raw.Image.load -- | Same as 'load', but returning a 'Texture' instead. -- @@ -146,12 +151,13 @@ -- This will work for all supported image types, __except TGA__. If you need to -- decode a @TGA@ 'ByteString', use 'decodeTGA' instead. decode :: MonadIO m => ByteString -> m Surface -decode bytes = liftIO . - unsafeUseAsCStringLen bytes $ \(cstr, len) -> do +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 + fmap unmanaged + . throwIfNull "SDL.Image.decode" "IMG_Load_RW" + $ SDL.Raw.Image.load_RW rw 0 -- | Same as 'decode', but returning a 'Texture' instead. -- @@ -165,11 +171,12 @@ -- load them using this function. 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 + fmap unmanaged + . throwIfNull "SDL.Image.loadTGA" "IMG_LoadTGA_RW" + . liftIO + $ do + rw <- withCString "rb" $ withCString path . flip rwFromFile + SDL.Raw.Image.loadTGA_RW rw -- | Same as 'loadTGA', only returning a 'Texture' instead. loadTextureTGA :: MonadIO m => Renderer -> FilePath -> m Texture @@ -181,12 +188,13 @@ -- -- Assumes the input is a @TGA@-formatted image. decodeTGA :: MonadIO m => ByteString -> m Surface -decodeTGA bytes = liftIO . - unsafeUseAsCStringLen bytes $ \(cstr, len) -> do +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 + fmap unmanaged + . throwIfNull "SDL.Image.decodeTGA" "IMG_LoadTGA_RW" + $ SDL.Raw.Image.loadTGA_RW rw -- | Same as 'decodeTGA', but returns a 'Texture' instead. decodeTextureTGA :: MonadIO m => Renderer -> ByteString -> m Texture @@ -196,8 +204,9 @@ -- | Tests whether a 'ByteString' contains an image of a given format. formattedAs :: Format -> ByteString -> Bool -formattedAs f bytes = unsafePerformIO . - unsafeUseAsCStringLen bytes $ \(cstr, len) -> do +formattedAs f bytes = unsafePerformIO + . unsafeUseAsCStringLen bytes + $ \(cstr, len) -> do rw <- rwFromConstMem (castPtr cstr) (fromIntegral len) formatPredicate f rw >>= \case 1 -> return True @@ -215,7 +224,7 @@ format :: ByteString -> Maybe Format format bytes = fst <$> find snd attempts where - attempts = map (\f -> (f, formattedAs f bytes)) [minBound..] + attempts = map (\f -> (f, formattedAs f bytes)) [minBound ..] -- | Each of the supported image formats. data Format @@ -233,24 +242,24 @@ | PNG | TIF | WEBP - deriving (Eq, Enum, Ord, Bounded, Generic, Read, Show) + deriving stock (Eq, Enum, Ord, Bounded, Generic, Read, Show) -- Given an image format, return its raw predicate function. 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 + 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 -- | Gets the major, minor, patch versions of the linked @SDL2_image@ library. diff --git a/src/SDL/Raw/Helper.hs b/src/SDL/Raw/Helper.hs --- a/src/SDL/Raw/Helper.hs +++ b/src/SDL/Raw/Helper.hs @@ -1,25 +1,45 @@ -{-| - -Module : SDL.Raw.Helper -Copyright : (c) 2015 Siniša Biđin -License : MIT -Maintainer : sinisa@bidin.eu -Stability : experimental - -Exposes a way to automatically generate a foreign import alongside its lifted, -inlined MonadIO variant. Use this to simplify the package's SDL.Raw.* modules. - --} - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} +-- | +-- +-- Module : SDL.Raw.Helper +-- Copyright : (c) 2015 Siniša Biđin, 2021 Daniel Firth +-- License : MIT +-- Maintainer : sinisa@bidin.eu, dan.firth@homotopic.tech +-- Stability : experimental +-- +-- Exposes a way to automatically generate a foreign import alongside its lifted, +-- inlined MonadIO variant. Use this to simplify the package's SDL.Raw.* modules. module SDL.Raw.Helper (liftF) where -import Control.Monad (replicateM) -import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad (replicateM) +import Control.Monad.IO.Class (MonadIO, liftIO) import Language.Haskell.TH + ( Body (NormalB), + Callconv (CCall), + Clause (Clause), + Dec (ForeignD, FunD, PragmaD, SigD), + Exp (AppE, VarE), + Foreign (ImportF), + Inline (Inline), + Name, + Pat (VarP), + Phases (AllPhases), + Pragma (InlineP), + Q, + RuleMatch (FunLike), + Safety (Safe), + TyVarBndr (PlainTV), + Type (AppT, ArrowT, ConT, ForallT, SigT, VarT), + mkName, + newName, +#if MIN_VERSION_template_haskell(2,17,0) + Specificity(SpecifiedSpec) +#endif + ) -- | Given a name @fname@, a name of a C function @cname@ and the desired -- Haskell type @ftype@, this function generates: @@ -29,8 +49,8 @@ liftF :: String -> String -> Q Type -> Q [Dec] liftF fname cname ftype = do let f' = mkName $ fname ++ "'" -- Direct binding. - let f = mkName fname -- Lifted. - t' <- ftype -- Type of direct binding. + let f = mkName fname -- Lifted. + t' <- ftype -- Type of direct binding. -- The generated function accepts n arguments. args <- replicateM (countArgs t') $ newName "x" @@ -39,39 +59,42 @@ -- However, this fails to typecheck without an explicit type signature. -- Therefore, we include one. TODO: Can we get rid of this? sigd <- case args of - [] -> ((:[]) . SigD f) `fmap` liftType t' - _ -> return [] + [] -> ((: []) . SigD f) `fmap` liftType t' + _ -> return [] - return $ concat - [ - [ ForeignD $ ImportF CCall Safe cname f' t' - , PragmaD $ InlineP f Inline FunLike AllPhases - ] - , sigd - , [ FunD f - [ Clause - (map VarP args) - (NormalB $ 'liftIO `applyTo` [f' `applyTo` map VarE args]) - [] + return $ + concat + [ [ ForeignD $ ImportF CCall Safe cname f' t', + PragmaD $ InlineP f Inline FunLike AllPhases + ], + sigd, + [ FunD + f + [ Clause + (map VarP args) + (NormalB $ 'liftIO `applyTo` [f' `applyTo` map VarE args]) + [] + ] ] ] - ] -- | How many arguments does a function of a given type take? countArgs :: Type -> Int countArgs = count 0 where + count :: Num p => p -> Type -> p count !n = \case - (AppT (AppT ArrowT _) t) -> count (n+1) t + (AppT (AppT ArrowT _) t) -> count (n + 1) t (ForallT _ _ t) -> count n t - (SigT t _) -> count n t - _ -> n + (SigT t _) -> count n t + _ -> n -- | An expression where f is applied to n arguments. applyTo :: Name -> [Exp] -> Exp applyTo f [] = VarE f applyTo f es = loop (tail es) . AppE (VarE f) $ head es where + loop :: Foldable t => t Exp -> Exp -> Exp loop as e = foldl AppE e as -- | Fuzzily speaking, converts a given IO type into a MonadIO m one. @@ -81,7 +104,12 @@ m <- newName "m" return $ ForallT +#if MIN_VERSION_template_haskell(2,17,0) + [PlainTV m SpecifiedSpec] +#else [PlainTV m] + +#endif [AppT (ConT ''MonadIO) $ VarT m] (AppT (VarT m) t) t -> return t diff --git a/src/SDL/Raw/Image.hsc b/src/SDL/Raw/Image.hsc --- a/src/SDL/Raw/Image.hsc +++ b/src/SDL/Raw/Image.hsc @@ -1,9 +1,9 @@ {-| Module : SDL.Raw.Image -Copyright : (c) 2015 Siniša Biđin +Copyright : (c) 2015 Siniša Biđin, 2021 Daniel Firth License : MIT -Maintainer : sinisa@bidin.eu +Maintainer : sinisa@bidin.eu, dan.firth@homotopic.tech Stability : experimental Raw bindings to the @SDL2_image@ library. No error-handling is done here. For @@ -13,6 +13,10 @@ -} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# OPTIONS_GHC -fno-warn-missing-exported-signatures #-} +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +{-# OPTIONS_GHC -fno-warn-missing-local-signatures #-} +{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-}