sdl2-gfx 0.2 → 0.3.0.0
raw patch · 17 files changed
+789/−514 lines, 17 filesdep −bytestringdep −lineardep −textdep ~basedep ~sdl2dep ~vectorsetup-changednew-uploader
Dependencies removed: bytestring, linear, text, transformers
Dependency ranges changed: base, sdl2, vector
Files
- ChangeLog.md +5/−0
- LICENSE +1/−1
- README.md +20/−0
- Setup.hs +0/−2
- example/Example.hs +0/−92
- example/Main.hs +88/−0
- sdl2-gfx.cabal +65/−63
- src/SDL/ExceptionHelper.hs +0/−21
- src/SDL/Framerate.hs +34/−41
- src/SDL/ImageFilter.hs +103/−84
- src/SDL/Primitive.hs +313/−104
- src/SDL/Raw/Framerate.hsc +7/−3
- src/SDL/Raw/Helper.hs +64/−36
- src/SDL/Raw/ImageFilter.hsc +9/−6
- src/SDL/Raw/Primitive.hsc +7/−4
- src/SDL/Raw/Rotozoom.hsc +8/−5
- src/SDL/Rotozoom.hs +65/−52
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for sdl2-mixer++## v0.3.0.0++* Compatibility with GHC-9
LICENSE view
@@ -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
+ README.md view
@@ -0,0 +1,20 @@+# sdl2-gfx++[](https://hackage.haskell.org/package/sdl2-gfx)+[](https://gitlab.homotopic.tech/haskell/sdl2-gfx)++Haskell bindings to SDL2_gfx. Provides both raw and high level bindings.++The+[original SDL2_gfx documentation](http://www.ferzkopp.net/Software/SDL2_gfx/Docs/html/index.html)+can also help, as the bindings are close to a direct mapping.++##### Example++A small example executable is included with the library. It uses many parts of+the library to draw a chaotic jumbled mess on your screen. You can find it in+the `example` directory.++```bash+stack exec -- sdl2-gfx-example+```
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− example/Example.hs
@@ -1,92 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Main where--import Control.Monad (when)-import Data.Vector.Storable (fromList)-import Foreign.C.Types (CInt)-import Linear (V2(..), V4(..))-import SDL (($=))--import qualified SDL-import qualified SDL.Framerate-import qualified SDL.Primitive--red :: SDL.Primitive.Color-red = V4 255 50 50 255--green :: SDL.Primitive.Color-green = V4 50 255 50 255--blue :: SDL.Primitive.Color-blue = V4 50 50 255 255--black :: SDL.Primitive.Color-black = V4 0 0 0 255--white :: SDL.Primitive.Color-white = V4 255 255 255 255--main :: IO ()-main = do-- SDL.initialize [SDL.InitVideo]- w <- SDL.createWindow "sdl2-gfx-example" SDL.defaultWindow- r <- SDL.createRenderer w (-1) SDL.defaultRenderer- SDL.showWindow w-- let fps = 60 -- How fast do we aim to render?- let limit = 120 -- How many frames will we render?-- SDL.Framerate.with fps $ loopFor limit r-- SDL.destroyWindow w- SDL.quit--loopFor :: CInt -> SDL.Renderer -> SDL.Framerate.Manager -> IO ()-loopFor limit r fpsm = loop'- where- loop' :: IO ()- loop' = do-- -- How many frames have we drawn until now?- frames <- fromIntegral `fmap` SDL.Framerate.count fpsm-- -- Clear the screen!- SDL.rendererDrawColor r $= black- SDL.clear r-- -- Run each of the functions from SDL.Primitives.- -- For added chaos, move everything by framecount.- SDL.Primitive.pixel r (V2 (100+frames) 100) green- SDL.Primitive.line r (V2 10 10) (V2 (25+frames) (25+frames)) red- SDL.Primitive.thickLine r (V2 10 15) (V2 (10+frames) 120) 3 white- SDL.Primitive.smoothLine r (V2 100 frames) (V2 300 (20-frames)) white- SDL.Primitive.horizontalLine r (V2 40 (350+frames)) (2*frames) blue- SDL.Primitive.verticalLine r (V2 40 (350+frames)) (5*frames) green- SDL.Primitive.rectangle r (V2 (75+frames) (90+frames)) (V2 (100+frames) (100+frames)) white- SDL.Primitive.roundRectangle r (V2 110 300) (V2 (170+frames) (400+frames)) 10 white- SDL.Primitive.fillRectangle r (V2 (175+frames) (190+frames)) (V2 (200+frames) (200+frames)) red- SDL.Primitive.fillRoundRectangle r (V2 120 310) (V2 (160+frames) (390+frames)) 5 blue- SDL.Primitive.arc r (V2 320 240) 100 0 (frames*360 `div` limit) red- SDL.Primitive.circle r (V2 320 240) 80 white- SDL.Primitive.smoothCircle r (V2 320 240) 70 white- SDL.Primitive.fillCircle r (V2 320 240) 50 white- SDL.Primitive.ellipse r (V2 500 200) 70 (10+frames) green- SDL.Primitive.smoothEllipse r (V2 500 200) 60 (5+frames) white- SDL.Primitive.fillEllipse r (V2 500 200) 40 frames blue- SDL.Primitive.pie r (V2 640 500) 80 0 (frames*360 `div` limit) red- SDL.Primitive.fillPie r (V2 640 400) 60 0 (frames*360 `div` limit) blue- SDL.Primitive.triangle r (V2 700 10) (V2 750 10) (V2 750 60) red- SDL.Primitive.smoothTriangle r (V2 700 5) (V2 740 5) (V2 740 70) green- SDL.Primitive.fillTriangle r (V2 650 40) (V2 690 50) (V2 700 90) blue- SDL.Primitive.polygon r (fromList [100, 220, 430, 317, 50]) (fromList [30, 70, 200, 300, 500]) green- SDL.Primitive.smoothPolygon r (fromList $ map (+40) [100, 220, 430, 317, 50]) (fromList $ map (+40) [30, 70, 200, 300, 500]) blue- SDL.Primitive.fillPolygon r (fromList $ map (+300) [100, 220, 430, 317, 50]) (fromList $ map (+400) [30, 70, 200, 300, 500]) $ V4 200 20 20 128- SDL.Primitive.bezier r (fromList [70, 43, 23, 388, 239, 584, 444]) (fromList [546, 323, 110, 5, 483, 673, 332]) 5 $ V4 255 0 255 255-- SDL.present r-- SDL.Framerate.delay_ fpsm -- Delay to keep framerate constant.-- when (frames < limit) loop'
+ example/Main.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++import Control.Monad (when)+import Data.Vector.Storable (fromList)+import Foreign.C.Types (CInt)+import SDL (($=))+import qualified SDL+import qualified SDL.Framerate+import qualified SDL.Primitive+import SDL.Vect (V2 (..), V4 (..))++red :: SDL.Primitive.Color+red = V4 255 50 50 255++green :: SDL.Primitive.Color+green = V4 50 255 50 255++blue :: SDL.Primitive.Color+blue = V4 50 50 255 255++black :: SDL.Primitive.Color+black = V4 0 0 0 255++white :: SDL.Primitive.Color+white = V4 255 255 255 255++main :: IO ()+main = do+ SDL.initialize [SDL.InitVideo]+ w <- SDL.createWindow "sdl2-gfx-example" SDL.defaultWindow+ r <- SDL.createRenderer w (-1) SDL.defaultRenderer+ SDL.showWindow w++ let fps :: Int+ fps = 60 -- How fast do we aim to render?+ let limit :: CInt+ limit = 120 -- How many frames will we render?+ SDL.Framerate.with fps $ loopFor limit r++ SDL.destroyWindow w+ SDL.quit++loopFor :: CInt -> SDL.Renderer -> SDL.Framerate.Manager -> IO ()+loopFor limit r fpsm = loop'+ where+ loop' :: IO ()+ loop' = do+ -- How many frames have we drawn until now?+ frames <- fromIntegral `fmap` SDL.Framerate.count fpsm++ -- Clear the screen!+ SDL.rendererDrawColor r $= black+ SDL.clear r++ -- Run each of the functions from SDL.Primitives.+ -- For added chaos, move everything by framecount.+ SDL.Primitive.pixel r (V2 (100 + frames) 100) green+ SDL.Primitive.line r (V2 10 10) (V2 (25 + frames) (25 + frames)) red+ SDL.Primitive.thickLine r (V2 10 15) (V2 (10 + frames) 120) 3 white+ SDL.Primitive.smoothLine r (V2 100 frames) (V2 300 (20 - frames)) white+ SDL.Primitive.horizontalLine r (V2 40 (350 + frames)) (2 * frames) blue+ SDL.Primitive.verticalLine r (V2 40 (350 + frames)) (5 * frames) green+ SDL.Primitive.rectangle r (V2 (75 + frames) (90 + frames)) (V2 (100 + frames) (100 + frames)) white+ SDL.Primitive.roundRectangle r (V2 110 300) (V2 (170 + frames) (400 + frames)) 10 white+ SDL.Primitive.fillRectangle r (V2 (175 + frames) (190 + frames)) (V2 (200 + frames) (200 + frames)) red+ SDL.Primitive.fillRoundRectangle r (V2 120 310) (V2 (160 + frames) (390 + frames)) 5 blue+ SDL.Primitive.arc r (V2 320 240) 100 0 (frames * 360 `div` limit) red+ SDL.Primitive.circle r (V2 320 240) 80 white+ SDL.Primitive.smoothCircle r (V2 320 240) 70 white+ SDL.Primitive.fillCircle r (V2 320 240) 50 white+ SDL.Primitive.ellipse r (V2 500 200) 70 (10 + frames) green+ SDL.Primitive.smoothEllipse r (V2 500 200) 60 (5 + frames) white+ SDL.Primitive.fillEllipse r (V2 500 200) 40 frames blue+ SDL.Primitive.pie r (V2 640 500) 80 0 (frames * 360 `div` limit) red+ SDL.Primitive.fillPie r (V2 640 400) 60 0 (frames * 360 `div` limit) blue+ SDL.Primitive.triangle r (V2 700 10) (V2 750 10) (V2 750 60) red+ SDL.Primitive.smoothTriangle r (V2 700 5) (V2 740 5) (V2 740 70) green+ SDL.Primitive.fillTriangle r (V2 650 40) (V2 690 50) (V2 700 90) blue+ SDL.Primitive.polygon r (fromList [100, 220, 430, 317, 50]) (fromList [30, 70, 200, 300, 500]) green+ SDL.Primitive.smoothPolygon r (fromList $ map (+ 40) [100, 220, 430, 317, 50]) (fromList $ map (+ 40) [30, 70, 200, 300, 500]) blue+ SDL.Primitive.fillPolygon r (fromList $ map (+ 300) [100, 220, 430, 317, 50]) (fromList $ map (+ 400) [30, 70, 200, 300, 500]) $ V4 200 20 20 128+ SDL.Primitive.bezier r (fromList [70, 43, 23, 388, 239, 584, 444]) (fromList [546, 323, 110, 5, 483, 673, 332]) 5 $ V4 255 0 255 255++ SDL.present r++ SDL.Framerate.delay_ fpsm -- Delay to keep framerate constant.+ when (frames < limit) loop'
sdl2-gfx.cabal view
@@ -1,75 +1,77 @@-name: sdl2-gfx-version: 0.2-synopsis: Bindings to SDL2_gfx.-description: Haskell bindings to SDL2_gfx.-license: MIT-license-file: LICENSE-author: Siniša Biđin <sinisa@bidin.eu>-maintainer: Siniša Biđin <sinisa@bidin.eu>-copyright: Copyright © 2015 Siniša Biđin-category: 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-gfx+version: 0.3.0.0+synopsis: Haskell bindings to SDL2_gfx+category: Graphics, Foreign+bug-reports: https://gitlab.homotopic.tech/haskell/sdl2-gfx/issues+author: Siniša Biđin,+ Daniel Firth+maintainer: Siniša Biđin <sinisa@bidin.eu>,+ Daniel Firth <dan.firth@homotopic.tech>+copyright: 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-gfx.git+ type: git+ location: https://gitlab.homotopic.tech/haskell/sdl2-gfx library- ghc-options: -Wall- exposed-modules:- SDL.Primitive,- SDL.Raw.Primitive,- SDL.Framerate,- SDL.Raw.Framerate,- SDL.Rotozoom,- SDL.Raw.Rotozoom,- SDL.ImageFilter,- SDL.Raw.ImageFilter-+ SDL.Framerate+ SDL.ImageFilter+ SDL.Primitive+ SDL.Raw.Framerate+ SDL.Raw.Helper+ SDL.Raw.ImageFilter+ SDL.Raw.Primitive+ SDL.Raw.Rotozoom+ SDL.Rotozoom other-modules:- SDL.ExceptionHelper,- SDL.Raw.Helper-+ Paths_sdl2_gfx 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_gfx pkgconfig-depends:- sdl2 >= 2.0.3,- SDL2_gfx >= 1.0.1-+ sdl2 >= 2.0.3+ , SDL2_gfx >= 1.0.1 build-depends:- base >= 4.7 && < 5,- bytestring,- lifted-base >= 0.2,- linear >= 1.10.1.2,- monad-control >= 1.0,- sdl2 >= 2.0,- template-haskell,- text,- transformers >= 0.2,- vector >= 0.10.9.0-- default-language:- Haskell2010--flag example- description: Build the example executable- default: True+ base >=4.9 && <5+ , lifted-base >=0.2+ , monad-control >=1.0+ , sdl2 >=2.0.0+ , template-haskell >=2.10+ , vector >=0.10+ default-language: Haskell2010+ autogen-modules: Paths_sdl2_gfx executable sdl2-gfx-example- ghc-options: -Wall- hs-source-dirs: example- main-is: Example.hs+ main-is: Main.hs+ other-modules:+ Paths_sdl2_gfx+ 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_gfx+ pkgconfig-depends:+ sdl2 >= 2.0.3+ , SDL2_gfx >= 1.0.1+ build-depends:+ base >=4.9 && <5+ , sdl2 >=2.0.0+ , sdl2-gfx+ , vector >=0.10 default-language: Haskell2010-- if flag(example)- build-depends:- base >= 4.7 && < 5,- linear >= 1.10.1.2,- sdl2 >= 2.0,- sdl2-gfx,- vector >= 0.10.9.0- else- buildable: False
− src/SDL/ExceptionHelper.hs
@@ -1,21 +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 SDL (SDLException(SDLCallFailed))-import SDL.Raw (getError)--throwIfNeg_ :: (MonadIO m, Num a, Ord a) => Text -> Text -> m a -> m ()-throwIfNeg_ = throwIf_ (< 0)--throwIf_ :: MonadIO m => (a -> Bool) -> Text -> Text -> m a -> m ()-throwIf_ f caller rawf act = do- result <- act- liftIO $ when (f result) $ do- err <- decodeUtf8 <$> (packCString =<< getError)- throwIO $ SDLCallFailed caller rawf err- return ()
src/SDL/Framerate.hs view
@@ -1,49 +1,44 @@-{-|--Module : SDL.Framerate-Copyright : (c) 2015 Siniša Biđin-License : MIT-Maintainer : sinisa@bidin.eu-Stability : experimental--Bindings to @SDL2_gfx@'s framerate management functionality. These functions-should allow you to set, manage and query a target application framerate.---}--+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} +-- |+--+-- Module : SDL.Framerate+-- Copyright : (c) 2015 Siniša Biđin, 2021 Daniel Firth+-- License : MIT+-- Maintainer : dan.firth@homotopic.tech+-- Stability : experimental+--+-- Bindings to @SDL2_gfx@'s framerate management functionality. These functions+-- should allow you to set, manage and query a target application framerate. module SDL.Framerate- ( Framerate- , Manager(..)- , with- , manager- , set- , delay- , delay_- , minimum- , maximum- , get- , count- , destroyManager- ) where+ ( Framerate,+ Manager (..),+ with,+ manager,+ set,+ delay,+ delay_,+ SDL.Framerate.minimum,+ SDL.Framerate.maximum,+ get,+ count,+ destroyManager,+ )+where -import Control.Exception.Lifted (bracket)-import Control.Monad (void)-import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Exception.Lifted (bracket)+import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Control (MonadBaseControl)-import Foreign.Marshal.Alloc (malloc, free)-import Foreign.Ptr (Ptr)-import Prelude hiding (minimum, maximum)-+import Foreign.Marshal.Alloc (free, malloc)+import Foreign.Ptr (Ptr) import qualified SDL.Raw.Framerate -- | A framerate manager, counting frames and keeping track of time delays -- necessary to reach a certain target framerate. newtype Manager = Manager (Ptr SDL.Raw.Framerate.Manager)- deriving (Eq, Show)+ deriving stock (Eq, Show) -- | A certain number of frames per second. type Framerate = Int@@ -52,8 +47,8 @@ -- 'Manager' after the inner computation ends. -- -- This is the recommended way to create a 'Manager'.-with- :: (MonadBaseControl IO m, MonadIO m) => Framerate -> (Manager -> m a) -> m a+with ::+ (MonadBaseControl IO m, MonadIO m) => Framerate -> (Manager -> m a) -> m a with fps act = bracket manager destroyManager $ \m -> set m fps >> act m@@ -82,9 +77,7 @@ -- Note that the given framerate must be within the allowed range -- otherwise -- the minimum or maximum allowed framerate is used instead. set :: MonadIO m => Manager -> Framerate -> m ()-set (Manager ptr) = void . set' . min maximum . max minimum- where- set' = SDL.Raw.Framerate.setFramerate ptr . fromIntegral+set (Manager ptr) = void . SDL.Raw.Framerate.setFramerate ptr . fromIntegral . min SDL.Framerate.maximum . max SDL.Framerate.minimum -- | Get the currently set framerate. get :: MonadIO m => Manager -> m Framerate
src/SDL/ImageFilter.hs view
@@ -1,68 +1,64 @@-{-|--Module : SDL.ImageFilter-Copyright : (c) 2015 Siniša Biđin-License : MIT-Maintainer : sinisa@bidin.eu-Stability : experimental--Bindings to @SDL2_gfx@'s MMX image filter functionality.---}-+-- |+--+-- Module : SDL.ImageFilter+-- Copyright : (c) 2015 Siniša Biđin+-- License : MIT+-- Maintainer : sinisa@bidin.eu+-- Stability : experimental+--+-- Bindings to @SDL2_gfx@'s MMX image filter functionality. module SDL.ImageFilter- (- -- * Query MMX- usingMMX- , disableMMX- , enableMMX+ ( -- * Query MMX+ usingMMX,+ disableMMX,+ enableMMX, - -- * Vector operations- , add- , mean- , sub- , absDiff- , mult- , multNor- , multDivBy2- , multDivBy4- , bitAnd- , bitOr- , div- , bitNegation- , addByte- , addUInt- , addByteToHalf- , subByte- , subUInt- , shiftRight- , shiftRightUInt- , multByByte- , shiftRightAndMultByByte- , shiftLeftByte- , shiftLeftUInt- , shiftLeft- , binarizeUsingThreshold- , clipToRange- , normalizeLinear- ) where+ -- * Vector operations+ add,+ mean,+ sub,+ absDiff,+ mult,+ multNor,+ multDivBy2,+ multDivBy4,+ bitAnd,+ bitOr,+ div,+ bitNegation,+ addByte,+ addUInt,+ addByteToHalf,+ subByte,+ subUInt,+ shiftRight,+ shiftRightUInt,+ multByByte,+ shiftRightAndMultByByte,+ shiftLeftByte,+ shiftLeftUInt,+ shiftLeft,+ binarizeUsingThreshold,+ clipToRange,+ normalizeLinear,+ )+where import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Word (Word8)-import Prelude hiding (div)-import Foreign.C.Types (CUChar, CUInt, CInt)-import Foreign.Ptr (castPtr, Ptr)-import Foreign.Marshal.Alloc (mallocBytes, finalizerFree)-import Foreign.ForeignPtr (newForeignPtr)-import Data.Vector.Storable (Vector)-import System.IO.Unsafe (unsafePerformIO)--import qualified SDL.Raw.ImageFilter+import Data.Vector.Storable (Vector) import qualified Data.Vector.Storable as V+import Data.Word (Word8)+import Foreign.C.Types (CInt, CUChar, CUInt)+import Foreign.ForeignPtr (newForeignPtr)+import Foreign.Marshal.Alloc (finalizerFree, mallocBytes)+import Foreign.Ptr (Ptr, castPtr)+import qualified SDL.Raw.ImageFilter+import System.IO.Unsafe (unsafePerformIO)+import Prelude hiding (div) -- | Are we using MMX code? usingMMX :: MonadIO m => m Bool-usingMMX = (==1) <$> SDL.Raw.ImageFilter.mmxDetect+usingMMX = (== 1) <$> SDL.Raw.ImageFilter.mmxDetect -- | Disable MMX, use non-MMX code instead. disableMMX :: MonadIO m => m ()@@ -83,12 +79,13 @@ f <- newForeignPtr finalizerFree $ castPtr p return $ V.unsafeFromForeignPtr0 f len -binary- :: (Ptr CUChar -> Ptr CUChar -> Ptr CUChar -> CUInt -> IO CInt) ->- (Vector Word8 -> Vector Word8 -> Vector Word8)+binary ::+ (Ptr CUChar -> Ptr CUChar -> Ptr CUChar -> CUInt -> IO CInt) ->+ (Vector Word8 -> Vector Word8 -> Vector Word8) binary f x y =- unsafePerformIO .- V.unsafeWith x $ \x' ->+ unsafePerformIO+ . V.unsafeWith x+ $ \x' -> V.unsafeWith y $ \y' -> mallocVector (minLen x y) $ \z' -> f (castPtr x') (castPtr y') z' (minLen x y)@@ -132,18 +129,22 @@ bitNegation :: Vector Word8 -> Vector Word8 bitNegation x =- unsafePerformIO .- V.unsafeWith x $ \x' ->+ unsafePerformIO+ . V.unsafeWith x+ $ \x' -> mallocVector (V.length x) $ \y' -> SDL.Raw.ImageFilter.bitNegation- (castPtr x') y' (fromIntegral $ V.length x)+ (castPtr x')+ y'+ (fromIntegral $ V.length x) -binaryByte- :: (Ptr CUChar -> Ptr CUChar -> CUInt -> CUChar -> IO CInt) ->- (Word8 -> Vector Word8 -> Vector Word8)+binaryByte ::+ (Ptr CUChar -> Ptr CUChar -> CUInt -> CUChar -> IO CInt) ->+ (Word8 -> Vector Word8 -> Vector Word8) binaryByte f b x =- unsafePerformIO .- V.unsafeWith x $ \x' ->+ unsafePerformIO+ . V.unsafeWith x+ $ \x' -> mallocVector (V.length x) $ \y' -> f (castPtr x') y' (fromIntegral $ V.length x) (cuchar b) @@ -177,12 +178,13 @@ binarizeUsingThreshold :: Word8 -> Vector Word8 -> Vector Word8 binarizeUsingThreshold = binaryByte SDL.Raw.ImageFilter.binarizeUsingThreshold -binaryUInt- :: (Ptr CUChar -> Ptr CUChar -> CUInt -> CUInt -> IO CInt) ->- (CUInt -> Vector Word8 -> Vector Word8)+binaryUInt ::+ (Ptr CUChar -> Ptr CUChar -> CUInt -> CUInt -> IO CInt) ->+ (CUInt -> Vector Word8 -> Vector Word8) binaryUInt f i x =- unsafePerformIO .- V.unsafeWith x $ \x' ->+ unsafePerformIO+ . V.unsafeWith x+ $ \x' -> mallocVector (V.length x) $ \y' -> f (castPtr x') y' (fromIntegral $ V.length x) i @@ -194,24 +196,41 @@ shiftRightAndMultByByte :: Word8 -> Word8 -> Vector Word8 -> Vector Word8 shiftRightAndMultByByte s m x =- unsafePerformIO .- V.unsafeWith x $ \x' ->+ unsafePerformIO+ . V.unsafeWith x+ $ \x' -> mallocVector (V.length x) $ \y' -> SDL.Raw.ImageFilter.shiftRightAndMultByByte- (castPtr x') y' (fromIntegral $ V.length x) (cuchar s) (cuchar m)+ (castPtr x')+ y'+ (fromIntegral $ V.length x)+ (cuchar s)+ (cuchar m) clipToRange :: Word8 -> Word8 -> Vector Word8 -> Vector Word8 clipToRange a b x =- unsafePerformIO .- V.unsafeWith x $ \x' ->+ unsafePerformIO+ . V.unsafeWith x+ $ \x' -> mallocVector (V.length x) $ \y' -> SDL.Raw.ImageFilter.clipToRange- (castPtr x') y' (fromIntegral $ V.length x) (cuchar a) (cuchar b)+ (castPtr x')+ y'+ (fromIntegral $ V.length x)+ (cuchar a)+ (cuchar b) normalizeLinear :: CInt -> CInt -> CInt -> CInt -> Vector Word8 -> Vector Word8 normalizeLinear cmin cmax nmin nmax x =- unsafePerformIO .- V.unsafeWith x $ \x' ->+ unsafePerformIO+ . V.unsafeWith x+ $ \x' -> mallocVector (V.length x) $ \y' -> SDL.Raw.ImageFilter.normalizeLinear- (castPtr x') y' (fromIntegral $ V.length x) cmin cmax nmin nmax+ (castPtr x')+ y'+ (fromIntegral $ V.length x)+ cmin+ cmax+ nmin+ nmax
src/SDL/Primitive.hs view
@@ -1,83 +1,78 @@-{-|--Module : SDL.Primitive-Copyright : (c) 2015 Siniša Biđin-License : MIT-Maintainer : sinisa@bidin.eu-Stability : experimental--Bindings to @SDL2_gfx@'s primitives drawing functionality. These functions-should allow you to render various simple shapes such as lines, ellipses or-polygons.--All of the monadic functions within this module are capable of throwing an-'SDL.Exception.SDLException' if they encounter an error.---}--{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} +-- |+--+-- Module : SDL.Primitive+-- Copyright : (c) 2015 Siniša Biđin, 2021 Daniel Firth+-- License : MIT+-- Maintainer : dan.firth@homotopic.tech+-- Stability : experimental+--+-- Bindings to @SDL2_gfx@'s primitives drawing functionality. These functions+-- should allow you to render various simple shapes such as lines, ellipses or+-- polygons.+--+-- All of the monadic functions within this module are capable of throwing an+-- 'SDL.Exception.SDLException' if they encounter an error. module SDL.Primitive- (- -- * Pixels- Pos- , Color- , pixel+ ( -- * Pixels+ Pos,+ Color,+ pixel, - -- * Lines- , line- , Length- , horizontalLine- , verticalLine- , smoothLine- , Width- , thickLine+ -- * Lines+ line,+ Length,+ horizontalLine,+ verticalLine,+ smoothLine,+ Width,+ thickLine, - -- * Triangles- , triangle- , smoothTriangle- , fillTriangle+ -- * Triangles+ triangle,+ smoothTriangle,+ fillTriangle, - -- * Rectangles- , rectangle- , Radius- , roundRectangle- , fillRectangle- , fillRoundRectangle+ -- * Rectangles+ rectangle,+ Radius,+ roundRectangle,+ fillRectangle,+ fillRoundRectangle, - -- * Curves- , Start- , End- , arc- , circle- , smoothCircle- , fillCircle- , ellipse- , smoothEllipse- , fillEllipse- , pie- , fillPie- , Steps- , bezier+ -- * Curves+ Start,+ End,+ arc,+ circle,+ smoothCircle,+ fillCircle,+ ellipse,+ smoothEllipse,+ fillEllipse,+ pie,+ fillPie,+ Steps,+ bezier, - -- * Polygons- , polygon- , smoothPolygon- , fillPolygon- ) where+ -- * Polygons+ polygon,+ smoothPolygon,+ fillPolygon,+ )+where import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Int (Int16)-import Data.Vector.Storable (Vector, unsafeWith, length)-import Data.Word (Word8)-import Foreign.C.Types (CInt)-import Linear (V4(..), V2(..))-import Prelude hiding (length)-import SDL.ExceptionHelper (throwIfNeg_)-import SDL.Internal.Types (Renderer(..))-+import Data.Int (Int16)+import Data.Vector.Storable (Vector, length, unsafeWith)+import Data.Word (Word8)+import Foreign.C.Types (CInt)+import SDL.Internal.Exception (throwIfNeg_)+import SDL.Internal.Types (Renderer (..)) import qualified SDL.Raw.Primitive+import SDL.Vect (V2 (..), V4 (..))+import Prelude hiding (length) -- | A position as a two-dimensional vector. type Pos = V2 CInt@@ -97,14 +92,28 @@ pixel (Renderer p) (V2 x y) (V4 r g b a) = throwIfNeg_ "SDL.Primitive.pixel" "pixelRGBA" $ SDL.Raw.Primitive.pixel- p (cint x) (cint y) r g b a+ p+ (cint x)+ (cint y)+ r+ g+ b+ a -- | Renders a line between two points. line :: MonadIO m => Renderer -> Pos -> Pos -> Color -> m () line (Renderer p) (V2 x y) (V2 u v) (V4 r g b a) = throwIfNeg_ "SDL.Primitive.line" "lineRGBA" $ SDL.Raw.Primitive.line- p (cint x) (cint y) (cint u) (cint v) r g b a+ p+ (cint x)+ (cint y)+ (cint u)+ (cint v)+ r+ g+ b+ a -- | A width in pixels. type Width = CInt@@ -114,14 +123,31 @@ thickLine (Renderer p) (V2 x y) (V2 u v) w (V4 r g b a) = throwIfNeg_ "SDL.Primitive.thickLine" "thickLineRGBA" $ SDL.Raw.Primitive.thickLine- p (cint x) (cint y) (cint u) (cint v) (cint w) r g b a+ p+ (cint x)+ (cint y)+ (cint u)+ (cint v)+ (cint w)+ r+ g+ b+ a -- | Renders an anti-aliased line between two points. smoothLine :: MonadIO m => Renderer -> Pos -> Pos -> Color -> m () smoothLine (Renderer p) (V2 x y) (V2 u v) (V4 r g b a) = throwIfNeg_ "SDL.Primitive.smoothLine" "aalineRGBA" $ SDL.Raw.Primitive.aaLine- p (cint x) (cint y) (cint u) (cint v) r g b a+ p+ (cint x)+ (cint y)+ (cint u)+ (cint v)+ r+ g+ b+ a -- | A length in pixels. type Length = CInt@@ -132,7 +158,14 @@ horizontalLine (Renderer p) (V2 x y) w (V4 r g b a) = throwIfNeg_ "SDL.Primitive.horizontalLine" "hlineRGBA" $ SDL.Raw.Primitive.hline- p (cint x) (cint $ x + w) (cint y) r g b a+ p+ (cint x)+ (cint $ x + w)+ (cint y)+ r+ g+ b+ a -- | Renders a vertical line of a certain 'Length', its top and starting point -- corresponding to a given 'Pos'.@@ -140,7 +173,14 @@ verticalLine (Renderer p) (V2 x y) h (V4 r g b a) = throwIfNeg_ "SDL.Primitive.verticalLine" "vlineRGBA" $ SDL.Raw.Primitive.vline- p (cint x) (cint y) (cint $ y + h) r g b a+ p+ (cint x)+ (cint y)+ (cint $ y + h)+ r+ g+ b+ a -- | Renders a transparent rectangle spanning two points, bordered by a line of -- a given 'Color'.@@ -148,7 +188,15 @@ rectangle (Renderer p) (V2 x y) (V2 u v) (V4 r g b a) = throwIfNeg_ "SDL.Primitive.rectangle" "rectangleRGBA" $ SDL.Raw.Primitive.rectangle- p (cint x) (cint y) (cint u) (cint v) r g b a+ p+ (cint x)+ (cint y)+ (cint u)+ (cint v)+ r+ g+ b+ a -- | A radius in pixels. type Radius = CInt@@ -161,21 +209,47 @@ roundRectangle (Renderer p) (V2 x y) (V2 u v) rad (V4 r g b a) = throwIfNeg_ "SDL.Primitive.roundRectangle" "roundedRectangleRGBA" $ SDL.Raw.Primitive.roundedRectangle- p (cint x) (cint y) (cint u) (cint v) (cint rad) r g b a+ p+ (cint x)+ (cint y)+ (cint u)+ (cint v)+ (cint rad)+ r+ g+ b+ a -- | Same as 'rectangle', but the rectangle is filled by the given 'Color'. fillRectangle :: MonadIO m => Renderer -> Pos -> Pos -> Color -> m () fillRectangle (Renderer p) (V2 x y) (V2 u v) (V4 r g b a) = throwIfNeg_ "SDL.Primitive.fillRectangle" "boxRGBA" $ SDL.Raw.Primitive.box- p (cint x) (cint y) (cint u) (cint v) r g b a+ p+ (cint x)+ (cint y)+ (cint u)+ (cint v)+ r+ g+ b+ a -- | Same as 'roundRectangle', but the rectangle is filled by the given 'Color'. fillRoundRectangle :: MonadIO m => Renderer -> Pos -> Pos -> Radius -> Color -> m () fillRoundRectangle (Renderer p) (V2 x y) (V2 u v) rad (V4 r g b a) = throwIfNeg_ "SDL.Primitive.fillRoundRectangle" "roundedBoxRGBA" $ SDL.Raw.Primitive.roundedBox- p (cint x) (cint y) (cint u) (cint v) (cint rad) r g b a+ p+ (cint x)+ (cint y)+ (cint u)+ (cint v)+ (cint rad)+ r+ g+ b+ a -- | A starting position in degrees. type Start = CInt@@ -191,28 +265,58 @@ arc (Renderer p) (V2 x y) rad start end (V4 r g b a) = throwIfNeg_ "SDL.Primitive.arc" "arcRGBA" $ SDL.Raw.Primitive.arc- p (cint x) (cint y) (cint rad) (cint start) (cint end) r g b a+ p+ (cint x)+ (cint y)+ (cint rad)+ (cint start)+ (cint end)+ r+ g+ b+ a -- | Renders a transparent circle, bordered by a line of a given 'Color'. circle :: MonadIO m => Renderer -> Pos -> Radius -> Color -> m () circle (Renderer p) (V2 x y) rad (V4 r g b a) = throwIfNeg_ "SDL.Primitive.circle" "circleRGBA" $ SDL.Raw.Primitive.circle- p (cint x) (cint y) (cint rad) r g b a+ p+ (cint x)+ (cint y)+ (cint rad)+ r+ g+ b+ a -- | Same as 'circle', but fills it with the given 'Color' instead. fillCircle :: MonadIO m => Renderer -> Pos -> Radius -> Color -> m () fillCircle (Renderer p) (V2 x y) rad (V4 r g b a) = throwIfNeg_ "SDL.Primitive.filledCircle" "filledCircleRGBA" $ SDL.Raw.Primitive.filledCircle- p (cint x) (cint y) (cint rad) r g b a+ p+ (cint x)+ (cint y)+ (cint rad)+ r+ g+ b+ a -- | Same as 'circle', but the border is anti-aliased. smoothCircle :: MonadIO m => Renderer -> Pos -> Radius -> Color -> m () smoothCircle (Renderer p) (V2 x y) rad (V4 r g b a) = throwIfNeg_ "SDL.Primitive.aaCircle" "aacircleRGBA" $ SDL.Raw.Primitive.aaCircle- p (cint x) (cint y) (cint rad) r g b a+ p+ (cint x)+ (cint y)+ (cint rad)+ r+ g+ b+ a -- | Renders a transparent ellipse, bordered by a line of a given 'Color'. --@@ -222,21 +326,45 @@ ellipse (Renderer p) (V2 x y) rx ry (V4 r g b a) = throwIfNeg_ "SDL.Primitive.ellipse" "ellipseRGBA" $ SDL.Raw.Primitive.ellipse- p (cint x) (cint y) (cint rx) (cint ry) r g b a+ p+ (cint x)+ (cint y)+ (cint rx)+ (cint ry)+ r+ g+ b+ a -- | Same as 'ellipse', but makes the border anti-aliased. smoothEllipse :: MonadIO m => Renderer -> Pos -> Radius -> Radius -> Color -> m () smoothEllipse (Renderer p) (V2 x y) rx ry (V4 r g b a) = throwIfNeg_ "SDL.Primitive.smoothEllipse" "aaellipseRGBA" $ SDL.Raw.Primitive.aaEllipse- p (cint x) (cint y) (cint rx) (cint ry) r g b a+ p+ (cint x)+ (cint y)+ (cint rx)+ (cint ry)+ r+ g+ b+ a -- | Same as 'ellipse', but fills it with the given 'Color' instead. fillEllipse :: MonadIO m => Renderer -> Pos -> Radius -> Radius -> Color -> m () fillEllipse (Renderer p) (V2 x y) rx ry (V4 r g b a) = throwIfNeg_ "SDL.Primitive.fillEllipse" "filledEllipseRGBA" $ SDL.Raw.Primitive.filledEllipse- p (cint x) (cint y) (cint rx) (cint ry) r g b a+ p+ (cint x)+ (cint y)+ (cint rx)+ (cint ry)+ r+ g+ b+ a -- | Render a pie outline, its 'Pos' being its center. --@@ -246,14 +374,32 @@ pie (Renderer p) (V2 x y) rad start end (V4 r g b a) = throwIfNeg_ "SDL.Primitive.pie" "pieRGBA" $ SDL.Raw.Primitive.pie- p (cint x) (cint y) (cint rad) (cint start) (cint end) r g b a+ p+ (cint x)+ (cint y)+ (cint rad)+ (cint start)+ (cint end)+ r+ g+ b+ a -- | Same as 'pie', but fills it with the given 'Color' instead. fillPie :: MonadIO m => Renderer -> Pos -> Radius -> Start -> End -> Color -> m () fillPie (Renderer p) (V2 x y) rad start end (V4 r g b a) = throwIfNeg_ "SDL.Primitive.fillPie" "filledPieRGBA" $ SDL.Raw.Primitive.filledPie- p (cint x) (cint y) (cint rad) (cint start) (cint end) r g b a+ p+ (cint x)+ (cint y)+ (cint rad)+ (cint start)+ (cint end)+ r+ g+ b+ a -- | How many interpolation steps when rendering a bezier curve? --@@ -271,25 +417,54 @@ bezier :: MonadIO m => Renderer -> Vector Int16 -> Vector Int16 -> Steps -> Color -> m () bezier (Renderer p) xs ys steps (V4 r g b a) = throwIfNeg_ "SDL.Primitive.bezier" "bezierRGBA" $- liftIO .- unsafeWith xs $ \xs' ->+ liftIO+ . unsafeWith xs+ $ \xs' -> unsafeWith ys $ \ys' -> SDL.Raw.Primitive.bezier- p xs' ys' (fromIntegral $ length xs) steps r g b a+ p+ xs'+ ys'+ (fromIntegral $ length xs)+ steps+ r+ g+ b+ a -- | Render a transparent triangle, its edges being of a given 'Color'. triangle :: MonadIO m => Renderer -> Pos -> Pos -> Pos -> Color -> m () triangle (Renderer p) (V2 x y) (V2 u v) (V2 t z) (V4 r g b a) = throwIfNeg_ "SDL.Primitive.triangle" "trigonRGBA" $ SDL.Raw.Primitive.trigon- p (cint x) (cint y) (cint u) (cint v) (cint t) (cint z) r g b a+ p+ (cint x)+ (cint y)+ (cint u)+ (cint v)+ (cint t)+ (cint z)+ r+ g+ b+ a -- | Same as 'triangle', but the edges are anti-aliased. smoothTriangle :: MonadIO m => Renderer -> Pos -> Pos -> Pos -> Color -> m () smoothTriangle (Renderer p) (V2 x y) (V2 u v) (V2 t z) (V4 r g b a) = throwIfNeg_ "SDL.Primitive.smoothTriangle" "aatrigonRGBA" $ SDL.Raw.Primitive.aaTrigon- p (cint x) (cint y) (cint u) (cint v) (cint t) (cint z) r g b a+ p+ (cint x)+ (cint y)+ (cint u)+ (cint v)+ (cint t)+ (cint z)+ r+ g+ b+ a -- | Same as 'triangle', but the triangle is filled with the given 'Color' -- instead.@@ -297,7 +472,17 @@ fillTriangle (Renderer p) (V2 x y) (V2 u v) (V2 t z) (V4 r g b a) = throwIfNeg_ "SDL.Primitive.fillTriangle" "filledTrigonRGBA" $ SDL.Raw.Primitive.filledTrigon- p (cint x) (cint y) (cint u) (cint v) (cint t) (cint z) r g b a+ p+ (cint x)+ (cint y)+ (cint u)+ (cint v)+ (cint t)+ (cint z)+ r+ g+ b+ a -- | Render a transparent polygon, its edges of a given 'Color'. --@@ -308,28 +493,52 @@ polygon :: MonadIO m => Renderer -> Vector Int16 -> Vector Int16 -> Color -> m () polygon (Renderer p) xs ys (V4 r g b a) = throwIfNeg_ "SDL.Primitive.polygon" "polygonRGBA" $- liftIO .- unsafeWith xs $ \xs' ->+ liftIO+ . unsafeWith xs+ $ \xs' -> unsafeWith ys $ \ys' -> SDL.Raw.Primitive.polygon- p xs' ys' (fromIntegral $ length xs) r g b a+ p+ xs'+ ys'+ (fromIntegral $ length xs)+ r+ g+ b+ a -- | Same as 'polygon', but the edges are drawn anti-aliased. smoothPolygon :: MonadIO m => Renderer -> Vector Int16 -> Vector Int16 -> Color -> m () smoothPolygon (Renderer p) xs ys (V4 r g b a) = throwIfNeg_ "SDL.Primitive.smoothPolygon" "aapolygonRGBA" $- liftIO .- unsafeWith xs $ \xs' ->+ liftIO+ . unsafeWith xs+ $ \xs' -> unsafeWith ys $ \ys' -> SDL.Raw.Primitive.aaPolygon- p xs' ys' (fromIntegral $ length xs) r g b a+ p+ xs'+ ys'+ (fromIntegral $ length xs)+ r+ g+ b+ a -- | Same as 'polygon', but the polygon is filled with the given 'Color'. fillPolygon :: MonadIO m => Renderer -> Vector Int16 -> Vector Int16 -> Color -> m () fillPolygon (Renderer p) xs ys (V4 r g b a) = throwIfNeg_ "SDL.Primitive.fillPolygon" "filledPolygonRGBA" $- liftIO .- unsafeWith xs $ \xs' ->+ liftIO+ . unsafeWith xs+ $ \xs' -> unsafeWith ys $ \ys' -> SDL.Raw.Primitive.filledPolygon- p xs' ys' (fromIntegral $ length xs) r g b a+ p+ xs'+ ys'+ (fromIntegral $ length xs)+ r+ g+ b+ a
src/SDL/Raw/Framerate.hsc view
@@ -1,9 +1,9 @@ {-| Module : SDL.Raw.Framerate-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_gfx@ library, specifically the framerate management@@ -12,7 +12,11 @@ -} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-missing-exported-signatures #-}+{-# OPTIONS_GHC -fno-warn-missing-local-signatures #-}+{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}@@ -48,7 +52,7 @@ , baseTicks :: Word32 , lastTicks :: Word32 , rate :: Word32- } deriving (Eq, Show, Read)+ } deriving stock (Eq, Show, Read) instance Storable Manager where alignment = sizeOf
src/SDL/Raw/Helper.hs view
@@ -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
src/SDL/Raw/ImageFilter.hsc view
@@ -1,9 +1,9 @@ {-| -Module : SDL.Raw.ImageFilter-Copyright : (c) 2015 Siniša Biđin+Module : SDL.Raw.Framerate+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_gfx@ library, specifically the MMX image filter@@ -12,7 +12,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 TemplateHaskell #-} module SDL.Raw.ImageFilter@@ -125,10 +128,10 @@ liftF "shiftRightAndMultByByte" "SDL_imageFilterShiftRightAndMultByByte" [t|Ptr CUChar -> Ptr CUChar -> CUInt -> CUChar -> CUChar -> IO CInt|] -liftF "shiftLeftByte" "SDL_imageFilterLeftByte"+liftF "shiftLeftByte" "SDL_imageFilterShiftLeftByte" [t|Ptr CUChar -> Ptr CUChar -> CUInt -> CUChar -> IO CInt|] -liftF "shiftLeftUInt" "SDL_imageFilterLeftUint"+liftF "shiftLeftUInt" "SDL_imageFilterShiftLeftUint" [t|Ptr CUChar -> Ptr CUChar -> CUInt -> CUChar -> IO CInt|] liftF "shiftLeft" "SDL_imageFilterShiftLeft"
src/SDL/Raw/Primitive.hsc view
@@ -1,9 +1,9 @@ {-| Module : SDL.Raw.Primitive-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_gfx@ library, specifically the primitives drawing@@ -12,6 +12,9 @@ -} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-missing-exported-signatures #-}+{-# OPTIONS_GHC -fno-warn-missing-local-signatures #-}+{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-} {-# LANGUAGE TemplateHaskell #-} @@ -171,8 +174,8 @@ liftF "filledPolygon" "filledPolygonRGBA" [t|Renderer -> Ptr X -> Ptr Y -> N -> R -> G -> B -> A -> IO CInt|] -liftF "texturedPolygon" "texturedPolygonRGBA"- [t|Renderer -> Ptr X -> Ptr Y -> N -> Ptr Surface -> X -> Y -> R -> G -> B -> A -> IO CInt|]+liftF "texturedPolygon" "texturedPolygon"+ [t|Renderer -> Ptr X -> Ptr Y -> N -> Ptr Surface -> X -> Y -> IO CInt|] liftF "bezier" "bezierRGBA" [t|Renderer -> Ptr X -> Ptr Y -> N -> N -> R -> G -> B -> A -> IO CInt|]
src/SDL/Raw/Rotozoom.hsc view
@@ -1,9 +1,9 @@ {-| Module : SDL.Raw.Rotozoom-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_gfx@ library, specifically the surface rotation and@@ -12,6 +12,9 @@ -} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-missing-exported-signatures #-}+{-# OPTIONS_GHC -fno-warn-missing-local-signatures #-}+{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-}@@ -45,16 +48,16 @@ liftF "rotozoomXY" "rotozoomSurfaceXY" [t|Ptr Surface -> CDouble -> CDouble -> CDouble -> CInt -> IO (Ptr Surface)|] -liftF "rotozoomSize" "rotozoomSize"+liftF "rotozoomSize" "rotozoomSurfaceSize" [t|CInt -> CInt -> CDouble -> CDouble -> Ptr CInt -> Ptr CInt -> IO ()|] -liftF "rotozoomSizeXY" "rotozoomSizeXY"+liftF "rotozoomSizeXY" "rotozoomSurfaceSizeXY" [t|CInt -> CInt -> CDouble -> CDouble -> CDouble -> Ptr CInt -> Ptr CInt -> IO ()|] liftF "zoom" "zoomSurface" [t|Ptr Surface -> CDouble -> CDouble -> CInt -> IO (Ptr Surface)|] -liftF "zoomSize" "zoomSize"+liftF "zoomSize" "zoomSurfaceSize" [t|CInt -> CInt -> CDouble -> CDouble -> Ptr CInt -> Ptr CInt -> IO ()|] liftF "shrink" "shrinkSurface"
src/SDL/Rotozoom.hs view
@@ -1,46 +1,44 @@-{-|--Module : SDL.Rotozoom-Copyright : (c) 2015 Siniša Biđin-License : MIT-Maintainer : sinisa@bidin.eu-Stability : experimental--Bindings to @SDL2_gfx@'s surface rotation and zoom functionality.---}- {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-} +-- |+--+-- Module : SDL.Rotozoom+-- Copyright : (c) 2015 Siniša Biđin+-- License : MIT+-- Maintainer : sinisa@bidin.eu+-- Stability : experimental+--+-- Bindings to @SDL2_gfx@'s surface rotation and zoom functionality. module SDL.Rotozoom- ( Angle- , Zoom- , Smooth(..)- , rotozoom- , rotozoomXY- , Size- , rotozoomSize- , rotozoomSizeXY- , zoom- , zoomXY- , zoomSize- , zoomSizeXY- , shrink- , rotate90- ) where+ ( Angle,+ Zoom,+ Smooth (..),+ rotozoom,+ rotozoomXY,+ Size,+ rotozoomSize,+ rotozoomSizeXY,+ zoom,+ zoomXY,+ zoomSize,+ zoomSizeXY,+ shrink,+ rotate90,+ )+where import Control.Monad.IO.Class (MonadIO, liftIO)-import Foreign.C.Types (CInt)-import Foreign.Marshal.Alloc (alloca)-import Foreign.Ptr (Ptr)-import Foreign.Storable (peek)-import Linear (V2(..))-import GHC.Generics (Generic)-import SDL (Surface(..))-+import Foreign.C.Types (CInt)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Ptr (Ptr)+import Foreign.Storable (peek)+import GHC.Generics (Generic)+import SDL (Surface (..)) import qualified SDL.Raw import qualified SDL.Raw.Rotozoom+import SDL.Vect (V2 (..)) -- | Desired rotation in degrees. type Angle = Double@@ -50,12 +48,12 @@ -- | Whether resulting 'Surface's are anti-aliased or not. data Smooth = Smooth | Rough- deriving (Eq, Enum, Ord, Bounded, Generic, Read, Show)+ deriving stock (Eq, Enum, Ord, Bounded, Generic, Read, Show) smoothToCInt :: Smooth -> CInt smoothToCInt = \case Smooth -> SDL.Raw.Rotozoom.SMOOTHING_ON- Rough -> SDL.Raw.Rotozoom.SMOOTHING_OFF+ Rough -> SDL.Raw.Rotozoom.SMOOTHING_OFF -- | A helper for unmanaged 'Surface's, since it is not exposed by SDL itself. unmanaged :: Ptr SDL.Raw.Surface -> Surface@@ -67,8 +65,8 @@ -- 32-bit RGBA. rotozoom :: MonadIO m => Surface -> Angle -> Zoom -> Smooth -> m Surface rotozoom (Surface p _) a z s =- unmanaged <$>- SDL.Raw.Rotozoom.rotozoom p (realToFrac a) (realToFrac z) (smoothToCInt s)+ unmanaged+ <$> SDL.Raw.Rotozoom.rotozoom p (realToFrac a) (realToFrac z) (smoothToCInt s) -- | Same as 'rotozoom', but applies different horizontal and vertical scaling -- factors.@@ -76,9 +74,13 @@ -- The 'Zoom' arguments are the horizontal and vertical zoom, respectively. rotozoomXY :: MonadIO m => Surface -> Angle -> Zoom -> Zoom -> Smooth -> m Surface rotozoomXY (Surface p _) a zx zy s =- unmanaged <$>- SDL.Raw.Rotozoom.rotozoomXY- p (realToFrac a) (realToFrac zx) (realToFrac zy) (smoothToCInt s)+ unmanaged+ <$> SDL.Raw.Rotozoom.rotozoomXY+ p+ (realToFrac a)+ (realToFrac zx)+ (realToFrac zy)+ (smoothToCInt s) -- | A surface size, packing width and height. type Size = V2 CInt@@ -87,8 +89,9 @@ -- resulting from a 'rotozoom' call. rotozoomSize :: MonadIO m => Size -> Angle -> Zoom -> m Size rotozoomSize (V2 w h) a z =- liftIO .- alloca $ \w' ->+ liftIO+ . alloca+ $ \w' -> alloca $ \h' -> do SDL.Raw.Rotozoom.rotozoomSize w h (realToFrac a) (realToFrac z) w' h' V2 <$> peek w' <*> peek h'@@ -97,14 +100,22 @@ -- factors. rotozoomSizeXY :: MonadIO m => Size -> Angle -> Zoom -> Zoom -> m Size rotozoomSizeXY (V2 w h) a zx zy =- liftIO .- alloca $ \w' ->+ liftIO+ . alloca+ $ \w' -> alloca $ \h' -> do SDL.Raw.Rotozoom.rotozoomSizeXY- w h (realToFrac a) (realToFrac zx) (realToFrac zy) w' h'+ w+ h+ (realToFrac a)+ (realToFrac zx)+ (realToFrac zy)+ w'+ h' V2 <$> peek w' <*> peek h' {-# INLINE zoom #-}+ -- | Same as 'rotozoom', but only performs the zoom. -- -- If a 'Zoom' factor is negative, it flips the image on both axes.@@ -118,10 +129,11 @@ -- axis. zoomXY :: MonadIO m => Surface -> Zoom -> Zoom -> Smooth -> m Surface zoomXY (Surface p _) zx zy s =- unmanaged <$>- SDL.Raw.Rotozoom.zoom p (realToFrac zx) (realToFrac zy) (smoothToCInt s)+ unmanaged+ <$> SDL.Raw.Rotozoom.zoom p (realToFrac zx) (realToFrac zy) (smoothToCInt s) {-# INLINE zoomSize #-}+ -- | Calculates the 'Size' of a resulting 'Surface' for a 'zoom' call. zoomSize :: MonadIO m => Size -> Zoom -> m Size zoomSize size z = zoomSizeXY size z z@@ -130,8 +142,9 @@ -- factors. zoomSizeXY :: MonadIO m => Size -> Angle -> Zoom -> m Size zoomSizeXY (V2 w h) zx zy =- liftIO .- alloca $ \w' ->+ liftIO+ . alloca+ $ \w' -> alloca $ \h' -> do SDL.Raw.Rotozoom.zoomSize w h (realToFrac zx) (realToFrac zy) w' h' V2 <$> peek w' <*> peek h'