diff --git a/SFML.cabal b/SFML.cabal --- a/SFML.cabal +++ b/SFML.cabal @@ -1,8 +1,8 @@ name: SFML -version: 0.2.0.0 +version: 2.3.2 synopsis: SFML bindings description: - Low level bindings for SFML 2.0. + Low level bindings for SFML 2.3.2. license: MIT license-file: LICENSE author: Marc Sunet @@ -13,6 +13,15 @@ build-type: Simple cabal-version: >=1.8 +source-repository head + type: git + location: https://github.com/SFML-haskell + +Flag OfficialCSFMLForWindows + Description: Use the official CSFML bundle for Windows from http://www.sfml-dev.org/download/csfml/ + default: False + + library hs-source-dirs: src @@ -40,6 +49,7 @@ SFML.Graphics.Color SFML.Graphics.ConvexShape SFML.Graphics.Font + SFML.Graphics.FontInfo SFML.Graphics.Glyph SFML.Graphics.Image SFML.Graphics.PrimitiveType @@ -50,12 +60,14 @@ SFML.Graphics.RenderWindow SFML.Graphics.SFBindable SFML.Graphics.SFBounded + SFML.Graphics.SFDrawable SFML.Graphics.SFCoordSpace SFML.Graphics.SFRenderTarget SFML.Graphics.SFShape SFML.Graphics.SFShapeResizable SFML.Graphics.SFSmoothTexture SFML.Graphics.SFTexturable + SFML.Graphics.SFTransformable SFML.Graphics.SFViewable SFML.Graphics.Shader SFML.Graphics.Shape @@ -63,12 +75,13 @@ SFML.Graphics.Text SFML.Graphics.Texture SFML.Graphics.Transform - SFML.Graphics.Transformable SFML.Graphics.Types + SFML.Graphics.Types SFML.Graphics.Vertex SFML.Graphics.VertexArray SFML.Graphics.View SFML.SFCopyable SFML.SFDisplayable + SFML.SFException SFML.SFResource SFML.System.Clock SFML.System.InputStream @@ -81,6 +94,7 @@ SFML.Window.ContextSettings SFML.Window.Event SFML.Window.Joystick + SFML.Window.JoystickIdentification SFML.Window.Keyboard SFML.Window.Mouse SFML.Window.SFWindow @@ -112,6 +126,7 @@ cbits/SFML/System/Clock_helper.c cbits/SFML/System/Time_helper.c cbits/SFML/System/Sleep_helper.c + cbits/SFML/Window/Joystick_helper.c cbits/SFML/Window/VideoMode_helper.c cbits/SFML/Window/Window_helper.c @@ -123,10 +138,24 @@ extensions: ForeignFunctionInterface + DeriveDataTypeable - extra-libraries: - csfml-window, - csfml-system, - csfml-graphics, - csfml-network, - csfml-audio + if os(windows) + extra-libraries: + csfml-window, + csfml-system, + csfml-graphics, + csfml-network, + csfml-audio + else + extra-libraries: + csfml-window, + csfml-system, + csfml-graphics, + csfml-network, + csfml-audio, + sfml-window, + sfml-system, + sfml-graphics, + sfml-network, + sfml-audio diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple main = defaultMain + diff --git a/cbits/SFML/Audio/Listener_helper.c b/cbits/SFML/Audio/Listener_helper.c --- a/cbits/SFML/Audio/Listener_helper.c +++ b/cbits/SFML/Audio/Listener_helper.c @@ -24,3 +24,15 @@ *direction = sfListener_getDirection (); } + +void sfListener_setUpVector_helper (sfVector3f* upVector) +{ + sfListener_setUpVector (*upVector); +} + + +void sfListener_getUpVector_helper (sfVector3f* upVector) +{ + *upVector = sfListener_getUpVector (); +} + diff --git a/cbits/SFML/Graphics/Font_helper.c b/cbits/SFML/Graphics/Font_helper.c --- a/cbits/SFML/Graphics/Font_helper.c +++ b/cbits/SFML/Graphics/Font_helper.c @@ -6,3 +6,8 @@ *glyph = sfFont_getGlyph (font, codePoint, characterSize, bold); } + +void sfFont_getInfo_helper (sfFont* font, sfFontInfo* info) +{ + *info = sfFont_getInfo (font); +} diff --git a/cbits/SFML/Window/Joystick_helper.c b/cbits/SFML/Window/Joystick_helper.c new file mode 100644 --- /dev/null +++ b/cbits/SFML/Window/Joystick_helper.c @@ -0,0 +1,7 @@ +#include + + +void sfJoystick_getIdentification_helper (unsigned int joystick, sfJoystickIdentification* ident) +{ + *ident = sfJoystick_getIdentification(joystick); +} diff --git a/src/SFML/Audio/Listener.hs b/src/SFML/Audio/Listener.hs --- a/src/SFML/Audio/Listener.hs +++ b/src/SFML/Audio/Listener.hs @@ -6,6 +6,8 @@ , getListenerPosition , setListenerDirection , getListenerDirection +, setListenerUpVector +, getListenerUpVector ) where @@ -70,13 +72,15 @@ --CSFML_AUDIO_API sfVector3f sfListener_getPosition(); --- | Set the orientation of the listener in the scene. +-- | Set the orientation of the forward vector in the scene. -- --- The orientation defines the 3D axes of the listener --- (left, up, front) in the scene. The orientation vector --- doesn't have to be normalized. +-- The direction (also called "at vector") is the vector +-- pointing forward from the listener's perspective. Together +-- with the up vector, it defines the 3D orientation of the +-- listener in the scene. The direction vector doesn't +-- have to be normalized. -- --- The default listener's orientation is (0, 0, -1). +-- The default listener's direction is (0, 0, -1). setListenerDirection :: Vec3f -> IO () setListenerDirection dir = with dir sfListener_setDirection_helper @@ -95,3 +99,29 @@ --CSFML_AUDIO_API sfVector3f sfListener_getDirection(); + +-- | Set the upward vector of the listener in the scene +-- +-- The up vector is the vector that points upward from the +-- listener's perspective. Together with the direction, it +-- defines the 3D orientation of the listener in the scene. +-- The up vector doesn't have to be normalized. +-- The default listener's up vector is (0, 1, 0). It is usually +-- not necessary to change it, especially in 2D scenarios. +setListenerUpVector :: Vec3f -> IO () +setListenerUpVector dir = with dir sfListener_setUpVector_helper + +foreign import ccall unsafe "sfListener_setUpVector_helper" + sfListener_setUpVector_helper :: Ptr Vec3f -> IO () + +--CSFML_AUDIO_API void sfListener_setUpVector(sfVector3f upVector); + + +-- | Get the current upward vector (unnormalised) of the listener in the scene. +getListenerUpVector :: IO Vec3f +getListenerUpVector = alloca $ \ptr -> sfListener_getUpVector_helper ptr >> peek ptr + +foreign import ccall unsafe "sfListener_getUpVector_helper" + sfListener_getUpVector_helper :: Ptr Vec3f -> IO () + +--CSFML_AUDIO_API sfVector3f sfListener_getUpVector(); diff --git a/src/SFML/Audio/Music.hs b/src/SFML/Audio/Music.hs --- a/src/SFML/Audio/Music.hs +++ b/src/SFML/Audio/Music.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} module SFML.Audio.Music ( module SFML.Utils -, MusicException(..) , musicFromFile , musicFromMemory , musicFromStream @@ -39,15 +37,14 @@ import SFML.Audio.SFSoundBuffer import SFML.Audio.SoundStatus import SFML.Audio.Types +import SFML.SFException import SFML.SFResource import SFML.System.InputStream import SFML.System.Time import SFML.System.Vector3 import SFML.Utils -import Control.Exception import Control.Monad ((>=>)) -import Data.Typeable import Foreign.Marshal.Utils (with) import Foreign.Marshal.Alloc (alloca) import Foreign.C.String @@ -60,11 +57,7 @@ checkNull music@(Music ptr) = if ptr == nullPtr then Nothing else Just music -data MusicException = MusicException String deriving (Show, Typeable) -instance Exception MusicException - - -- | Create a new music and load it from a file. -- -- This function doesn't start playing the music (call @@ -73,9 +66,9 @@ -- Here is a complete list of all the supported audio formats: -- ogg, wav, flac, aiff, au, raw, paf, svx, nist, voc, ircam, -- w64, mat4, mat5 pvf, htk, sds, avr, sd2, caf, wve, mpc2k, rf64. -musicFromFile :: FilePath -> IO (Either MusicException Music) +musicFromFile :: FilePath -> IO (Either SFException Music) musicFromFile path = - let err = MusicException $ "Failed loading music from file " ++ path + let err = SFException $ "Failed loading music from file " ++ path in withCAString path $ \cstr -> sfMusic_createFromFile cstr >>= return . tagErr err . checkNull foreign import ccall unsafe "sfMusic_createFromFile" @@ -97,10 +90,10 @@ musicFromMemory :: Ptr a -- ^ Pointer to the file data in memory -> Int -- ^ Size of the data to load, in bytes - -> IO (Either MusicException Music) + -> IO (Either SFException Music) musicFromMemory ptr size = - let err = MusicException $ "Failed loading music from memory address " ++ show ptr + let err = SFException $ "Failed loading music from memory address " ++ show ptr in fmap (tagErr err . checkNull) $ sfMusic_createFromMemory ptr (fromIntegral size) foreign import ccall unsafe "sfMusic_createFromMemory" @@ -119,9 +112,9 @@ -- Here is a complete list of all the supported audio formats: -- ogg, wav, flac, aiff, au, raw, paf, svx, nist, voc, ircam, -- w64, mat4, mat5 pvf, htk, sds, avr, sd2, caf, wve, mpc2k, rf64. -musicFromStream :: InputStream -> IO (Either MusicException Music) +musicFromStream :: InputStream -> IO (Either SFException Music) musicFromStream is = - let err = MusicException $ "Failed loading music from input stream " ++ show is + let err = SFException $ "Failed loading music from input stream " ++ show is in with is $ \ptr -> sfMusic_createFromStream ptr >>= return . tagErr err . checkNull foreign import ccall unsafe "sfMusic_createFromStream" diff --git a/src/SFML/Audio/SFSoundRecorder.hs b/src/SFML/Audio/SFSoundRecorder.hs --- a/src/SFML/Audio/SFSoundRecorder.hs +++ b/src/SFML/Audio/SFSoundRecorder.hs @@ -3,7 +3,7 @@ class SFSoundRecorder a where - + -- | Start the capture of a sound recorder. -- -- The sample rate parameter defines the number of audio samples @@ -12,13 +12,15 @@ -- -- This function uses its own thread so that it doesn't block -- the rest of the program while the capture runs. - -- + -- -- Please note that only one capture can happen at the same time. + -- + -- Return 'True' if start of capture was successful, 'False' otherwise. startRecording :: a -> Int -- ^ Desired capture rate, in number of samples per second - -> IO () - + -> IO Bool + -- | Stop the capture of a sound recorder. stopRecording :: a -> IO () diff --git a/src/SFML/Audio/SoundBuffer.hs b/src/SFML/Audio/SoundBuffer.hs --- a/src/SFML/Audio/SoundBuffer.hs +++ b/src/SFML/Audio/SoundBuffer.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} module SFML.Audio.SoundBuffer ( module SFML.Utils -, SoundBufferException(..) , soundBufferFromFile , soundBufferFromMemory , soundBufferFromStream @@ -22,14 +20,13 @@ import SFML.Audio.SFSampled import SFML.Audio.SFSoundBuffer import SFML.Audio.Types +import SFML.SFException import SFML.SFResource import SFML.System.InputStream import SFML.System.Time import SFML.Utils -import Control.Exception import Control.Monad ((>=>)) -import Data.Typeable import Foreign.C.String import Foreign.C.Types import Foreign.Marshal.Alloc (alloca) @@ -42,19 +39,14 @@ checkNull buf@(SoundBuffer ptr) = if ptr == nullPtr then Nothing else Just buf -data SoundBufferException = SoundBufferException String deriving (Show, Typeable) - -instance Exception SoundBufferException - - -- | Create a new sound buffer and load it from a file. -- -- Here is a complete list of all the supported audio formats: -- ogg, wav, flac, aiff, au, raw, paf, svx, nist, voc, ircam, -- w64, mat4, mat5 pvf, htk, sds, avr, sd2, caf, wve, mpc2k, rf64. -soundBufferFromFile :: FilePath -> IO (Either SoundBufferException SoundBuffer) +soundBufferFromFile :: FilePath -> IO (Either SFException SoundBuffer) soundBufferFromFile path = - let err = SoundBufferException $ "Failed loading sound buffer from file: " ++ show path + let err = SFException $ "Failed loading sound buffer from file: " ++ show path in fmap (tagErr err . checkNull) $ withCAString path sfSoundBuffer_createFromFile foreign import ccall unsafe "sfSoundBuffer_createFromFile" @@ -73,10 +65,10 @@ soundBufferFromMemory :: Ptr a -- ^ Pointer to the file data in memory -> Int -- ^ Size of the data to load, in bytes - -> IO (Either SoundBufferException SoundBuffer) -- ^ A new sfSoundBuffer object ('Nothing' if failed) + -> IO (Either SFException SoundBuffer) -- ^ A new sfSoundBuffer object ('Nothing' if failed) soundBufferFromMemory ptr size = - let err = SoundBufferException $ "Failed loading sound buffer from memory address " ++ show ptr + let err = SFException $ "Failed loading sound buffer from memory address " ++ show ptr in sfSoundBuffer_createFromMemory ptr (fromIntegral size) >>= return . tagErr err . checkNull foreign import ccall unsafe "sfSoundBuffer_createFromMemory" @@ -92,10 +84,10 @@ -- w64, mat4, mat5 pvf, htk, sds, avr, sd2, caf, wve, mpc2k, rf64. soundBufferFromStream :: InputStream - -> IO (Either SoundBufferException SoundBuffer) -- ^ A new sfSoundBuffer object ('Nothing' if failed) + -> IO (Either SFException SoundBuffer) -- ^ A new sfSoundBuffer object ('Nothing' if failed) soundBufferFromStream is = - let err = SoundBufferException $ "Failed loading sound buffer from input stream " ++ show is + let err = SFException $ "Failed loading sound buffer from input stream " ++ show is in with is sfSoundBuffer_createFromStream >>= return . tagErr err . checkNull foreign import ccall unsafe "sfSoundBuffer_createFromStream" diff --git a/src/SFML/Audio/SoundBufferRecorder.hs b/src/SFML/Audio/SoundBufferRecorder.hs --- a/src/SFML/Audio/SoundBufferRecorder.hs +++ b/src/SFML/Audio/SoundBufferRecorder.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} module SFML.Audio.SoundBufferRecorder ( module SFML.Utils -, SoundBufferRecorderException(..) , createSoundBufferRecorder , destroy , startRecording @@ -16,12 +14,13 @@ import SFML.Audio.SFSampled import SFML.Audio.SFSoundRecorder import SFML.Audio.Types +import SFML.SFException import SFML.SFResource import SFML.Utils +import Control.Applicative ((<$>), (<*>)) import Control.Exception import Control.Monad ((>=>)) -import Data.Typeable import Foreign.C.Types import Foreign.Ptr (nullPtr) @@ -30,15 +29,10 @@ checkNull sbr@(SoundBufferRecorder ptr) = if ptr == nullPtr then Nothing else Just sbr -data SoundBufferRecorderException = SoundBufferRecorderException String deriving (Show, Typeable) - -instance Exception SoundBufferRecorderException - - -- | Create a new sound buffer recorder. -createSoundBufferRecorder :: IO (Either SoundBufferRecorderException SoundBufferRecorder) +createSoundBufferRecorder :: IO (Either SFException SoundBufferRecorder) createSoundBufferRecorder = - let err = SoundBufferRecorderException $ "Failed creating sound buffer recorder" + let err = SFException $ "Failed creating sound buffer recorder" in fmap (tagErr err . checkNull) sfSoundBufferRecorder_create foreign import ccall unsafe "sfSoundBufferRecorder_create" @@ -50,7 +44,7 @@ instance SFResource SoundBufferRecorder where - + {-# INLINABLE destroy #-} destroy = sfSoundBufferRecorder_destroy @@ -61,16 +55,16 @@ instance SFSoundRecorder SoundBufferRecorder where - + {-# INLINABLE startRecording #-} - startRecording rec rate = sfSoundBufferRecorder_start rec (fromIntegral rate) - + startRecording rec rate = ((/=0) . fromIntegral) <$> sfSoundBufferRecorder_start rec (fromIntegral rate) + {-# INLINABLE stopRecording #-} stopRecording = sfSoundBufferRecorder_stop foreign import ccall unsafe "sfSoundBufferRecorder_start" - sfSoundBufferRecorder_start :: SoundBufferRecorder -> CUInt -> IO () + sfSoundBufferRecorder_start :: SoundBufferRecorder -> CUInt -> IO CInt -- CSFML_AUDIO_API void sfSoundBufferRecorder_start(sfSoundBufferRecorder* soundBufferRecorder, unsigned int sampleRate); @@ -81,7 +75,7 @@ instance SFSampled SoundBufferRecorder where - + {-# INLINABLE getSampleRate #-} getSampleRate = sfSoundBufferRecorder_getSampleRate >=> return . fromIntegral diff --git a/src/SFML/Audio/SoundRecorder.hs b/src/SFML/Audio/SoundRecorder.hs --- a/src/SFML/Audio/SoundRecorder.hs +++ b/src/SFML/Audio/SoundRecorder.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} module SFML.Audio.SoundRecorder ( module SFML.Utils -, SoundRecorderException(..) , SoundRecorderStartCallback , SoundRecorderProcessCallback , SoundRecorderStopCallback @@ -12,6 +10,11 @@ , stopRecording , getSampleRate , isSoundRecorderAvailable +, setProcessingInterval +, getAvailableSoundRecordingDevices +, getDefaultSoundRecordingDevice +, setSoundRecordingDevice +, getSoundRecordingDevice ) where @@ -19,26 +22,26 @@ import SFML.Audio.SFSampled import SFML.Audio.SFSoundRecorder import SFML.Audio.Types +import SFML.SFException import SFML.SFResource +import SFML.System.Time import SFML.Utils -import Control.Exception -import Control.Monad ((>=>)) -import Data.Typeable +import Control.Applicative ((<$>), (<*>)) +import Control.Monad ((>=>), forM) import Data.Word (Word16) +import Foreign.C.String import Foreign.C.Types -import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Array (advancePtr) +import Foreign.Storable +import Foreign.Ptr checkNull :: SoundRecorder -> Maybe SoundRecorder checkNull sr@(SoundRecorder ptr) = if ptr == nullPtr then Nothing else Just sr -data SoundRecorderException = SoundRecorderException String deriving (Show, Typeable) - -instance Exception SoundRecorderException - - -- | Type of the callback used when starting a capture. type SoundRecorderStartCallback a = Ptr a -> IO CInt @@ -62,10 +65,10 @@ -> Ptr (SoundRecorderProcessCallback a) -- ^ (onProcess) Callback function which will be called each time there's audio data to process -> Ptr (SoundRecorderStopCallback a) -- ^ (onStop) Callback function which will be called when the current capture stops (can be NULL) -> Ptr a -- ^ Data to pass to the callback function (can be NULL) - -> IO (Either SoundRecorderException SoundRecorder) -- ^ A new 'SoundRecorder' object ('Nothing' if failed) + -> IO (Either SFException SoundRecorder) -- ^ A new 'SoundRecorder' object ('Nothing' if failed) createSoundRecorder c1 c2 c3 d = - let err = SoundRecorderException $ + let err = SFException $ "Failed creating sound recorder: onStart = " ++ show c1 ++ " onProcess = " ++ show c2 ++ " onStop = " ++ show c3 ++ @@ -84,7 +87,7 @@ instance SFResource SoundRecorder where - + {-# INLINABLE destroy #-} destroy = sfSoundRecorder_destroy @@ -95,16 +98,16 @@ instance SFSoundRecorder SoundRecorder where - + {-# INLINABLE startRecording #-} - startRecording rec rate = sfSoundRecorder_start rec (fromIntegral rate) - + startRecording rec rate = ((/=0) . fromIntegral) <$> sfSoundRecorder_start rec (fromIntegral rate) + {-# INLINABLE stopRecording #-} stopRecording = sfSoundRecorder_stop foreign import ccall unsafe "sfSoundRecorder_start" - sfSoundRecorder_start :: SoundRecorder -> CUInt -> IO () + sfSoundRecorder_start :: SoundRecorder -> CUInt -> IO CInt -- CSFML_AUDIO_API void sfSoundRecorder_start(sfSoundRecorder* soundRecorder, unsigned int sampleRate); @@ -115,7 +118,7 @@ instance SFSampled SoundRecorder where - + {-# INLINABLE getSampleRate #-} getSampleRate = sfSoundRecorder_getSampleRate >=> return . fromIntegral @@ -138,4 +141,92 @@ sfSoundRecorder_isAvailable :: IO CInt -- CSFML_AUDIO_API sfBool sfSoundRecorder_isAvailable(void); + + +-- | Set the processing interval. +-- +-- The processing interval controls the period +-- between calls to the onProcessSamples function. You may +-- want to use a small interval if you want to process the +-- recorded data in real time, for example. +-- +-- Note: this is only a hint, the actual period may vary. +-- So don't rely on this parameter to implement precise timing. +-- +-- The default processing interval is 100 ms. +setProcessingInterval + :: SoundRecorder + -> Time -- ^ Processing interval + -> IO () + +setProcessingInterval = sfSoundRecorder_setProcessingInterval + +foreign import ccall unsafe "sfSoundRecorder_setProcessingInterval" + sfSoundRecorder_setProcessingInterval :: SoundRecorder -> Time -> IO () + +--CSFML_AUDIO_API void sfSoundRecorder_setProcessingInterval(sfSoundRecorder* soundRecorder, sfTime interval); + + +-- | Get a list of the names of all availabe audio capture devices. +-- +-- This function returns an array of strings (null terminated), +-- containing the names of all availabe audio capture devices. +-- If no devices are available then 'Nothing' is returned. +getAvailableSoundRecordingDevices :: IO [String] +getAvailableSoundRecordingDevices = alloca $ \pCount -> do + pNames <- sfSoundRecorder_getAvailableDevices pCount + count <- fromIntegral <$> peek pCount :: IO Int + forM [1..count] $ peekCString . advancePtr (castPtr pNames) + +foreign import ccall unsafe "sfSoundRecorder_getAvailableDevices" + sfSoundRecorder_getAvailableDevices :: Ptr CSize -> IO (Ptr CString) + +--CSFML_AUDIO_API const char** sfSoundRecorder_getAvailableDevices(size_t* count); + + +-- | Get the name of the default audio capture device. +-- +-- This function returns the name of the default audio +-- capture device. If none is available, NULL is returned. + +getDefaultSoundRecordingDevice :: IO String +getDefaultSoundRecordingDevice = sfSoundRecorder_getDefaultDevice >>= peekCString + +foreign import ccall unsafe "sfSoundRecorder_getDefaultDevice" + sfSoundRecorder_getDefaultDevice :: IO CString + +--CSFML_AUDIO_API const char* sfSoundRecorder_getDefaultDevice(); + + +-- | Set the audio capture device. +-- +-- This function sets the audio capture device to the device +-- with the given name. It can be called on the fly (i.e: +-- while recording). If you do so while recording and +-- opening the device fails, it stops the recording. +-- +-- Return 'True if it was able to set the requested device, 'False' otherwise. +setSoundRecordingDevice + :: SoundRecorder + -> String -- ^ The name of the audio capture device + -> IO Bool + +setSoundRecordingDevice rec name = withCString name $ \cname -> + ((/=0) . fromIntegral) <$> sfSoundRecorder_setDevice rec cname + +foreign import ccall unsafe "sfSoundRecorder_setDevice" + sfSoundRecorder_setDevice :: SoundRecorder -> CString -> IO CInt + +--CSFML_AUDIO_API sfBool sfSoundRecorder_setDevice(sfSoundRecorder* soundRecorder, const char* name); + + +-- | Get the name of the current audio capture device. +getSoundRecordingDevice :: SoundRecorder -> IO String +getSoundRecordingDevice rec = sfSoundRecorder_getDevice rec >>= peekCString + +foreign import ccall unsafe "sfSoundRecorder_getDevice" + sfSoundRecorder_getDevice :: SoundRecorder -> IO CString + +--CSFML_AUDIO_API const char* sfSoundRecorder_getDevice(sfSoundRecorder* soundRecorder); + diff --git a/src/SFML/Audio/SoundStream.hsc b/src/SFML/Audio/SoundStream.hsc --- a/src/SFML/Audio/SoundStream.hsc +++ b/src/SFML/Audio/SoundStream.hsc @@ -36,6 +36,7 @@ import SFML.System.Time import SFML.System.Vector3 +import Control.Applicative ((<$>), (<*>)) import Control.Monad ((>=>)) import Data.Word (Word16) import Foreign.C.Types @@ -70,12 +71,11 @@ instance Storable SoundStreamChunk where sizeOf _ = size_SoundStreamChunk alignment _ = alignment (undefined :: CInt) - - peek ptr = do - samples <- #{peek sfSoundStreamChunk, samples} ptr - sampleCount <- #{peek sfSoundStreamChunk, sampleCount} ptr :: IO CUInt - return $ SoundStreamChunk samples (fromIntegral sampleCount) - + + peek ptr = SoundStreamChunk + <$> #{peek sfSoundStreamChunk, samples} ptr + <*> fmap fromIntegral (#{peek sfSoundStreamChunk, sampleCount} ptr :: IO CUInt) + poke ptr (SoundStreamChunk samples sampleCount) = do #{poke sfSoundStreamChunk, samples} ptr samples #{poke sfSoundStreamChunk, sampleCount} ptr (fromIntegral sampleCount :: CUInt) @@ -120,7 +120,7 @@ instance SFResource SoundStream where - + {-# INLINABLE destroy #-} destroy = sfSoundStream_destroy @@ -131,64 +131,64 @@ instance SFSound SoundStream where - + {-# INLINABLE play #-} play = sfSoundStream_play - + {-# INLINABLE pause #-} pause = sfSoundStream_pause - + {-# INLINABLE stop #-} stop = sfSoundStream_stop - + {-# INLINABLE getAttenuation #-} getAttenuation = sfSoundStream_getAttenuation >=> return . realToFrac - + {-# INLINABLE getLoop #-} getLoop music = fmap (toEnum . fromIntegral) $ sfSoundStream_getLoop music - + {-# INLINABLE getMinDistance #-} getMinDistance = sfSoundStream_getMinDistance >=> return . realToFrac - + {-# INLINABLE getPitch #-} getPitch = sfSoundStream_getPitch >=> return . realToFrac - + {-# INLINABLE getPlayingOffset #-} getPlayingOffset music = alloca $ \ptr -> sfSoundStream_getPlayingOffset_helper music ptr >> peek ptr - + {-# INLINABLE getPosition #-} getPosition music = alloca $ \ptr -> sfSoundStream_getPosition_helper music ptr >> peek ptr - + {-# INLINABLE getStatus #-} getStatus = sfSoundStream_getStatus >=> return . toEnum . fromIntegral - + {-# INLINABLE getVolume #-} getVolume = sfSoundStream_getVolume >=> return . realToFrac - + {-# INLINABLE isRelativeToListener #-} isRelativeToListener = sfSoundStream_isRelativeToListener >=> return . toEnum . fromIntegral - + {-# INLINABLE setAttenuation #-} setAttenuation m a = sfSoundStream_setAttenuation m (realToFrac a) - + {-# INLINABLE setLoop #-} setLoop music val = sfSoundStream_setLoop music (fromIntegral . fromEnum $ val) - + {-# INLINABLE setMinDistance #-} setMinDistance m d = sfSoundStream_setMinDistance m (realToFrac d) - + {-# INLINABLE setPitch #-} setPitch m p = sfSoundStream_setPitch m (realToFrac p) - + {-# INLINABLE setPlayingOffset #-} setPlayingOffset = sfSoundStream_setPlayingOffset - + {-# INLINABLE setPosition #-} setPosition music pos = with pos $ sfSoundStream_setPosition_helper music - + {-# INLINABLE setRelativeToListener #-} setRelativeToListener music val = sfSoundStream_setRelativeToListener music (fromIntegral . fromEnum $ val) - + {-# INLINABLE setVolume #-} setVolume m v = sfSoundStream_setVolume m (realToFrac v) diff --git a/src/SFML/Graphics.hs b/src/SFML/Graphics.hs --- a/src/SFML/Graphics.hs +++ b/src/SFML/Graphics.hs @@ -16,11 +16,13 @@ , module SFML.Graphics.SFBindable , module SFML.Graphics.SFBounded , module SFML.Graphics.SFCoordSpace +, module SFML.Graphics.SFDrawable , module SFML.Graphics.SFRenderTarget , module SFML.Graphics.SFShape , module SFML.Graphics.SFShapeResizable , module SFML.Graphics.SFSmoothTexture , module SFML.Graphics.SFTexturable +, module SFML.Graphics.SFTransformable , module SFML.Graphics.SFViewable , module SFML.Graphics.Shader , module SFML.Graphics.Shape @@ -28,7 +30,6 @@ , module SFML.Graphics.Text , module SFML.Graphics.Texture , module SFML.Graphics.Transform -, module SFML.Graphics.Transformable , module SFML.Graphics.Types , module SFML.Graphics.Vertex , module SFML.Graphics.VertexArray @@ -53,11 +54,13 @@ import SFML.Graphics.SFBindable import SFML.Graphics.SFBounded import SFML.Graphics.SFCoordSpace +import SFML.Graphics.SFDrawable import SFML.Graphics.SFRenderTarget import SFML.Graphics.SFShape import SFML.Graphics.SFShapeResizable import SFML.Graphics.SFSmoothTexture import SFML.Graphics.SFTexturable +import SFML.Graphics.SFTransformable import SFML.Graphics.SFViewable import SFML.Graphics.Shader import SFML.Graphics.Shape @@ -65,7 +68,6 @@ import SFML.Graphics.Text import SFML.Graphics.Texture import SFML.Graphics.Transform -import SFML.Graphics.Transformable import SFML.Graphics.Types import SFML.Graphics.Vertex import SFML.Graphics.VertexArray diff --git a/src/SFML/Graphics/BlendMode.hs b/src/SFML/Graphics/BlendMode.hs deleted file mode 100644 --- a/src/SFML/Graphics/BlendMode.hs +++ /dev/null @@ -1,36 +0,0 @@ -module SFML.Graphics.BlendMode -( - BlendMode(..) -) -where - - -import Foreign.C.Types (CInt) -import Foreign.Ptr -import Foreign.Storable - - --- | Available blending modes for drawing. -data BlendMode - = BlendAlpha -- ^ Pixel = Src * a + Dest * (1 - a) - | BlendAdd -- ^ Pixel = Src + Dest - | BlendMultiply -- ^ Pixel = Src * Dest - | BlendNone -- ^ No blending - deriving (Eq, Enum, Bounded, Show) - - -instance Storable BlendMode where - sizeOf _ = sizeOf (undefined :: CInt) - alignment _ = alignment (undefined :: CInt) - - peek ptr = fmap (toEnum . fromIntegral) $ peek (castPtr ptr :: Ptr CInt) - poke ptr bm = poke (castPtr ptr :: Ptr CInt) (fromIntegral . fromEnum $ bm) - -{-typedef enum -{ - sfBlendAlpha, ///< Pixel = Src * a + Dest * (1 - a) - sfBlendAdd, ///< Pixel = Src + Dest - sfBlendMultiply, ///< Pixel = Src * Dest - sfBlendNone ///< No blending -} sfBlendMode;-} - diff --git a/src/SFML/Graphics/BlendMode.hsc b/src/SFML/Graphics/BlendMode.hsc new file mode 100644 --- /dev/null +++ b/src/SFML/Graphics/BlendMode.hsc @@ -0,0 +1,123 @@ +module SFML.Graphics.BlendMode +( + BlendFactor(..) +, BlendEquation(..) +, BlendMode(..) +, blendAlpha +, blendAdd +, blendMultiply +, blendNone +) +where + + +import Control.Applicative ((<$>), (<*>)) +import Foreign.C.Types (CInt) +import Foreign.Ptr +import Foreign.Storable + +#include + + +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t(y__); }, y__) + + +-- | Enumeration of the blending factors +data BlendFactor + = BlendFactorZero -- ^ (0, 0, 0, 0) + | BlendFactorOne -- ^ (1, 1, 1, 1) + | BlendFactorSrcColor -- ^ (src.r, src.g, src.b, src.a) + | BlendFactorOneMinusSrcColor -- ^ (1, 1, 1, 1) - (src.r, src.g, src.b, src.a) + | BlendFactorDstColor -- ^ (dst.r, dst.g, dst.b, dst.a) + | BlendFactorOneMinusDstColor -- ^ (1, 1, 1, 1) - (dst.r, dst.g, dst.b, dst.a) + | BlendFactorSrcAlpha -- ^ (src.a, src.a, src.a, src.a) + | BlendFactorOneMinusSrcAlpha -- ^ (1, 1, 1, 1) - (src.a, src.a, src.a, src.a) + | BlendFactorDstAlpha -- ^ (dst.a, dst.a, dst.a, dst.a) + | BlendFactorOneMinusDstAlpha -- ^ (1, 1, 1, 1) - (dst.a, dst.a, dst.a, dst.a) + deriving (Eq, Enum, Bounded, Show) + + +-- | Enumeration of the blending equations +data BlendEquation + = BlendEquationAdd -- ^ Pixel = Src * SrcFactor + Dst * DstFactor + | BlendEquationSubtract -- ^ Pixel = Src * SrcFactor - Dst * DstFactor + deriving (Eq, Enum, Bounded, Show) + + +-- | Available blending modes for drawing. +data BlendMode + = BlendMode + { colorSrcFactor :: BlendFactor -- ^ Source blending factor for the color channels + , colorDstFactor :: BlendFactor -- ^ Destination blending factor for the color channels + , colorEquation :: BlendEquation -- ^ Blending equation for the color channels + , alphaSrcFactor :: BlendFactor -- ^ Source blending factor for the alpha channel + , alphaDstFactor :: BlendFactor -- ^ Destination blending factor for the alpha channel + , alphaEquation :: BlendEquation -- ^ Blending equation for the alpha channel + } deriving (Eq, Show) + + +instance Storable BlendFactor where + sizeOf _ = #{size sfBlendFactor} + alignment _ = #{alignment sfBlendFactor} + + peek ptr = fmap (toEnum . fromIntegral) $ peek (castPtr ptr :: Ptr CInt) + poke ptr bm = poke (castPtr ptr :: Ptr CInt) (fromIntegral . fromEnum $ bm) + + +instance Storable BlendEquation where + sizeOf _ = #{size sfBlendEquation} + alignment _ = #{alignment sfBlendEquation} + + peek ptr = fmap (toEnum . fromIntegral) $ peek (castPtr ptr :: Ptr CInt) + poke ptr bm = poke (castPtr ptr :: Ptr CInt) (fromIntegral . fromEnum $ bm) + + +instance Storable BlendMode where + sizeOf _ = #{size sfBlendMode} + alignment _ = #{alignment sfBlendMode} + + peek ptr = BlendMode <$> #{peek sfBlendMode, colorSrcFactor} ptr + <*> #{peek sfBlendMode, colorDstFactor} ptr + <*> #{peek sfBlendMode, colorEquation} ptr + <*> #{peek sfBlendMode, alphaSrcFactor} ptr + <*> #{peek sfBlendMode, alphaDstFactor} ptr + <*> #{peek sfBlendMode, alphaEquation} ptr + poke ptr bm = do + #{poke sfBlendMode, colorSrcFactor} ptr (colorSrcFactor bm) + #{poke sfBlendMode, colorDstFactor} ptr (colorDstFactor bm) + #{poke sfBlendMode, colorEquation} ptr (colorEquation bm) + #{poke sfBlendMode, alphaSrcFactor} ptr (alphaSrcFactor bm) + #{poke sfBlendMode, alphaDstFactor} ptr (alphaDstFactor bm) + #{poke sfBlendMode, alphaEquation} ptr (alphaEquation bm) + + +blendAlpha = BlendMode BlendFactorSrcAlpha + BlendFactorOneMinusSrcAlpha + BlendEquationAdd + BlendFactorOne + BlendFactorOneMinusSrcAlpha + BlendEquationAdd + + +blendAdd = BlendMode BlendFactorSrcAlpha + BlendFactorOne + BlendEquationAdd + BlendFactorOne + BlendFactorOne + BlendEquationAdd + + +blendMultiply = BlendMode BlendFactorDstColor + BlendFactorZero + BlendEquationAdd + BlendFactorDstColor + BlendFactorZero + BlendEquationAdd + + +blendNone = BlendMode BlendFactorOne + BlendFactorZero + BlendEquationAdd + BlendFactorOne + BlendFactorZero + BlendEquationAdd diff --git a/src/SFML/Graphics/CircleShape.hs b/src/SFML/Graphics/CircleShape.hs --- a/src/SFML/Graphics/CircleShape.hs +++ b/src/SFML/Graphics/CircleShape.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} module SFML.Graphics.CircleShape ( module SFML.Utils -, CircleShapeException(..) , createCircleShape , copy , destroy @@ -47,16 +45,15 @@ import SFML.Graphics.SFShapeResizable import SFML.Graphics.SFTexturable import SFML.Graphics.Transform -import SFML.Graphics.Transformable +import SFML.Graphics.SFTransformable import SFML.Graphics.Types import SFML.SFCopyable +import SFML.SFException import SFML.SFResource import SFML.System.Vector2 import SFML.Utils -import Control.Exception import Control.Monad ((>=>)) -import Data.Typeable import Foreign.C.Types import Foreign.Ptr (Ptr, nullPtr) import Foreign.Marshal.Alloc (alloca) @@ -72,15 +69,10 @@ checkNullTexture tex@(Texture ptr) = if ptr == nullPtr then Nothing else Just tex -data CircleShapeException = CircleShapeException String deriving (Show, Typeable) - -instance Exception CircleShapeException - - -- | Create a new circle shape. -createCircleShape :: IO (Either CircleShapeException CircleShape) +createCircleShape :: IO (Either SFException CircleShape) createCircleShape = - let err = CircleShapeException "Failed creating circle shape" + let err = SFException "Failed creating circle shape" in fmap (tagErr err . checkNull) sfCircleShape_create foreign import ccall unsafe "sfCircleShape_create" @@ -114,7 +106,7 @@ --CSFML_GRAPHICS_API void sfCircleShape_destroy(sfCircleShape* shape); -instance Transformable CircleShape where +instance SFTransformable CircleShape where {-# INLINABLE setPosition #-} setPosition c p = with p $ sfCircleShape_setPosition_helper c diff --git a/src/SFML/Graphics/Color.hsc b/src/SFML/Graphics/Color.hsc --- a/src/SFML/Graphics/Color.hsc +++ b/src/SFML/Graphics/Color.hsc @@ -14,7 +14,9 @@ where -import Data.Word (Word8) +import Control.Applicative ((<$>), (<*>)) +import Data.Bits ((.&.), shiftR) +import Data.Word (Word8, Word32) import Foreign.Storable #include @@ -33,14 +35,13 @@ instance Storable Color where sizeOf _ = 4 * sizeOf (undefined :: Word8) alignment _ = alignment (undefined :: Word8) - - peek ptr = do - r <- #{peek sfColor, r} ptr - g <- #{peek sfColor, g} ptr - b <- #{peek sfColor, b} ptr - a <- #{peek sfColor, a} ptr - return $ Color r g b a - + + peek ptr = Color + <$> #{peek sfColor, r} ptr + <*> #{peek sfColor, g} ptr + <*> #{peek sfColor, b} ptr + <*> #{peek sfColor, a} ptr + poke ptr (Color r g b a) = do #{poke sfColor, r} ptr r #{poke sfColor, g} ptr g @@ -60,13 +61,17 @@ instance Num Color where - + (Color r1 g1 b1 a1) + (Color r2 g2 b2 a2) = Color (r1+r2) (g1+g2) (b1+b2) (a1+a2) (Color r1 g1 b1 a1) - (Color r2 g2 b2 a2) = Color (r1-r2) (g1-g2) (b1-b2) (a1-a2) (Color r1 g1 b1 a1) * (Color r2 g2 b2 a2) = Color (r1*r2) (g1*g2) (b1*b2) (a1*a2) negate (Color r g b a) = Color (-r) (-g) (-b) (-a) abs (Color r g b a) = Color (abs r) (abs g) (abs b) (abs a) signum (Color r g b a) = Color (signum r) (signum g) (signum b) (signum a) - fromInteger i = let i' = fromIntegral i in Color i' i' i' i' - - + fromInteger i' = + let i = fromIntegral i' :: Word32 + r = fromIntegral $ (i .&. 0xFF000000) `shiftR` 24 + g = fromIntegral $ (i .&. 0x00FF0000) `shiftR` 16 + b = fromIntegral $ (i .&. 0x0000FF00) `shiftR` 8 + a = fromIntegral $ i .&. 0x000000FF + in Color r g b a diff --git a/src/SFML/Graphics/ConvexShape.hs b/src/SFML/Graphics/ConvexShape.hs --- a/src/SFML/Graphics/ConvexShape.hs +++ b/src/SFML/Graphics/ConvexShape.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} module SFML.Graphics.ConvexShape ( module SFML.Utils -, ConvexShapeException(..) , createConvexShape , copy , destroy @@ -46,16 +44,15 @@ import SFML.Graphics.SFShapeResizable import SFML.Graphics.SFTexturable import SFML.Graphics.Transform -import SFML.Graphics.Transformable +import SFML.Graphics.SFTransformable import SFML.Graphics.Types import SFML.SFCopyable +import SFML.SFException import SFML.SFResource import SFML.System.Vector2 import SFML.Utils -import Control.Exception import Control.Monad ((>=>)) -import Data.Typeable import Foreign.C.Types import Foreign.Ptr (Ptr, nullPtr) import Foreign.Marshal.Alloc (alloca) @@ -71,15 +68,10 @@ checkNullTexture tex@(Texture ptr) = if ptr == nullPtr then Nothing else Just tex -data ConvexShapeException = ConvexShapeException String deriving (Show, Typeable) - -instance Exception ConvexShapeException - - -- | Create a new convex shape. -createConvexShape :: IO (Either ConvexShapeException ConvexShape) +createConvexShape :: IO (Either SFException ConvexShape) createConvexShape = - let err = ConvexShapeException "Failed creating convex shape" + let err = SFException "Failed creating convex shape" in fmap (tagErr err . checkNull) sfConvexShape_create foreign import ccall unsafe "sfConvexShape_create" @@ -113,7 +105,7 @@ --CSFML_GRAPHICS_API void sfConvexShape_destroy(sfConvexShape* shape); -instance Transformable ConvexShape where +instance SFTransformable ConvexShape where {-# INLINABLE setPosition #-} setPosition c p = with p $ sfConvexShape_setPosition_helper c diff --git a/src/SFML/Graphics/Font.hs b/src/SFML/Graphics/Font.hs --- a/src/SFML/Graphics/Font.hs +++ b/src/SFML/Graphics/Font.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} module SFML.Graphics.Font ( module SFML.Utils -, FontException(..) , fontFromFile , fontFromMemory , fontFromStream @@ -11,20 +9,23 @@ , getGlyph , getKerning , getLineSpacing +, getUnderlinePosition +, getUnderlineThickness , getFontTexture +, getInfo ) where +import SFML.Graphics.FontInfo import SFML.Graphics.Glyph import SFML.Graphics.Types import SFML.SFCopyable +import SFML.SFException import SFML.SFResource import SFML.System.InputStream import SFML.Utils -import Control.Exception -import Data.Typeable import Data.Word import Foreign.C.String import Foreign.C.Types @@ -38,15 +39,10 @@ checkNull font@(Font ptr) = if ptr == nullPtr then Nothing else Just font -data FontException = FontException String deriving (Show, Typeable) - -instance Exception FontException - - -- | Create a new font from a file. -fontFromFile :: FilePath -> IO (Either FontException Font) +fontFromFile :: FilePath -> IO (Either SFException Font) fontFromFile path = - let err = FontException $ "Failed loading font from file " ++ show path + let err = SFException $ "Failed loading font from file " ++ show path in fmap (tagErr err . checkNull) $ withCAString path sfFont_createFromFile foreign import ccall unsafe "sfFont_createFromFile" @@ -61,10 +57,10 @@ fontFromMemory :: Ptr Char -- ^ Pointer to the file data in memory -> Int -- ^ Size of the data to load, in bytes - -> IO (Either FontException Font) + -> IO (Either SFException Font) fontFromMemory pixels size = - let err = FontException $ "Failed loading font from memory address " ++ show pixels + let err = SFException $ "Failed loading font from memory address " ++ show pixels in fmap (tagErr err . checkNull) $ sfFont_createFromMemory pixels (fromIntegral size) foreign import ccall unsafe "sfFont_createFromMemory" @@ -76,9 +72,9 @@ -- | Create a new image font a custom stream. -fontFromStream :: InputStream -> IO (Either FontException Font) +fontFromStream :: InputStream -> IO (Either SFException Font) fontFromStream stream = - let err = FontException $ "Failed loading font from stream " ++ show stream + let err = SFException $ "Failed loading font from stream " ++ show stream in fmap (tagErr err . checkNull) $ with stream sfFont_createFromStream foreign import ccall "sfFont_createFromStream" @@ -90,7 +86,7 @@ instance SFCopyable Font where - + {-# INLINABLE copy #-} copy = sfFont_copy @@ -102,7 +98,7 @@ instance SFResource Font where - + {-# INLINABLE destroy #-} destroy = sfFont_destroy @@ -138,13 +134,13 @@ -> Int -- ^ Unicode code point of the first character -> Int -- ^ Unicode code point of the second characte.r -> Int -- ^ Character size, in pixels - -> IO Int + -> IO Float getKerning font first second size = - fmap fromIntegral $ sfFont_getKerning font (fromIntegral first) (fromIntegral second) (fromIntegral size) + fmap realToFrac $ sfFont_getKerning font (fromIntegral first) (fromIntegral second) (fromIntegral size) foreign import ccall unsafe "sfFont_getKerning" - sfFont_getKerning :: Font -> Word32 -> Word32 -> CUInt -> IO CInt + sfFont_getKerning :: Font -> Word32 -> Word32 -> CUInt -> IO CFloat --CSFML_GRAPHICS_API int sfFont_getKerning(sfFont* font, sfUint32 first, sfUint32 second, unsigned int characterSize); @@ -152,17 +148,52 @@ -- | Get the line spacing value. getLineSpacing :: Font -- ^ Source font - -> Int -- ^ Character size, in pixels - -> IO Int + -> Int -- ^ Character size, in pixels + -> IO Float -getLineSpacing font size = fmap fromIntegral $ sfFont_getLineSpacing font (fromIntegral size) +getLineSpacing font size = fmap realToFrac $ sfFont_getLineSpacing font (fromIntegral size) foreign import ccall unsafe "sfFont_getLineSpacing" - sfFont_getLineSpacing :: Font -> CUInt -> IO CInt + sfFont_getLineSpacing :: Font -> CUInt -> IO CFloat --CSFML_GRAPHICS_API int sfFont_getLineSpacing(sfFont* font, unsigned int characterSize); +-- | Get the position of the underline. +-- +-- Underline position is the vertical offset to apply between the +-- baseline and the underline. +getUnderlinePosition + :: Font -- ^ Source font + -> Int -- ^ Reference character size + -> IO Float + +getUnderlinePosition font size + = fmap realToFrac $ sfFont_getUnderlinePosition font (fromIntegral size) + +foreign import ccall unsafe "sfFont_getUnderlinePosition" + sfFont_getUnderlinePosition :: Font -> CUInt -> IO CFloat + +--CSFML_GRAPHICS_API float sfFont_getUnderlinePosition(sfFont* font, unsigned int characterSize); + + +-- | Get the thickness of the underline. +-- +-- Underline thickness is the vertical size of the underline. +getUnderlineThickness + :: Font -- ^ Source font + -> Int -- ^ Reference character size + -> IO Float + +getUnderlineThickness font size + = fmap realToFrac $ sfFont_getUnderlineThickness font (fromIntegral size) + +foreign import ccall unsafe "sfFont_getUnderlineThickness" + sfFont_getUnderlineThickness :: Font -> CUInt -> IO CFloat + +--CSFML_GRAPHICS_API float sfFont_getUnderlineThickness(sfFont* font, unsigned int characterSize); + + -- | Get the texture containing the glyphs of a given size in a font. getFontTexture :: Font -- ^ Source font @@ -176,3 +207,16 @@ --CSFML_GRAPHICS_API const sfTexture* sfFont_getTexture(sfFont* font, unsigned int characterSize); + +-- | Get the font information. +-- +-- The returned structure will remain valid only if the font +-- is still valid. If the font is invalid an invalid structure +-- is returned. +getInfo :: Font -> IO FontInfo +getInfo font = alloca $ \ptr -> sfFont_getInfo_helper font ptr >> peek ptr + +foreign import ccall unsafe "sfFont_getInfo_helper" + sfFont_getInfo_helper :: Font -> Ptr FontInfo -> IO () + +--CSFML_GRAPHICS_API sfFontInfo sfFont_getInfo(const sfFont* font); diff --git a/src/SFML/Graphics/FontInfo.hsc b/src/SFML/Graphics/FontInfo.hsc new file mode 100644 --- /dev/null +++ b/src/SFML/Graphics/FontInfo.hsc @@ -0,0 +1,30 @@ +module SFML.Graphics.FontInfo +( + FontInfo(..) +) +where + +import Control.Applicative ((<$>), (<*>)) +import Foreign.C.String +import Foreign.Ptr +import Foreign.Storable + +#include + + +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t(y__); }, y__) + + +data FontInfo + = FontInfo + { family :: String + } deriving (Show) + + +instance Storable FontInfo where + sizeOf _ = #{size sfFontInfo} + alignment _ = #{alignment sfFontInfo} + + peek ptr = FontInfo <$> peekCString (castPtr ptr) + + poke ptr fontInfo = withCString (family fontInfo) $ \cstring -> poke (castPtr ptr) cstring diff --git a/src/SFML/Graphics/Glyph.hsc b/src/SFML/Graphics/Glyph.hsc --- a/src/SFML/Graphics/Glyph.hsc +++ b/src/SFML/Graphics/Glyph.hsc @@ -8,6 +8,7 @@ import SFML.Graphics.Rect +import Control.Applicative ((<$>), (<*>)) import Foreign.C.Types import Foreign.Storable @@ -29,13 +30,12 @@ instance Storable Glyph where sizeOf _ = sizeInt + 2*sizeIntRect alignment _ = alignment (undefined :: IntRect) - - peek ptr = do - advance <- #{peek sfGlyph, advance} ptr :: IO CInt - bounds <- #{peek sfGlyph, bounds} ptr - rect <- #{peek sfGlyph, textureRect} ptr - return $ Glyph (fromIntegral advance) bounds rect - + + peek ptr = Glyph + <$> fmap fromIntegral (#{peek sfGlyph, advance} ptr :: IO CInt) + <*> #{peek sfGlyph, bounds} ptr + <*> #{peek sfGlyph, textureRect} ptr + poke ptr (Glyph advance bounds rect) = do #{poke sfGlyph, advance} ptr (fromIntegral advance :: CInt) #{poke sfGlyph, bounds} ptr bounds diff --git a/src/SFML/Graphics/Image.hs b/src/SFML/Graphics/Image.hs --- a/src/SFML/Graphics/Image.hs +++ b/src/SFML/Graphics/Image.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} module SFML.Graphics.Image ( module SFML.Utils -, ImageException(..) , createImage , imageFromColor , imageFromPixels @@ -28,13 +26,12 @@ import SFML.Graphics.Rect import SFML.Graphics.Types import SFML.SFCopyable +import SFML.SFException import SFML.SFResource import SFML.System.InputStream import SFML.System.Vector2 import SFML.Utils -import Control.Exception -import Data.Typeable import Data.Word (Word8) import Foreign.Ptr import Foreign.C.String @@ -48,21 +45,16 @@ checkNull img@(Image ptr) = if ptr == nullPtr then Nothing else Just img -data ImageException = ImageException String deriving (Show, Typeable) - -instance Exception ImageException - - -- | Create an image. -- -- This image is filled with black pixels. createImage :: Int -- ^ Width of the image -> Int -- ^ Height of the image - -> IO (Either ImageException Image) + -> IO (Either SFException Image) createImage w h = - let err = ImageException "Failed creating image" + let err = SFException "Failed creating image" in fmap (tagErr err . checkNull) $ sfImage_create (fromIntegral w) (fromIntegral h) foreign import ccall unsafe "sfImage_create" diff --git a/src/SFML/Graphics/Rect.hsc b/src/SFML/Graphics/Rect.hsc --- a/src/SFML/Graphics/Rect.hsc +++ b/src/SFML/Graphics/Rect.hsc @@ -10,6 +10,7 @@ where +import Control.Applicative ((<$>), (<*>)) import Foreign.C.Types import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Utils (with) @@ -36,14 +37,13 @@ instance Storable FloatRect where sizeOf _ = 4 * sizeFloat alignment _ = alignment (undefined :: CFloat) - - peek ptr = do - l <- fmap realToFrac (#{peek sfFloatRect, left} ptr :: IO CFloat) - t <- fmap realToFrac (#{peek sfFloatRect, top} ptr :: IO CFloat) - w <- fmap realToFrac (#{peek sfFloatRect, width} ptr :: IO CFloat) - h <- fmap realToFrac (#{peek sfFloatRect, height} ptr :: IO CFloat) - return $ FloatRect l t w h - + + peek ptr = FloatRect + <$> fmap realToFrac (#{peek sfFloatRect, left} ptr :: IO CFloat) + <*> fmap realToFrac (#{peek sfFloatRect, top} ptr :: IO CFloat) + <*> fmap realToFrac (#{peek sfFloatRect, width} ptr :: IO CFloat) + <*> fmap realToFrac (#{peek sfFloatRect, height} ptr :: IO CFloat) + poke ptr (FloatRect l t w h) = do #{poke sfFloatRect, left} ptr (realToFrac l :: CFloat) #{poke sfFloatRect, top} ptr (realToFrac t :: CFloat) @@ -63,14 +63,13 @@ instance Storable IntRect where sizeOf _ = 4 * sizeInt alignment _ = alignment (undefined :: CInt) - - peek ptr = do - l <- #{peek sfIntRect, left} ptr :: IO CInt - t <- #{peek sfIntRect, top} ptr :: IO CInt - w <- #{peek sfIntRect, width} ptr :: IO CInt - h <- #{peek sfIntRect, height} ptr :: IO CInt - return $ IntRect (fromIntegral l) (fromIntegral t) (fromIntegral w) (fromIntegral h) - + + peek ptr = IntRect + <$> fmap fromIntegral (#{peek sfIntRect, left} ptr :: IO CInt) + <*> fmap fromIntegral (#{peek sfIntRect, top} ptr :: IO CInt) + <*> fmap fromIntegral (#{peek sfIntRect, width} ptr :: IO CInt) + <*> fmap fromIntegral (#{peek sfIntRect, height} ptr :: IO CInt) + poke ptr (IntRect l t w h) = do #{poke sfIntRect, left} ptr (fromIntegral l :: CInt) #{poke sfIntRect, top} ptr (fromIntegral t :: CInt) @@ -118,7 +117,7 @@ instance Rect FloatRect where - + intersectRect r1 r2 = unsafeDupablePerformIO $ alloca $ \ptr1 -> alloca $ \ptr2 -> @@ -138,7 +137,7 @@ instance Rect IntRect where - + intersectRect r1 r2 = unsafeDupablePerformIO $ alloca $ \ptr1 -> alloca $ \ptr2 -> diff --git a/src/SFML/Graphics/RectangleShape.hs b/src/SFML/Graphics/RectangleShape.hs --- a/src/SFML/Graphics/RectangleShape.hs +++ b/src/SFML/Graphics/RectangleShape.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} module SFML.Graphics.RectangleShape ( module SFML.Utils -, RectangleShapeException(..) , createRectangleShape , copy , destroy @@ -47,16 +45,15 @@ import SFML.Graphics.SFShapeResizable import SFML.Graphics.SFTexturable import SFML.Graphics.Transform -import SFML.Graphics.Transformable +import SFML.Graphics.SFTransformable import SFML.Graphics.Types import SFML.SFCopyable +import SFML.SFException import SFML.SFResource import SFML.System.Vector2 import SFML.Utils -import Control.Exception import Control.Monad ((>=>)) -import Data.Typeable import Foreign.C.Types import Foreign.Ptr (Ptr, nullPtr) import Foreign.Marshal.Alloc (alloca) @@ -72,15 +69,10 @@ checkNullTexture tex@(Texture ptr) = if ptr == nullPtr then Nothing else Just tex -data RectangleShapeException = RectangleShapeException String deriving (Show, Typeable) - -instance Exception RectangleShapeException - - -- | Create a new rectangle shape. -createRectangleShape :: IO (Either RectangleShapeException RectangleShape) +createRectangleShape :: IO (Either SFException RectangleShape) createRectangleShape = - let err = RectangleShapeException "Failed creating rectangle shape" + let err = SFException "Failed creating rectangle shape" in fmap (tagErr err . checkNull) sfRectangleShape_create foreign import ccall unsafe "sfRectangleShape_create" @@ -113,7 +105,7 @@ --CSFML_GRAPHICS_API void sfRectangleShape_destroy(sfRectangleShape* shape); -instance Transformable RectangleShape where +instance SFTransformable RectangleShape where {-# INLINABLE setPosition #-} setPosition c p = with p $ sfRectangleShape_setPosition_helper c diff --git a/src/SFML/Graphics/RenderStates.hsc b/src/SFML/Graphics/RenderStates.hsc --- a/src/SFML/Graphics/RenderStates.hsc +++ b/src/SFML/Graphics/RenderStates.hsc @@ -11,13 +11,17 @@ import SFML.Graphics.Transform import SFML.Graphics.Types -import Foreign.C.Types (CFloat) +import Control.Applicative ((<$>), (<*>)) +import Foreign.C.Types (CIntPtr) import Foreign.Ptr (nullPtr) import Foreign.Storable #include +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t(y__); }, y__) + + -- | Define the states used for drawing to a RenderTarget. data RenderStates = RenderStates { blendMode :: BlendMode @@ -28,15 +32,14 @@ instance Storable RenderStates where - sizeOf _ = size_sfRenderStates - alignment _ = alignment (undefined :: CFloat) + sizeOf _ = #{size sfRenderStates} + alignment _ = #{alignment sfRenderStates} - peek ptr = do - bm <- #{peek sfRenderStates, blendMode} ptr - tr <- #{peek sfRenderStates, transform} ptr - tx <- #{peek sfRenderStates, texture} ptr - sh <- #{peek sfRenderStates, shader} ptr - return $ RenderStates bm tr tx sh + peek ptr = RenderStates + <$> #{peek sfRenderStates, blendMode} ptr + <*> #{peek sfRenderStates, transform} ptr + <*> #{peek sfRenderStates, texture} ptr + <*> #{peek sfRenderStates, shader} ptr poke ptr (RenderStates bm tr tx sh) = do #{poke sfRenderStates, blendMode} ptr bm @@ -44,20 +47,17 @@ #{poke sfRenderStates, texture} ptr tx #{poke sfRenderStates, shader} ptr sh - -size_sfRenderStates = #{size sfRenderStates} - -- | Default render states, defined as -- -- @ --- renderStates = RenderStates 'BlendAlpha' 'idTransform' (Texture 'nullPtr') (Shader 'nullPtr') +-- renderStates = RenderStates 'blendAlpha' 'idTransform' (Texture 'nullPtr') (Shader 'nullPtr') -- @ -- -- This constant tries to mimic the C++ RenderStates default constructor to ease -- the construction of render states. For example, instead of typing -- -- @ --- states = RenderStates BlendAlpha idTransform tex (Shader nullptr) +-- states = RenderStates blendAlpha idTransform tex (Shader nullptr) -- @ -- -- Now we can simply type @@ -65,7 +65,7 @@ -- @ -- states = renderStates { texture = tex } -- @ -renderStates = RenderStates BlendAlpha idTransform (Texture nullPtr) (Shader nullPtr) +renderStates = RenderStates blendAlpha idTransform (Texture nullPtr) (Shader nullPtr) {-typedef struct { diff --git a/src/SFML/Graphics/RenderTexture.hs b/src/SFML/Graphics/RenderTexture.hs --- a/src/SFML/Graphics/RenderTexture.hs +++ b/src/SFML/Graphics/RenderTexture.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} module SFML.Graphics.RenderTexture ( module SFML.Utils -, RenderTextureException(..) , createRenderTexture , destroy , getTextureSize @@ -45,12 +43,11 @@ import SFML.Graphics.SFSmoothTexture import SFML.Graphics.Vertex import SFML.SFDisplayable +import SFML.SFException import SFML.SFResource import SFML.System.Vector2 import SFML.Utils -import Control.Exception -import Data.Typeable import Foreign.C.Types import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Array (withArray) @@ -63,20 +60,15 @@ checkNull tex@(RenderTexture ptr) = if ptr == nullPtr then Nothing else Just tex -data RenderTextureException = RenderTextureException String deriving (Show, Typeable) - -instance Exception RenderTextureException - - -- | Construct a new render texture. createRenderTexture :: Int -- ^ Width of the render texture -> Int -- ^ Height of the render texture -> Bool -- ^ Do you want a depth-buffer attached? (useful only if you're doing 3D OpenGL on the render texture) - -> IO (Either RenderTextureException RenderTexture) + -> IO (Either SFException RenderTexture) createRenderTexture w h d = - let err = RenderTextureException "Failed creating render texture" + let err = SFException "Failed creating render texture" in fmap (tagErr err . checkNull) $ sfRenderTexture_create (fromIntegral w) (fromIntegral h) (fromIntegral . fromEnum $ d) foreign import ccall unsafe "sfRenderTexture_create" diff --git a/src/SFML/Graphics/RenderWindow.hs b/src/SFML/Graphics/RenderWindow.hs --- a/src/SFML/Graphics/RenderWindow.hs +++ b/src/SFML/Graphics/RenderWindow.hs @@ -20,6 +20,8 @@ , setVSync , setKeyRepeat , setWindowActive +, requestFocus +, hasFocus , display , setFramerateLimit , setJoystickThreshold @@ -68,6 +70,7 @@ import SFML.SFResource import SFML.System.Vector2 +import Control.Applicative ((<$>), (<*>)) import Data.Bits ((.|.)) import Data.List (foldl') import Foreign.C.String @@ -117,7 +120,7 @@ instance SFResource RenderWindow where - + {-# INLINABLE destroy #-} destroy = sfRenderWindow_destroy @@ -128,22 +131,22 @@ instance SFDisplayable RenderWindow where - + {-# INLINABLE display #-} display = sfRenderWindow_display instance SFWindow RenderWindow where - - {-# INLINABLE close #-} + + {-# INLINABLE close #-} close = sfRenderWindow_close - + {-# INLINABLE isWindowOpen #-} isWindowOpen = fmap (/=0) . sfRenderWindow_isOpen - + {-# INLINABLE getWindowSettings #-} getWindowSettings wnd = alloca $ \ptr -> sfRenderWindow_getSettings_helper wnd ptr >> peek ptr - + {-# INLINABLE pollEvent #-} pollEvent wnd = alloca $ \ptr -> do @@ -151,7 +154,7 @@ case result of 0 -> return Nothing _ -> peek ptr >>= return . Just - + {-# INLINABLE waitEvent #-} waitEvent wnd = alloca $ \ptr -> do @@ -159,62 +162,68 @@ case result of 0 -> return Nothing _ -> peek ptr >>= return . Just - + {-# INLINABLE getWindowPosition #-} getWindowPosition wnd = alloca $ \ptr -> sfRenderWindow_getPosition_helper wnd ptr >> peek ptr - + {-# INLINABLE setWindowPosition #-} setWindowPosition wnd pos = with pos $ sfRenderWindow_setPosition_helper wnd - + {-# INLINABLE getWindowSize #-} getWindowSize wnd = alloca $ \ptr -> sfRenderWindow_getSize_helper wnd ptr >> peek ptr - + {-# INLINABLE setWindowSize #-} setWindowSize wnd size = with size $ sfRenderWindow_setSize_helper wnd - + {-# INLINABLE setWindowTitle #-} setWindowTitle wnd title = withCAString title $ sfRenderWindow_setTitle wnd - + {-# INLINABLE setWindowIcon #-} setWindowIcon wnd w h pixels = sfRenderWindow_setIcon wnd (fromIntegral w) (fromIntegral h) pixels - + {-# INLINABLE setWindowVisible #-} setWindowVisible wnd val = sfRenderWindow_setVisible wnd (fromIntegral . fromEnum $ val) - + {-# INLINABLE setMouseVisible #-} setMouseVisible wnd val = sfRenderWindow_setMouseCursorVisible wnd (fromIntegral . fromEnum $ val) - + {-# INLINABLE setVSync #-} setVSync wnd val = sfRenderWindow_setVerticalSyncEnabled wnd (fromIntegral . fromEnum $ val) - + {-# INLINABLE setKeyRepeat #-} setKeyRepeat wnd val = sfRenderWindow_setKeyRepeatEnabled wnd (fromIntegral . fromEnum $ val) - + {-# INLINABLE setWindowActive #-} setWindowActive wnd val = fmap (toEnum . fromIntegral) $ sfRenderWindow_setActive wnd (fromIntegral . fromEnum $ val) - + + {-# INLINABLE requestFocus #-} + requestFocus wnd = sfRenderWindow_requestFocus wnd + + {-# INLINABLE hasFocus #-} + hasFocus wnd = ((/=0) . fromIntegral) <$> sfRenderWindow_hasFocus wnd + {-# INLINABLE setFramerateLimit #-} setFramerateLimit wnd fps = sfRenderWindow_setFramerateLimit wnd (fromIntegral fps) - + {-# INLINABLE setJoystickThreshold #-} setJoystickThreshold w t = sfRenderWindow_setJoystickThreshold w (realToFrac t) - + {-# INLINABLE getSystemHandle #-} getSystemHandle = sfRenderWindow_getSystemHandle - + {-# INLINABLE getMousePosition #-} getMousePosition Nothing = alloca $ \ptr -> sfMouse_getPositionRenderWindow_helper (RenderWindow nullPtr) ptr >> peek ptr - + getMousePosition (Just wnd) = alloca $ \ptr -> sfMouse_getPositionRenderWindow_helper wnd ptr >> peek ptr - + {-# INLINABLE setMousePosition #-} setMousePosition pos Nothing = with pos $ \ptr -> sfMouse_setPositionRenderWindow_helper ptr (RenderWindow nullPtr) - + setMousePosition pos (Just wnd) = with pos $ \ptr -> sfMouse_setPositionRenderWindow_helper ptr wnd @@ -310,8 +319,8 @@ sfRenderWindow_setKeyRepeatEnabled :: RenderWindow -> CInt -> IO () --CSFML_GRAPHICS_API void sfRenderWindow_setKeyRepeatEnabled(sfRenderWindow* renderWindow, sfBool enabled); - + foreign import ccall unsafe "sfRenderWindow_setActive" sfRenderWindow_setActive :: RenderWindow -> CInt -> IO CInt @@ -320,6 +329,18 @@ --CSFML_GRAPHICS_API sfBool sfRenderWindow_setActive(sfRenderWindow* renderWindow, sfBool active); +foreign import ccall unsafe "sfRenderWindow_requestFocus" + sfRenderWindow_requestFocus :: RenderWindow -> IO () + +--CSFML_GRAPHICS_API void sfRenderWindow_requestFocus(sfRenderWindow* renderWindow); + + +foreign import ccall unsafe "sfRenderWindow_hasFocus" + sfRenderWindow_hasFocus :: RenderWindow -> IO CInt + +--CSFML_GRAPHICS_API sfBool sfRenderWindow_hasFocus(const sfRenderWindow* renderWindow); + + foreign import ccall unsafe "sfRenderWindow_display" sfRenderWindow_display :: RenderWindow -> IO () @@ -330,8 +351,8 @@ sfRenderWindow_setFramerateLimit :: RenderWindow -> CInt -> IO () --CSFML_GRAPHICS_API void sfRenderWindow_setFramerateLimit(sfRenderWindow* renderWindow, unsigned int limit); - + foreign import ccall unsafe "sfRenderWindow_setJoystickThreshold" sfRenderWindow_setJoystickThreshold :: RenderWindow -> CFloat -> IO () @@ -371,16 +392,16 @@ instance SFViewable RenderWindow where - + {-# INLINABLE setView #-} setView = sfRenderWindow_setView {-# INLINABLE getView #-} getView = sfRenderWindow_getView - + {-# INLINABLE getDefaultView #-} getDefaultView = sfRenderWindow_getDefaultView - + {-# INLINABLE getViewport #-} getViewport wnd view = alloca $ \ptr -> sfRenderWindow_getViewport_helper wnd view ptr >> peek ptr @@ -407,7 +428,7 @@ instance SFCoordSpace RenderWindow where - + {-# INLINABLE mapPixelToCoords #-} mapPixelToCoords wnd p view = alloca $ \ptr -> @@ -424,58 +445,58 @@ instance SFRenderTarget RenderWindow where - + {-# INLINABLE drawSprite #-} drawSprite wnd sprite Nothing = sfRenderWindow_drawSprite wnd sprite nullPtr drawSprite wnd sprite (Just rs) = with rs $ sfRenderWindow_drawSprite wnd sprite - + {-# INLINABLE drawText #-} drawText wnd text Nothing = sfRenderWindow_drawText wnd text nullPtr drawText wnd text (Just rs) = with rs $ sfRenderWindow_drawText wnd text - + {-# INLINABLE drawShape #-} drawShape wnd shape Nothing = sfRenderWindow_drawShape wnd shape nullPtr drawShape wnd shape (Just rs) = with rs $ sfRenderWindow_drawShape wnd shape - + {-# INLINABLE drawCircle #-} drawCircle wnd circle Nothing = sfRenderWindow_drawCircleShape wnd circle nullPtr drawCircle wnd circle (Just rs) = with rs $ sfRenderWindow_drawCircleShape wnd circle - + {-# INLINABLE drawConvexShape #-} drawConvexShape wnd shape Nothing = sfRenderWindow_drawConvexShape wnd shape nullPtr drawConvexShape wnd shape (Just rs) = with rs $ sfRenderWindow_drawConvexShape wnd shape - + {-# INLINABLE drawRectangle #-} drawRectangle wnd rect Nothing = sfRenderWindow_drawRectangleShape wnd rect nullPtr drawRectangle wnd rect (Just rs) = with rs $ sfRenderWindow_drawRectangleShape wnd rect - + {-# INLINABLE drawVertexArray #-} drawVertexArray wnd va Nothing = sfRenderWindow_drawVertexArray wnd va nullPtr drawVertexArray wnd va (Just rs) = with rs $ sfRenderWindow_drawVertexArray wnd va - + {-# INLINABLE drawPrimitives #-} drawPrimitives wnd verts prim Nothing = let n = length verts in withArray verts $ \ptr -> sfRenderWindow_drawPrimitives wnd ptr (fromIntegral n) (fromIntegral . fromEnum $ prim) nullPtr - + drawPrimitives wnd verts prim (Just r) = let n = length verts in withArray verts $ \ptr -> with r $ sfRenderWindow_drawPrimitives wnd ptr (fromIntegral n) (fromIntegral . fromEnum $ prim) - + drawPrimitives' wnd verts n prim Nothing = sfRenderWindow_drawPrimitives wnd verts (fromIntegral n) (fromIntegral . fromEnum $ prim) nullPtr - + drawPrimitives' wnd verts n prim (Just r) = with r $ sfRenderWindow_drawPrimitives wnd verts (fromIntegral n) (fromIntegral . fromEnum $ prim) - + {-# INLINABLE pushGLStates #-} pushGLStates = sfRenderWindow_pushGLStates - + {-# INLINABLE popGLStates #-} popGLStates = sfRenderWindow_popGLStates - + {-# INLINABLE resetGLStates #-} resetGLStates = sfRenderWindow_resetGLStates diff --git a/src/SFML/Graphics/SFDrawable.hs b/src/SFML/Graphics/SFDrawable.hs new file mode 100644 --- /dev/null +++ b/src/SFML/Graphics/SFDrawable.hs @@ -0,0 +1,31 @@ +module SFML.Graphics.SFDrawable where + +import SFML.Graphics.CircleShape +import SFML.Graphics.ConvexShape +import SFML.Graphics.RenderStates +import SFML.Graphics.Shape +import SFML.Graphics.SFRenderTarget +import SFML.Graphics.Text +import SFML.Graphics.Types +import SFML.Graphics.VertexArray + +class SFDrawable a where + draw :: SFRenderTarget t => t -> a -> Maybe RenderStates -> IO () + +instance SFDrawable Sprite where + draw = drawSprite + +instance SFDrawable Text where + draw = drawText + +instance SFDrawable Shape where + draw = drawShape + +instance SFDrawable CircleShape where + draw = drawCircle + +instance SFDrawable ConvexShape where + draw = drawConvexShape + +instance SFDrawable VertexArray where + draw = drawVertexArray diff --git a/src/SFML/Graphics/SFTransformable.hs b/src/SFML/Graphics/SFTransformable.hs new file mode 100644 --- /dev/null +++ b/src/SFML/Graphics/SFTransformable.hs @@ -0,0 +1,93 @@ +module SFML.Graphics.SFTransformable +where + + +import SFML.Graphics.Transform +import SFML.System.Vector2 + + +class SFTransformable a where + + -- | Set the position of a transformable. + -- + -- This function completely overwrites the previous position. + -- + -- See 'move' to apply an offset based on the previous position instead. + -- + -- The default position of a transformable object is (0, 0). + setPosition :: a -> Vec2f -> IO () + + -- | Set the orientation of a transformable. + -- + -- This function completely overwrites the previous rotation. + -- + -- See 'rotate' to add an angle based on the previous rotation instead. + -- + -- The default rotation of a transformable SFTransformable object is 0. + setRotation + :: a + -> Float -- ^ New rotation, in degrees + -> IO () + + -- | Set the scale factors of a transformable. + -- + -- This function completely overwrites the previous scale. + -- + -- See 'scale' to add a factor based on the previous scale instead. + -- + -- The default scale of a transformable SFTransformable object is (1, 1). + setScale :: a -> Vec2f -> IO () + + -- | Set the local origin of a transformable. + -- + -- The origin of an object defines the center point for + -- all transformations (position, scale, rotation). + -- + -- The coordinates of this point must be relative to the + -- top-left corner of the object, and ignore all + -- transformations (position, scale, rotation). + -- + -- The default origin of a transformable SFTransformable object is (0, 0). + setOrigin :: a -> Vec2f -> IO () + + -- | Get the position of a transformable. + getPosition :: a -> IO Vec2f + + -- | Get the orientation of a transformable. + getRotation + :: a + -> IO Float -- ^ Current rotation, in degrees + + -- | Get the current scale of a transformable + getScale :: a -> IO Vec2f + + -- | Get the local origin of a transformable. + getOrigin :: a -> IO Vec2f + + -- | Move a transformable by a given offset + -- + -- This function adds to the current position of the object, + -- unlike 'setPosition' which overwrites it. + move :: a -> Vec2f -> IO () + + -- | Rotate a transformable. + -- + -- This function adds to the current rotation of the object, + -- unlike 'setRotation' which overwrites it. + rotate + :: a + -> Float -- ^ Angle of rotation, in degrees + -> IO () + + -- | Scale a transformable. + -- + -- This function multiplies the current scale of the object, + -- unlike 'setScale' which overwrites it. + scale :: a -> Vec2f -> IO () + + -- | Get the combined transform of a transformable. + getTransform :: a -> IO Transform + + -- | Get the inverse of the combined transform of a transformable. + getInverseTransform :: a -> IO Transform + diff --git a/src/SFML/Graphics/Shader.hs b/src/SFML/Graphics/Shader.hs --- a/src/SFML/Graphics/Shader.hs +++ b/src/SFML/Graphics/Shader.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} module SFML.Graphics.Shader ( module SFML.Utils -, ShaderException(..) , nullShader , shaderFromFile , shaderFromMemory @@ -28,14 +26,13 @@ import SFML.Graphics.Transform import SFML.Graphics.Types import SFML.Graphics.SFBindable +import SFML.SFException import SFML.SFResource import SFML.System.InputStream import SFML.System.Vector2 import SFML.System.Vector3 import SFML.Utils -import Control.Exception -import Data.Typeable import Foreign.C.Types import Foreign.C.String import Foreign.Marshal.Utils (with) @@ -46,19 +43,14 @@ checkNull shader@(Shader ptr) = if ptr == nullPtr then Nothing else Just shader -data ShaderException = ShaderException String deriving (Show, Typeable) - -instance Exception ShaderException - - -exf :: Show a => Maybe a -> Maybe a -> ShaderException -exf vs fs = ShaderException $ "Failed loading shader program from files " ++ show vs ++ ", " ++ show fs +exf :: Show a => Maybe a -> Maybe a -> SFException +exf vs fs = SFException $ "Failed loading shader program from files " ++ show vs ++ ", " ++ show fs -exs :: Show a => Maybe a -> Maybe a -> ShaderException -exs vs fs = ShaderException $ "Failed loading shader program from sources " ++ show vs ++ ", " ++ show fs +exs :: Show a => Maybe a -> Maybe a -> SFException +exs vs fs = SFException $ "Failed loading shader program from sources " ++ show vs ++ ", " ++ show fs -exi :: Show a => Maybe a -> Maybe a -> ShaderException -exi vs fs = ShaderException $ "Failed loading shader program from input streams " ++ show vs ++ ", " ++ show fs +exi :: Show a => Maybe a -> Maybe a -> SFException +exi vs fs = SFException $ "Failed loading shader program from input streams " ++ show vs ++ ", " ++ show fs nullstr = Nothing :: Maybe String nullis = Nothing :: Maybe InputStream @@ -81,7 +73,7 @@ shaderFromFile :: Maybe FilePath -- ^ Path of the vertex shader file to load, or 'Nothing' to skip this shader -> Maybe FilePath -- ^ Path of the fragment shader file to load, or 'Nothing' to skip this shader - -> IO (Either ShaderException Shader) + -> IO (Either SFException Shader) shaderFromFile Nothing Nothing = fmap (tagErr (exf nullstr nullstr) . checkNull) $ sfShader_createFromFile nullPtr nullPtr @@ -115,7 +107,7 @@ shaderFromMemory :: Maybe String -- ^ String containing the source code of the vertex shader, or 'Nothing' to skip this shader -> Maybe String -- ^ String containing the source code of the fragment shader, or 'Nothing' to skip this shader - -> IO (Either ShaderException Shader) + -> IO (Either SFException Shader) shaderFromMemory Nothing Nothing = fmap (tagErr (exs nullstr nullstr) . checkNull) $ sfShader_createFromMemory nullPtr nullPtr @@ -150,7 +142,7 @@ shaderFromStream :: Maybe InputStream -- ^ Source stream to read the vertex shader from, or 'Nothing' to skip this shader -> Maybe InputStream -- ^ Source stream to read the fragment shader from, or 'Nothing' to skip this shader - -> IO (Either ShaderException Shader) + -> IO (Either SFException Shader) shaderFromStream Nothing Nothing = fmap (tagErr (exi nullis nullis) . checkNull) $ sfShader_createFromStream nullPtr nullPtr diff --git a/src/SFML/Graphics/Shape.hs b/src/SFML/Graphics/Shape.hs --- a/src/SFML/Graphics/Shape.hs +++ b/src/SFML/Graphics/Shape.hs @@ -42,7 +42,7 @@ import SFML.Graphics.SFShapeResizable import SFML.Graphics.SFTexturable import SFML.Graphics.Transform -import SFML.Graphics.Transformable +import SFML.Graphics.SFTransformable import SFML.Graphics.Types import SFML.SFResource import SFML.System.Vector2 @@ -85,7 +85,7 @@ --CSFML_GRAPHICS_API void sfShape_destroy(sfShape* shape); -instance Transformable Shape where +instance SFTransformable Shape where {-# INLINABLE setPosition #-} setPosition c p = with p $ sfShape_setPosition_helper c diff --git a/src/SFML/Graphics/Sprite.hs b/src/SFML/Graphics/Sprite.hs --- a/src/SFML/Graphics/Sprite.hs +++ b/src/SFML/Graphics/Sprite.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} module SFML.Graphics.Sprite ( module SFML.Utils -, SpriteException(..) , createSprite , copy , destroy @@ -37,16 +35,15 @@ import SFML.Graphics.Rect import SFML.Graphics.SFTexturable import SFML.Graphics.Transform -import SFML.Graphics.Transformable +import SFML.Graphics.SFTransformable import SFML.Graphics.Types import SFML.SFCopyable +import SFML.SFException import SFML.SFResource import SFML.System.Vector2 import SFML.Utils -import Control.Exception import Control.Monad ((>=>)) -import Data.Typeable import Foreign.C.Types import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Utils (with) @@ -62,15 +59,10 @@ checkNullTexture tex@(Texture ptr) = if ptr == nullPtr then Nothing else Just tex -data SpriteException = SpriteException String deriving (Show, Typeable) - -instance Exception SpriteException - - -- | Create a new sprite. -createSprite :: IO (Either SpriteException Sprite) +createSprite :: IO (Either SFException Sprite) createSprite = - let err = SpriteException "Failed creating sprite" + let err = SFException "Failed creating sprite" in fmap (tagErr err . checkNull) sfSprite_create foreign import ccall unsafe "sfSprite_create" @@ -104,7 +96,7 @@ --CSFML_GRAPHICS_API void sfSprite_destroy(sfSprite* sprite); -instance Transformable Sprite where +instance SFTransformable Sprite where {-# INLINABLE setPosition #-} setPosition sprite pos = with pos $ sfSprite_setPosition_helper sprite diff --git a/src/SFML/Graphics/Text.hs b/src/SFML/Graphics/Text.hs --- a/src/SFML/Graphics/Text.hs +++ b/src/SFML/Graphics/Text.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} module SFML.Graphics.Text ( module SFML.Utils -, TextException(..) , TextStyle(..) , createText , copy @@ -29,21 +27,22 @@ import SFML.Graphics.Color import SFML.Graphics.Rect import SFML.Graphics.Transform -import SFML.Graphics.Transformable +import SFML.Graphics.SFTransformable import SFML.Graphics.Types import SFML.SFCopyable +import SFML.SFException import SFML.SFResource import SFML.System.Vector2 import SFML.Utils -import Control.Exception import Control.Monad -import Data.Typeable import Data.Bits ((.|.)) import Data.List (foldl') +import Data.Word import Foreign.C.String import Foreign.C.Types import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Array (peekArray0, withArray0) import Foreign.Marshal.Utils (with) import Foreign.Ptr import Foreign.Storable @@ -51,29 +50,27 @@ -- | Text styles. data TextStyle - = TextRegular -- ^ Regular characters, no style - | TextBold -- ^ Characters are bold - | TextItalic -- ^ Characters are in italic - | TextUnderlined -- ^ Characters are underlined + = TextRegular -- ^ Regular characters, no style + | TextBold -- ^ Characters are bold + | TextItalic -- ^ Characters are in italic + | TextUnderlined -- ^ Characters are underlined + | TextStrikeThrough -- ^ Strike through characters deriving (Eq, Bounded, Show) instance Enum TextStyle where - fromEnum TextRegular = 0 - fromEnum TextBold = 1 - fromEnum TextItalic = 2 - fromEnum TextUnderlined = 4 + fromEnum TextRegular = 0 + fromEnum TextBold = 1 + fromEnum TextItalic = 2 + fromEnum TextUnderlined = 4 + fromEnum TextStrikeThrough = 8 toEnum 0 = TextRegular toEnum 1 = TextBold toEnum 2 = TextItalic toEnum 4 = TextUnderlined - - -data TextException = TextException String deriving (Show, Typeable) - -instance Exception TextException + toEnum 8 = TextStrikeThrough checkNull :: Text -> Maybe Text @@ -85,9 +82,9 @@ -- | Create a new text. -createText :: IO (Either TextException Text) +createText :: IO (Either SFException Text) createText = - let err = TextException "Failed creating text" + let err = SFException "Failed creating text" in fmap (tagErr err . checkNull) sfText_create foreign import ccall unsafe "sfText_create" @@ -121,7 +118,7 @@ --CSFML_GRAPHICS_API void sfText_destroy(sfText* text); -instance Transformable Text where +instance SFTransformable Text where {-# INLINABLE setPosition #-} setPosition text pos = with pos $ sfText_setPosition_helper text @@ -243,12 +240,12 @@ -- | Set the string of a text (from a unicode string). setTextStringU :: Text -> String -> IO () - --- withCString is locale dependent. SFML expects UTF-32. Needs fix. -setTextStringU text str = withCString str $ sfText_setUnicodeString text +setTextStringU text str = withArray0 0 str' $ sfText_setUnicodeString text + where + str' = map (fromIntegral . fromEnum) str foreign import ccall unsafe "sfText_setUnicodeString" - sfText_setUnicodeString :: Text -> CString -> IO () + sfText_setUnicodeString :: Text -> Ptr Word32 -> IO () --CSFML_GRAPHICS_API void sfText_setUnicodeString(sfText* text, const sfUint32* string); @@ -326,11 +323,12 @@ -- | Get the string of a text as a UTF-32 string. getTextUnicodeString :: Text -> IO String --- Fix: peekCString is locale-dependent. SFML will return a UTF-32 string. -getTextUnicodeString = sfText_getString >=> peekCString +getTextUnicodeString = liftM toString . peekArray0 0 <=< sfText_getUnicodeString + where + toString = map $ toEnum . fromIntegral foreign import ccall unsafe "sfText_getUnicodeString" - sfText_getUnicodeString :: Text -> IO CString + sfText_getUnicodeString :: Text -> IO (Ptr Word32) --CSFML_GRAPHICS_API const sfUint32* sfText_getUnicodeString(const sfText* text); diff --git a/src/SFML/Graphics/Texture.hs b/src/SFML/Graphics/Texture.hs --- a/src/SFML/Graphics/Texture.hs +++ b/src/SFML/Graphics/Texture.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} module SFML.Graphics.Texture ( module SFML.Utils -, TextureException(..) , nullTexture , createTexture , textureFromFile @@ -33,13 +31,12 @@ import SFML.Graphics.Types import SFML.Window.Types import SFML.SFCopyable +import SFML.SFException import SFML.SFResource import SFML.System.InputStream import SFML.System.Vector2 import SFML.Utils -import Control.Exception -import Data.Typeable import Foreign.C.String import Foreign.C.Types import Foreign.Marshal.Alloc (alloca) @@ -53,11 +50,6 @@ checkNull tex@(Texture ptr) = if ptr == nullPtr then Nothing else Just tex -data TextureException = TextureException String deriving (Show, Typeable) - -instance Exception TextureException - - -- | A null texture. nullTexture = Texture nullPtr @@ -66,10 +58,10 @@ createTexture :: Int -- ^ Texture width -> Int -- ^ Texture height - -> IO (Either TextureException Texture) + -> IO (Either SFException Texture) createTexture w h = - let err = TextureException "Failed creating texture" + let err = SFException "Failed creating texture" in fmap (tagErr err . checkNull) $ sfTexture_create (fromIntegral w) (fromIntegral h) foreign import ccall unsafe "sfTexture_create" @@ -84,10 +76,10 @@ textureFromFile :: FilePath -- ^ Path of the image file to load -> Maybe IntRect -- ^ Area of the source image to load ('Nothing' to load the entire image) - -> IO (Either TextureException Texture) + -> IO (Either SFException Texture) textureFromFile path rect = - let err = TextureException $ "Failed loading texture from file " ++ show path + let err = SFException $ "Failed loading texture from file " ++ show path in withCAString path $ \cpath -> fmap (tagErr err . checkNull) $ case rect of @@ -107,10 +99,10 @@ :: Ptr a -- ^ Pointer to the file data in memory -> Int -- ^ Size of the data to load, in bytes -> Maybe IntRect -- ^ Area of the source image to load ('Nothing' to load the entire image) - -> IO (Either TextureException Texture) + -> IO (Either SFException Texture) textureFromMemory pixels size rect = - let err = TextureException $ "Failed creating texture from memory address " ++ show pixels + let err = SFException $ "Failed creating texture from memory address " ++ show pixels in fmap (tagErr err . checkNull) $ case rect of Nothing -> sfTexture_createFromMemory pixels (fromIntegral size) nullPtr Just r -> with r $ sfTexture_createFromMemory pixels (fromIntegral size) @@ -127,10 +119,10 @@ textureFromStream :: InputStream -- ^ Source stream to read from -> Maybe IntRect -- ^ Area of the source image to load ('Nothing' to load the entire image) - -> IO (Either TextureException Texture) + -> IO (Either SFException Texture) textureFromStream stream rect = - let err = TextureException $ "Failed creating texture from input stream " ++ show stream + let err = SFException $ "Failed creating texture from input stream " ++ show stream in fmap (tagErr err . checkNull) $ with stream $ \streamPtr -> case rect of @@ -149,11 +141,11 @@ textureFromImage :: Image -- ^ Image to upload to the texture -> Maybe IntRect -- ^ Area of the source image to load ('Nothing' to load the entire image) - -> IO (Either TextureException Texture) + -> IO (Either SFException Texture) textureFromImage image rect = let (Image addr) = image - err = TextureException $ "Failed creating texture from image " ++ show addr + err = SFException $ "Failed creating texture from image " ++ show addr in fmap (tagErr err . checkNull) $ case rect of Nothing -> sfTexture_createFromImage image nullPtr Just r -> with r $ sfTexture_createFromImage image diff --git a/src/SFML/Graphics/Transform.hsc b/src/SFML/Graphics/Transform.hsc --- a/src/SFML/Graphics/Transform.hsc +++ b/src/SFML/Graphics/Transform.hsc @@ -25,6 +25,7 @@ import SFML.Graphics.Types import SFML.System.Vector2 +import Control.Applicative ((<$>), (<*>)) import Data.List (foldl') import Foreign.C.Types import Foreign.Storable @@ -35,28 +36,27 @@ -- | Encapsulate a 3x3 transform matrix. data Transform = Transform - { m00 :: !Float, m10 :: !Float, m20 :: !Float - , m01 :: !Float, m11 :: !Float, m21 :: !Float - , m02 :: !Float, m12 :: !Float, m22 :: !Float + { m00 :: Float, m10 :: Float, m20 :: Float + , m01 :: Float, m11 :: Float, m21 :: Float + , m02 :: Float, m12 :: Float, m22 :: Float } instance Storable Transform where sizeOf _ = 9 * sizeFloat alignment _ = alignment (undefined :: CFloat) - - peek ptr = do - m00 <- fmap realToFrac $ (peekByteOff ptr 0 :: IO CFloat) - m01 <- fmap realToFrac $ (peekByteOff ptr sizeFloat :: IO CFloat) - m02 <- fmap realToFrac $ (peekByteOff ptr $ 2*sizeFloat :: IO CFloat) - m10 <- fmap realToFrac $ (peekByteOff ptr $ 3*sizeFloat :: IO CFloat) - m11 <- fmap realToFrac $ (peekByteOff ptr $ 4*sizeFloat :: IO CFloat) - m12 <- fmap realToFrac $ (peekByteOff ptr $ 5*sizeFloat :: IO CFloat) - m20 <- fmap realToFrac $ (peekByteOff ptr $ 6*sizeFloat :: IO CFloat) - m21 <- fmap realToFrac $ (peekByteOff ptr $ 7*sizeFloat :: IO CFloat) - m22 <- fmap realToFrac $ (peekByteOff ptr $ 8*sizeFloat :: IO CFloat) - return $ Transform m00 m01 m02 m10 m11 m12 m20 m21 m22 - + + peek ptr = Transform + <$> fmap realToFrac (peekByteOff ptr 0 :: IO CFloat) + <*> fmap realToFrac (peekByteOff ptr sizeFloat :: IO CFloat) + <*> fmap realToFrac (peekByteOff ptr $ 2*sizeFloat :: IO CFloat) + <*> fmap realToFrac (peekByteOff ptr $ 3*sizeFloat :: IO CFloat) + <*> fmap realToFrac (peekByteOff ptr $ 4*sizeFloat :: IO CFloat) + <*> fmap realToFrac (peekByteOff ptr $ 5*sizeFloat :: IO CFloat) + <*> fmap realToFrac (peekByteOff ptr $ 6*sizeFloat :: IO CFloat) + <*> fmap realToFrac (peekByteOff ptr $ 7*sizeFloat :: IO CFloat) + <*> fmap realToFrac (peekByteOff ptr $ 8*sizeFloat :: IO CFloat) + poke ptr (Transform m00 m01 m02 m10 m11 m12 m20 m21 m22) = do pokeByteOff ptr 0 (realToFrac m00 :: CFloat) pokeByteOff ptr sizeFloat (realToFrac m01 :: CFloat) @@ -75,35 +75,35 @@ = Transform (a00 + b00) (a01 + b01) (a02 + b02) (a03 + b03) (a04 + b04) (a05 + b05) (a06 + b06) (a07 + b07) (a08 + b08) - + (Transform a00 a01 a02 a03 a04 a05 a06 a07 a08) - (Transform b00 b01 b02 b03 b04 b05 b06 b07 b08) = Transform (a00 - b00) (a01 - b01) (a02 - b02) (a03 - b03) (a04 - b04) (a05 - b05) (a06 - b06) (a07 - b07) (a08 - b08) - + (Transform a00 a10 a20 a01 a11 a21 a02 a12 a22) * (Transform b00 b10 b20 b01 b11 b21 b02 b12 b22) = Transform (a00 * b00 + a10 * b01 + a20 * b02) (a00 * b10 + a10 * b11 + a20 * b12) (a00 * b20 + a10 * b21 + a20 * b22) - + (a01 * b00 + a11 * b01 + a21 * b02) (a01 * b10 + a11 * b11 + a21 * b12) (a01 * b20 + a11 * b21 + a21 * b22) - + (a02 * b00 + a12 * b01 + a22 * b02) (a02 * b10 + a12 * b11 + a22 * b12) (a02 * b20 + a12 * b21 + a22 * b22) - + abs (Transform a00 a01 a02 a03 a04 a05 a06 a07 a08) = (Transform (abs a00) (abs a01) (abs a02) (abs a03) (abs a04) (abs a05) (abs a06) (abs a07) (abs a08)) - + signum (Transform a00 a01 a02 a03 a04 a05 a06 a07 a08) = (Transform (signum a00) (signum a01) (signum a02) (signum a03) (signum a04) (signum a05) (signum a06) (signum a07) (signum a08)) - + fromInteger i = Transform i' i' i' i' i' i' i' i' i' where i' = fromInteger i @@ -288,12 +288,12 @@ p1@(Vec2f p1x p1y) = transformPoint transf (Vec2f l $ t + h) p2@(Vec2f p2x p2y) = transformPoint transf (Vec2f (l + w) t) p3@(Vec2f p3x p3y) = transformPoint transf (Vec2f (l + w) (t + h)) - + left = p0x; top = p0y; right = p0x; bottom = p0y; - + l' = min p3x $ min p2x $ min p1x p0x t' = min p3y $ min p2y $ min p1y p0y r' = max p3x $ max p2x $ max p1x p0x diff --git a/src/SFML/Graphics/Transformable.hs b/src/SFML/Graphics/Transformable.hs deleted file mode 100644 --- a/src/SFML/Graphics/Transformable.hs +++ /dev/null @@ -1,93 +0,0 @@ -module SFML.Graphics.Transformable -where - - -import SFML.Graphics.Transform -import SFML.System.Vector2 - - -class Transformable a where - - -- | Set the position of a transformable. - -- - -- This function completely overwrites the previous position. - -- - -- See 'move' to apply an offset based on the previous position instead. - -- - -- The default position of a transformable object is (0, 0). - setPosition :: a -> Vec2f -> IO () - - -- | Set the orientation of a transformable. - -- - -- This function completely overwrites the previous rotation. - -- - -- See 'rotate' to add an angle based on the previous rotation instead. - -- - -- The default rotation of a transformable Transformable object is 0. - setRotation - :: a - -> Float -- ^ New rotation, in degrees - -> IO () - - -- | Set the scale factors of a transformable. - -- - -- This function completely overwrites the previous scale. - -- - -- See 'scale' to add a factor based on the previous scale instead. - -- - -- The default scale of a transformable Transformable object is (1, 1). - setScale :: a -> Vec2f -> IO () - - -- | Set the local origin of a transformable. - -- - -- The origin of an object defines the center point for - -- all transformations (position, scale, rotation). - -- - -- The coordinates of this point must be relative to the - -- top-left corner of the object, and ignore all - -- transformations (position, scale, rotation). - -- - -- The default origin of a transformable Transformable object is (0, 0). - setOrigin :: a -> Vec2f -> IO () - - -- | Get the position of a transformable. - getPosition :: a -> IO Vec2f - - -- | Get the orientation of a transformable. - getRotation - :: a - -> IO Float -- ^ Current rotation, in degrees - - -- | Get the current scale of a transformable - getScale :: a -> IO Vec2f - - -- | Get the local origin of a transformable. - getOrigin :: a -> IO Vec2f - - -- | Move a transformable by a given offset - -- - -- This function adds to the current position of the object, - -- unlike 'setPosition' which overwrites it. - move :: a -> Vec2f -> IO () - - -- | Rotate a transformable. - -- - -- This function adds to the current rotation of the object, - -- unlike 'setRotation' which overwrites it. - rotate - :: a - -> Float -- ^ Angle of rotation, in degrees - -> IO () - - -- | Scale a transformable. - -- - -- This function multiplies the current scale of the object, - -- unlike 'setScale' which overwrites it. - scale :: a -> Vec2f -> IO () - - -- | Get the combined transform of a transformable. - getTransform :: a -> IO Transform - - -- | Get the inverse of the combined transform of a transformable. - getInverseTransform :: a -> IO Transform - diff --git a/src/SFML/Graphics/Types.hs b/src/SFML/Graphics/Types.hs --- a/src/SFML/Graphics/Types.hs +++ b/src/SFML/Graphics/Types.hs @@ -2,7 +2,7 @@ where -import Foreign.C.Types (CInt) +import Foreign.C.Types (CIntPtr) import Foreign.Ptr import Foreign.Storable @@ -24,16 +24,16 @@ instance Storable Texture where - sizeOf _ = sizeOf (undefined :: CInt) - alignment _ = alignment (undefined :: CInt) + sizeOf _ = sizeOf (undefined :: CIntPtr) + alignment _ = alignment (undefined :: CIntPtr) peek ptr = peek (castPtr ptr) >>= return . Texture poke ptr (Texture p) = poke (castPtr ptr) p instance Storable Shader where - sizeOf _ = sizeOf (undefined :: CInt) - alignment _ = alignment (undefined :: CInt) + sizeOf _ = sizeOf (undefined :: CIntPtr) + alignment _ = alignment (undefined :: CIntPtr) peek ptr = peek (castPtr ptr) >>= return . Shader poke ptr (Shader p) = poke (castPtr ptr) p diff --git a/src/SFML/Graphics/Vertex.hsc b/src/SFML/Graphics/Vertex.hsc --- a/src/SFML/Graphics/Vertex.hsc +++ b/src/SFML/Graphics/Vertex.hsc @@ -9,6 +9,7 @@ import SFML.Graphics.Color import SFML.System.Vector2 +import Control.Applicative ((<$>), (<*>)) import Foreign.C.Types (CFloat) import Foreign.Storable @@ -27,13 +28,12 @@ instance Storable Vertex where sizeOf _ = size_sfVertex alignment _ = alignment (undefined :: CFloat) - - peek ptr = do - pos <- #{peek sfVertex, position} ptr - col <- #{peek sfVertex, color} ptr - tex <- #{peek sfVertex, texCoords} ptr - return $ Vertex pos col tex - + + peek ptr = Vertex + <$> #{peek sfVertex, position} ptr + <*> #{peek sfVertex, color} ptr + <*> #{peek sfVertex, texCoords} ptr + poke ptr (Vertex pos col tex) = do #{poke sfVertex, position} ptr pos #{poke sfVertex, color} ptr col diff --git a/src/SFML/SFException.hs b/src/SFML/SFException.hs new file mode 100644 --- /dev/null +++ b/src/SFML/SFException.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module SFML.SFException where + +import Control.Exception +import Data.Typeable + +data SFException = SFException String deriving (Show, Typeable) + +instance Exception SFException diff --git a/src/SFML/System/InputStream.hsc b/src/SFML/System/InputStream.hsc --- a/src/SFML/System/InputStream.hsc +++ b/src/SFML/System/InputStream.hsc @@ -10,6 +10,7 @@ where +import Control.Applicative ((<$>), (<*>)) import Data.Word (Word64) import Foreign.C.Types (CInt) import Foreign.Ptr (Ptr) @@ -55,15 +56,14 @@ instance Storable InputStream where sizeOf _ = size_InputStream alignment _ = alignment (undefined :: CInt) - - peek ptr = do - read <- #{peek sfInputStream, read} ptr - seek <- #{peek sfInputStream, seek} ptr - tell <- #{peek sfInputStream, tell} ptr - gets <- #{peek sfInputStream, getSize} ptr - udata <- #{peek sfInputStream, userData} ptr - return $ InputStream read seek tell gets udata - + + peek ptr = InputStream + <$> #{peek sfInputStream, read} ptr + <*> #{peek sfInputStream, seek} ptr + <*> #{peek sfInputStream, tell} ptr + <*> #{peek sfInputStream, getSize} ptr + <*> #{peek sfInputStream, userData} ptr + poke ptr (InputStream read seek tell gets udata) = do #{poke sfInputStream, read} ptr read #{poke sfInputStream, seek} ptr seek @@ -76,7 +76,7 @@ instance Show InputStream where - + show (InputStream read seek tell getSize userData) = "InputStream { read = " ++ show read ++ ", seek = " ++ show seek ++ diff --git a/src/SFML/System/Vector2.hsc b/src/SFML/System/Vector2.hsc --- a/src/SFML/System/Vector2.hsc +++ b/src/SFML/System/Vector2.hsc @@ -8,6 +8,7 @@ where +import Control.Applicative ((<$>), (<*>)) import Data.Word import Foreign.C.Types import Foreign.Storable @@ -25,12 +26,11 @@ instance Storable Vec2i where sizeOf _ = 2*sizeInt alignment _ = alignment (undefined :: CInt) - - peek ptr = do - x <- #{peek sfVector2i, x} ptr :: IO CInt - y <- #{peek sfVector2i, y} ptr :: IO CInt - return $ Vec2i (fromIntegral x) (fromIntegral y) - + + peek ptr = Vec2i + <$> fmap fromIntegral (#{peek sfVector2i, x} ptr :: IO CInt) + <*> fmap fromIntegral (#{peek sfVector2i, y} ptr :: IO CInt) + poke ptr (Vec2i x y) = do #{poke sfVector2i, x} ptr (fromIntegral x :: CInt) #{poke sfVector2i, y} ptr (fromIntegral y :: CInt) @@ -51,12 +51,11 @@ instance Storable Vec2u where sizeOf _ = 2*sizeInt alignment _ = alignment (undefined :: CUInt) - - peek ptr = do - x <- #{peek sfVector2u, x} ptr :: IO CUInt - y <- #{peek sfVector2u, y} ptr :: IO CUInt - return $ Vec2u (fromIntegral x) (fromIntegral y) - + + peek ptr = Vec2u + <$> fmap fromIntegral (#{peek sfVector2u, x} ptr :: IO CUInt) + <*> fmap fromIntegral (#{peek sfVector2u, y} ptr :: IO CUInt) + poke ptr (Vec2u x y) = do #{poke sfVector2u, x} ptr (fromIntegral x :: CUInt) #{poke sfVector2u, y} ptr (fromIntegral y :: CUInt) @@ -77,12 +76,11 @@ instance Storable Vec2f where sizeOf _ = 2*sizeFloat alignment _ = alignment (undefined :: CFloat) - - peek ptr = do - x <- fmap realToFrac (#{peek sfVector2f, x} ptr :: IO CFloat) - y <- fmap realToFrac (#{peek sfVector2f, y} ptr :: IO CFloat) - return $ Vec2f x y - + + peek ptr = Vec2f + <$> fmap realToFrac (#{peek sfVector2f, x} ptr :: IO CFloat) + <*> fmap realToFrac (#{peek sfVector2f, y} ptr :: IO CFloat) + poke ptr (Vec2f x y) = do #{poke sfVector2f, x} ptr (realToFrac x :: CFloat) #{poke sfVector2f, y} ptr (realToFrac y :: CFloat) diff --git a/src/SFML/System/Vector3.hsc b/src/SFML/System/Vector3.hsc --- a/src/SFML/System/Vector3.hsc +++ b/src/SFML/System/Vector3.hsc @@ -6,6 +6,7 @@ where +import Control.Applicative ((<$>), (<*>)) import Foreign.C.Types import Foreign.Storable @@ -21,13 +22,12 @@ instance Storable Vec3f where sizeOf _ = 3*sizeFloat alignment _ = alignment (undefined :: CFloat) - - peek ptr = do - x <- fmap realToFrac (#{peek sfVector3f, x} ptr :: IO CFloat) - y <- fmap realToFrac (#{peek sfVector3f, y} ptr :: IO CFloat) - z <- fmap realToFrac (#{peek sfVector3f, z} ptr :: IO CFloat) - return $ Vec3f x y z - + + peek ptr = Vec3f + <$> fmap realToFrac (#{peek sfVector3f, x} ptr :: IO CFloat) + <*> fmap realToFrac (#{peek sfVector3f, y} ptr :: IO CFloat) + <*> fmap realToFrac (#{peek sfVector3f, z} ptr :: IO CFloat) + poke ptr (Vec3f x y z) = do #{poke sfVector3f, x} ptr (realToFrac x :: CFloat) #{poke sfVector3f, y} ptr (realToFrac y :: CFloat) diff --git a/src/SFML/Window/ContextSettings.hsc b/src/SFML/Window/ContextSettings.hsc --- a/src/SFML/Window/ContextSettings.hsc +++ b/src/SFML/Window/ContextSettings.hsc @@ -2,10 +2,13 @@ module SFML.Window.ContextSettings ( ContextSettings(..) +, ContextAttribute(..) ) where +import Control.Applicative ((<$>), (<*>)) +import Data.Word (Word32) import Foreign.C.Types import Foreign.Storable @@ -13,7 +16,7 @@ #include -sizeInt = #{size int} +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t(y__); }, y__) data ContextSettings = ContextSettings @@ -22,27 +25,51 @@ , antialiasingLevel :: Int -- ^ Level of antialiasing , majorVersion :: Int -- ^ Major number of the context version to create , minorVersion :: Int -- ^ Minor number of the context version to create + , attributeFlags :: [ContextAttribute] -- ^ The attribute flags to create the context with } deriving (Show) instance Storable ContextSettings where - sizeOf _ = 5*sizeInt - alignment _ = alignment (undefined :: CUInt) - - peek ptr = do - db <- #{peek sfContextSettings, depthBits} ptr :: IO CInt - sb <- #{peek sfContextSettings, stencilBits} ptr :: IO CInt - al <- #{peek sfContextSettings, antialiasingLevel} ptr :: IO CInt - ma <- #{peek sfContextSettings, majorVersion} ptr :: IO CInt - mi <- #{peek sfContextSettings, minorVersion} ptr :: IO CInt - return $ ContextSettings (fromIntegral db) (fromIntegral sb) (fromIntegral al) - (fromIntegral ma) (fromIntegral mi) - - poke ptr (ContextSettings db sb al ma mi) = do + sizeOf _ = #{size sfContextSettings} + alignment _ = #{alignment sfContextSettings} + + peek ptr = ContextSettings + <$> fmap fromIntegral (#{peek sfContextSettings, depthBits} ptr :: IO CInt) + <*> fmap fromIntegral (#{peek sfContextSettings, stencilBits} ptr :: IO CInt) + <*> fmap fromIntegral (#{peek sfContextSettings, antialiasingLevel} ptr :: IO CInt) + <*> fmap fromIntegral (#{peek sfContextSettings, majorVersion} ptr :: IO CInt) + <*> fmap fromIntegral (#{peek sfContextSettings, minorVersion} ptr :: IO CInt) + <*> fmap (toFlags . fromIntegral) (#{peek sfContextSettings, attributeFlags} ptr :: IO Word32) + + poke ptr (ContextSettings db sb al ma mi af) = do #{poke sfContextSettings, depthBits} ptr (fromIntegral db :: CInt) #{poke sfContextSettings, stencilBits} ptr (fromIntegral sb :: CInt) #{poke sfContextSettings, antialiasingLevel} ptr (fromIntegral al :: CInt) #{poke sfContextSettings, majorVersion} ptr (fromIntegral ma :: CInt) #{poke sfContextSettings, minorVersion} ptr (fromIntegral mi :: CInt) + #{poke sfContextSettings, attributeFlags} ptr ((fromIntegral . fromFlags) af :: Word32) + +data ContextAttribute + = ContextDefault -- ^ Non-debug, compatibility context (this and the core attribute are mutually exclusive) + | ContextCore -- ^ Core attribute + | ContextDebug -- ^ Debug attribute + deriving (Eq, Show) + + +instance Enum ContextAttribute where + + fromEnum ContextDefault = 0 + fromEnum ContextCore = 1 + fromEnum ContextDebug = 2 + + toEnum 0 = ContextDefault + toEnum 1 = ContextCore + toEnum 2 = ContextDebug + +fromFlags :: [ContextAttribute] -> Int +fromFlags = sum . map fromEnum + +toFlags :: Int -> [ContextAttribute] +toFlags = return . toEnum diff --git a/src/SFML/Window/Event.hsc b/src/SFML/Window/Event.hsc --- a/src/SFML/Window/Event.hsc +++ b/src/SFML/Window/Event.hsc @@ -10,6 +10,7 @@ import SFML.Window.Keyboard import SFML.Window.Mouse +import Control.Applicative ((<$>), (<*>)) import Foreign.C.String import Foreign.C.Types import Foreign.Marshal.Array @@ -45,10 +46,16 @@ , sys :: Bool } | SFEvtMouseWheelMoved - { delta :: Int - , x :: Int - , y :: Int + { moveDelta :: Int + , x :: Int + , y :: Int } + | SFEvtMouseWheelScrolled + { wheel :: MouseWheel + , scrollDelta :: Float + , x :: Int + , y :: Int + } | SFEvtMouseButtonPressed { button :: MouseButton , x :: Int @@ -84,6 +91,7 @@ | SFEvtJoystickDisconnected { joystickId :: Int } + deriving (Eq, Show) sizeInt = #{size int} @@ -93,7 +101,7 @@ instance Storable SFEvent where sizeOf _ = #{size sfEvent} alignment _ = alignment (undefined :: CInt) - + peek ptr' = let ptr'' = castPtr ptr' :: Ptr CInt in do @@ -101,65 +109,58 @@ eventType <- peek ptr'' :: IO CInt case eventType of 0 -> return SFEvtClosed - 1 -> do - w <- #{peek sfSizeEvent, width} ptr :: IO CUInt - h <- #{peek sfSizeEvent, height} ptr :: IO CUInt - return $ SFEvtResized (fromIntegral w) (fromIntegral h) + 1 -> SFEvtResized + <$> fmap fromIntegral (#{peek sfSizeEvent, width} ptr :: IO CUInt) + <*> fmap fromIntegral (#{peek sfSizeEvent, height} ptr :: IO CUInt) 2 -> return SFEvtLostFocus 3 -> return SFEvtGainedFocus 4 -> peekCAString (plusPtr ptr sizeInt) >>= return . SFEvtTextEntered - 5 -> do - code <- #{peek sfKeyEvent, code} ptr - alt <- #{peek sfKeyEvent, alt} ptr :: IO CInt - ctrl <- #{peek sfKeyEvent, control} ptr :: IO CInt - shift <- #{peek sfKeyEvent, shift} ptr :: IO CInt - sys <- #{peek sfKeyEvent, system} ptr :: IO CInt - return $ SFEvtKeyPressed code (toEnum . fromIntegral $ alt) (toEnum . fromIntegral $ ctrl) - (toEnum . fromIntegral $ shift) (toEnum . fromIntegral $ sys) - 6 -> do - code <- #{peek sfKeyEvent, code} ptr - alt <- #{peek sfKeyEvent, alt} ptr :: IO CInt - ctrl <- #{peek sfKeyEvent, control} ptr :: IO CInt - shift <- #{peek sfKeyEvent, shift} ptr :: IO CInt - sys <- #{peek sfKeyEvent, system} ptr :: IO CInt - return $ SFEvtKeyReleased code (toEnum . fromIntegral $ alt) (toEnum . fromIntegral $ ctrl) - (toEnum . fromIntegral $ shift) (toEnum . fromIntegral $ sys) - 7 -> do - delta <- #{peek sfMouseWheelEvent, delta} ptr :: IO CInt - x <- #{peek sfMouseWheelEvent, x} ptr :: IO CInt - y <- #{peek sfMouseWheelEvent, y} ptr :: IO CInt - return $ SFEvtMouseWheelMoved (fromIntegral delta) (fromIntegral x) (fromIntegral y) - 8 -> do - button <- #{peek sfMouseButtonEvent, button} ptr - x <- #{peek sfMouseButtonEvent, x} ptr :: IO CInt - y <- #{peek sfMouseButtonEvent, y} ptr :: IO CInt - return $ SFEvtMouseButtonPressed button (fromIntegral x) (fromIntegral y) - 9 -> do - button <- #{peek sfMouseButtonEvent, button} ptr - x <- #{peek sfMouseButtonEvent, x} ptr :: IO CInt - y <- #{peek sfMouseButtonEvent, y} ptr :: IO CInt - return $ SFEvtMouseButtonReleased button (fromIntegral x) (fromIntegral y) - 10 -> do - x <- #{peek sfMouseMoveEvent, x} ptr :: IO CInt - y <- #{peek sfMouseMoveEvent, y} ptr :: IO CInt - return $ SFEvtMouseMoved (fromIntegral x) (fromIntegral y) - 11 -> return SFEvtMouseEntered - 12 -> return SFEvtMouseLeft - 13 -> do - j <- #{peek sfJoystickButtonEvent, joystickId} ptr :: IO CUInt - bt <- #{peek sfJoystickButtonEvent, button} ptr :: IO CUInt - return $ SFEvtJoystickButtonPressed (fromIntegral j) (fromIntegral bt) - 14 -> do - j <- #{peek sfJoystickButtonEvent, joystickId} ptr :: IO CUInt - bt <- #{peek sfJoystickButtonEvent, button} ptr :: IO CUInt - return $ SFEvtJoystickButtonReleased (fromIntegral j) (fromIntegral bt) - 15 -> do - j <- #{peek sfJoystickMoveEvent, joystickId} ptr :: IO CUInt - axis <- #{peek sfJoystickMoveEvent, axis} ptr - pos <- fmap realToFrac (#{peek sfJoystickMoveEvent, position} ptr :: IO CFloat) - return $ SFEvtJoystickMoved (fromIntegral j) axis pos - 16 -> peekByteOff ptr sizeInt >>= return . SFEvtJoystickConnected - 17 -> peekByteOff ptr sizeInt >>= return . SFEvtJoystickDisconnected - + 5 -> SFEvtKeyPressed + <$> #{peek sfKeyEvent, code} ptr + <*> fmap (toEnum . fromIntegral) (#{peek sfKeyEvent, alt} ptr :: IO CInt) + <*> fmap (toEnum . fromIntegral) (#{peek sfKeyEvent, control} ptr :: IO CInt) + <*> fmap (toEnum . fromIntegral) (#{peek sfKeyEvent, shift} ptr :: IO CInt) + <*> fmap (toEnum . fromIntegral) (#{peek sfKeyEvent, system} ptr :: IO CInt) + 6 -> SFEvtKeyReleased + <$> #{peek sfKeyEvent, code} ptr + <*> fmap (toEnum . fromIntegral) (#{peek sfKeyEvent, alt} ptr :: IO CInt) + <*> fmap (toEnum . fromIntegral) (#{peek sfKeyEvent, control} ptr :: IO CInt) + <*> fmap (toEnum . fromIntegral) (#{peek sfKeyEvent, shift} ptr :: IO CInt) + <*> fmap (toEnum . fromIntegral) (#{peek sfKeyEvent, system} ptr :: IO CInt) + 7 -> SFEvtMouseWheelMoved + <$> fmap fromIntegral (#{peek sfMouseWheelEvent, delta} ptr :: IO CInt) + <*> fmap fromIntegral (#{peek sfMouseWheelEvent, x} ptr :: IO CInt) + <*> fmap fromIntegral (#{peek sfMouseWheelEvent, y} ptr :: IO CInt) + 8 -> SFEvtMouseWheelScrolled + <$> (#{peek sfMouseWheelScrollEvent, wheel} ptr :: IO MouseWheel) + <*> fmap realToFrac (#{peek sfMouseWheelScrollEvent, delta} ptr :: IO CFloat) + <*> fmap fromIntegral (#{peek sfMouseWheelScrollEvent, x} ptr :: IO CInt) + <*> fmap fromIntegral (#{peek sfMouseWheelScrollEvent, y} ptr :: IO CInt) + 9 -> SFEvtMouseButtonPressed + <$> #{peek sfMouseButtonEvent, button} ptr + <*> fmap fromIntegral (#{peek sfMouseButtonEvent, x} ptr :: IO CInt) + <*> fmap fromIntegral (#{peek sfMouseButtonEvent, y} ptr :: IO CInt) + 10 -> SFEvtMouseButtonReleased + <$> #{peek sfMouseButtonEvent, button} ptr + <*> fmap fromIntegral (#{peek sfMouseButtonEvent, x} ptr :: IO CInt) + <*> fmap fromIntegral (#{peek sfMouseButtonEvent, y} ptr :: IO CInt) + 11 -> SFEvtMouseMoved + <$> fmap fromIntegral (#{peek sfMouseMoveEvent, x} ptr :: IO CInt) + <*> fmap fromIntegral (#{peek sfMouseMoveEvent, y} ptr :: IO CInt) + 12 -> return SFEvtMouseEntered + 13 -> return SFEvtMouseLeft + 14 -> SFEvtJoystickButtonPressed + <$> fmap fromIntegral (#{peek sfJoystickButtonEvent, joystickId} ptr :: IO CUInt) + <*> fmap fromIntegral (#{peek sfJoystickButtonEvent, button} ptr :: IO CUInt) + 15 -> SFEvtJoystickButtonReleased + <$> fmap fromIntegral (#{peek sfJoystickButtonEvent, joystickId} ptr :: IO CUInt) + <*> fmap fromIntegral (#{peek sfJoystickButtonEvent, button} ptr :: IO CUInt) + 16 -> SFEvtJoystickMoved + <$> fmap fromIntegral (#{peek sfJoystickMoveEvent, joystickId} ptr :: IO CUInt) + <*> #{peek sfJoystickMoveEvent, axis} ptr + <*> fmap realToFrac (#{peek sfJoystickMoveEvent, position} ptr :: IO CFloat) + 17 -> peekByteOff ptr sizeInt >>= return . SFEvtJoystickConnected + 18 -> peekByteOff ptr sizeInt >>= return . SFEvtJoystickDisconnected + poke ptr evt = return () diff --git a/src/SFML/Window/Joystick.hsc b/src/SFML/Window/Joystick.hsc --- a/src/SFML/Window/Joystick.hsc +++ b/src/SFML/Window/Joystick.hsc @@ -8,12 +8,16 @@ , hasAxis , isJoystickButtonPressed , getAxisPosition +, getJoystickIdentification , updateJoystick ) where +import SFML.Window.JoystickIdentification + import Foreign.C.Types +import Foreign.Marshal.Alloc (alloca) import Foreign.Storable import Foreign.Ptr (Ptr, castPtr) @@ -27,11 +31,11 @@ instance Enum JoystickCap where - + fromEnum JoystickCount = 8 fromEnum JoystickButtonCount = 32 fromEnum JoystickAxisCount = 8 - + toEnum 8 = JoystickCount toEnum 32 = JoystickButtonCount --toEnum 8 = JoystickAxisCount @@ -56,7 +60,7 @@ instance Storable JoystickAxis where sizeOf _ = sizeInt alignment _ = alignment (undefined :: CInt) - + peek ptr = peek (castPtr ptr :: Ptr CInt) >>= return . toEnum . fromIntegral poke ptr bt = poke (castPtr ptr :: Ptr CInt) (fromIntegral . fromEnum $ bt) @@ -135,6 +139,23 @@ sfJoystick_getAxisPosition :: CUInt -> CUInt -> IO CFloat --CSFML_WINDOW_API float sfJoystick_getAxisPosition(unsigned int joystick, sfJoystickAxis axis); + + +-- | Get the joystick information. +-- +-- The result of this function will only remain valid until +-- the next time the function is called. +getJoystickIdentification + :: Int -- ^ Index of the joystick + -> IO JoystickIdentification + +getJoystickIdentification j + = alloca $ \ptr -> sfJoystick_getIdentification_helper (fromIntegral j) ptr >> peek ptr + +foreign import ccall unsafe "sfJoystick_getIdentification_helper" + sfJoystick_getIdentification_helper :: CUInt -> Ptr JoystickIdentification -> IO () + +--CSFML_WINDOW_API sfJoystickIdentification sfJoystick_getIdentification(unsigned int joystick); -- | Update the states of all joysticks. diff --git a/src/SFML/Window/JoystickIdentification.hsc b/src/SFML/Window/JoystickIdentification.hsc new file mode 100644 --- /dev/null +++ b/src/SFML/Window/JoystickIdentification.hsc @@ -0,0 +1,41 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +module SFML.Window.JoystickIdentification +( + JoystickIdentification(..) +) +where + + +import Control.Applicative ((<$>), (<*>)) +import Foreign.C.String +import Foreign.C.Types +import Foreign.Storable +import Foreign.Ptr (Ptr, castPtr) + +#include + + +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t(y__); }, y__) + + +-- | Joystick's identification +data JoystickIdentification = JoystickIdentification + { name :: String + , vendorId :: Int + , productId :: Int + } deriving (Eq, Show) + + +instance Storable JoystickIdentification where + sizeOf _ = #{size sfJoystickIdentification} + alignment _ = #{alignment sfJoystickIdentification} + + peek ptr = JoystickIdentification + <$> (#{peek sfJoystickIdentification, name} ptr >>= peekCString) + <*> fmap fromIntegral (#{peek sfJoystickIdentification, vendorId} ptr :: IO CUInt) + <*> fmap fromIntegral (#{peek sfJoystickIdentification, productId} ptr :: IO CUInt) + + poke ptr ji = do + withCString (name ji) $ #{poke sfJoystickIdentification, name} ptr + #{poke sfJoystickIdentification, vendorId} ptr ((fromIntegral . vendorId) ji :: CUInt) + #{poke sfJoystickIdentification, productId} ptr ((fromIntegral . productId) ji :: CUInt) diff --git a/src/SFML/Window/Mouse.hsc b/src/SFML/Window/Mouse.hsc --- a/src/SFML/Window/Mouse.hsc +++ b/src/SFML/Window/Mouse.hsc @@ -2,6 +2,7 @@ module SFML.Window.Mouse ( MouseButton(..) +, MouseWheel(..) , isMouseButtonPressed ) where @@ -15,7 +16,12 @@ import Foreign.Ptr import Foreign.Storable +#include + +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t(y__); }, y__) + + data MouseButton = MouseLeft | MouseRight @@ -25,13 +31,24 @@ deriving (Eq, Enum, Bounded, Show) -sizeInt = #{size int} +data MouseWheel + = MouseVerticalWheel -- ^ The vertical mouse wheel + | MouseHorizontalWheel -- ^ The horizontal mouse wheel + deriving (Eq, Enum, Bounded, Show) +instance Storable MouseWheel where + sizeOf _ = #{size sfMouseWheel} + alignment _ = #{alignment sfMouseWheel} + + peek ptr = peek (castPtr ptr :: Ptr CInt) >>= return . toEnum . fromIntegral + poke ptr mw = poke (castPtr ptr :: Ptr CInt) (fromIntegral . fromEnum $ mw) + + instance Storable MouseButton where - sizeOf _ = sizeInt - alignment _ = alignment (undefined :: CInt) - + sizeOf _ = #{size sfMouseButton} + alignment _ = #{alignment sfMouseButton} + peek ptr = peek (castPtr ptr :: Ptr CInt) >>= return . toEnum . fromIntegral poke ptr bt = poke (castPtr ptr :: Ptr CInt) (fromIntegral . fromEnum $ bt) diff --git a/src/SFML/Window/SFWindow.hs b/src/SFML/Window/SFWindow.hs --- a/src/SFML/Window/SFWindow.hs +++ b/src/SFML/Window/SFWindow.hs @@ -124,6 +124,23 @@ -- Only one window can be active on a thread at a time, thus -- the window previously active (if any) automatically gets deactivated. setWindowActive :: a -> Bool -> IO () + + -- | Request the current window to be made the active foreground window. + -- + -- At any given time, only one window may have the input focus + -- to receive input events such as keystrokes or mouse events. + -- If a window requests focus, it only hints to the operating + -- system, that it would like to be focused. The operating system + -- is free to deny the request. + -- This is not to be confused with 'setWindowActive'. + requestFocus :: a -> IO () + + -- | Check whether the render window has the input focus. + -- + -- At any given time, only one window may have the input focus + -- to receive input events such as keystrokes or most mouse + -- events. + hasFocus :: a -> IO Bool -- | Limit the framerate to a maximum fixed frequency. -- diff --git a/src/SFML/Window/VideoMode.hsc b/src/SFML/Window/VideoMode.hsc --- a/src/SFML/Window/VideoMode.hsc +++ b/src/SFML/Window/VideoMode.hsc @@ -9,7 +9,7 @@ where -import Control.Applicative +import Control.Applicative ((<$>), (<*>), (*>), liftA2) import Foreign.C.Types import Foreign.Ptr import Foreign.Marshal.Alloc (alloca) @@ -34,13 +34,12 @@ instance Storable VideoMode where sizeOf _ = 3*sizeInt alignment _ = alignment (undefined :: CInt) - - peek ptr = do - w <- #{peek sfVideoMode, width} ptr :: IO CUInt - h <- #{peek sfVideoMode, height} ptr :: IO CUInt - b <- #{peek sfVideoMode, bitsPerPixel} ptr :: IO CUInt - return $ VideoMode (fromIntegral w) (fromIntegral h) (fromIntegral b) - + + peek ptr = VideoMode + <$> fmap fromIntegral (#{peek sfVideoMode, width} ptr :: IO CUInt) + <*> fmap fromIntegral (#{peek sfVideoMode, height} ptr :: IO CUInt) + <*> fmap fromIntegral (#{peek sfVideoMode, bitsPerPixel} ptr :: IO CUInt) + poke ptr (VideoMode w h b) = do #{poke sfVideoMode, width} ptr (fromIntegral w :: CUInt) #{poke sfVideoMode, height} ptr (fromIntegral h :: CUInt) diff --git a/src/SFML/Window/Window.hsc b/src/SFML/Window/Window.hsc --- a/src/SFML/Window/Window.hsc +++ b/src/SFML/Window/Window.hsc @@ -22,6 +22,8 @@ , setVSync , setKeyRepeat , setWindowActive +, requestFocus +, hasFocus , display , setFramerateLimit , setJoystickThreshold @@ -32,6 +34,7 @@ where +import Control.Applicative ((<$>), (<*>)) import SFML.SFDisplayable import SFML.SFResource import SFML.System.Vector2 @@ -65,14 +68,14 @@ instance Enum WindowStyle where - + fromEnum SFNone = 0 fromEnum SFTitlebar = 1 fromEnum SFResize = 2 fromEnum SFClose = 4 fromEnum SFFullscreen = 8 fromEnum SFDefaultStyle = 7 - + toEnum 0 = SFNone toEnum 1 = SFTitlebar toEnum 2 = SFResize @@ -80,7 +83,6 @@ toEnum 8 = SFFullscreen toEnum 7 = SFDefaultStyle - -- | Construct a new window. -- -- This function creates the window with the size and pixel @@ -140,7 +142,7 @@ instance SFResource Window where - + {-# INLINABLE destroy #-} destroy = sfWindow_destroy @@ -151,25 +153,25 @@ instance SFDisplayable Window where - + {-# INLINABLE display #-} display = sfWindow_display instance SFWindow Window where - + {-# INLINABLE close #-} close = sfWindow_close - + {-# INLINABLE isWindowOpen #-} isWindowOpen wnd = sfWindow_isOpen wnd >>= return . (/=0) - + {-# INLINABLE getWindowSettings #-} getWindowSettings wnd = alloca $ \ptrCtxSettings -> do sfWindow_getSettings_helper wnd ptrCtxSettings peek ptrCtxSettings - + {-# INLINABLE pollEvent #-} pollEvent wnd = alloca $ \ptrEvt -> do @@ -177,7 +179,7 @@ case result of True -> peek ptrEvt >>= return . Just False -> return Nothing - + {-# INLINABLE waitEvent #-} waitEvent wnd = alloca $ \ptr -> do @@ -185,53 +187,59 @@ case result of 0 -> return Nothing _ -> peek ptr >>= return . Just - + {-# INLINABLE getWindowPosition #-} getWindowPosition wnd = alloca $ \vecPtr -> sfWindow_getPosition_helper wnd vecPtr >> peek vecPtr - + {-# INLINABLE setWindowPosition #-} setWindowPosition wnd pos = with pos $ \posPtr -> sfWindow_setPosition_helper wnd posPtr - + {-# INLINABLE getWindowSize #-} getWindowSize wnd = alloca $ \vecPtr -> sfWindow_getSize_helper wnd vecPtr >> peek vecPtr - + {-# INLINABLE setWindowSize #-} setWindowSize wnd size = with size $ \ptrSize -> sfWindow_setSize_helper wnd ptrSize - + {-# INLINABLE setWindowTitle #-} setWindowTitle wnd title = withCAString title $ \ptrTitle -> sfWindow_setTitle wnd ptrTitle - + {-# INLINABLE setWindowIcon #-} setWindowIcon = sfWindow_setIcon - + {-# INLINABLE setWindowVisible #-} setWindowVisible wnd val = sfWindow_setVisible wnd (fromIntegral . fromEnum $ val) - + {-# INLINABLE setMouseVisible #-} setMouseVisible wnd val = sfWindow_setMouseCursorVisible wnd (fromIntegral . fromEnum $ val) - + {-# INLINABLE setVSync #-} setVSync wnd val = sfWindow_setVerticalSyncEnabled wnd (fromIntegral . fromEnum $ val) - + {-# INLINABLE setKeyRepeat #-} setKeyRepeat wnd val = sfWindow_setKeyRepeatEnabled wnd (fromIntegral . fromEnum $ val) - + {-# INLINABLE setWindowActive #-} setWindowActive wnd val = sfWindow_setActive wnd (fromIntegral . fromEnum $ val) - + + {-# INLINABLE requestFocus #-} + requestFocus wnd = sfWindow_requestFocus wnd + + {-# INLINABLE hasFocus #-} + hasFocus wnd = ((/=0) . fromIntegral) <$> sfWindow_hasFocus wnd + {-# INLINABLE setFramerateLimit #-} setFramerateLimit wnd val = sfWindow_setFramerateLimit wnd (fromIntegral val) - + {-# INLINABLE setJoystickThreshold #-} setJoystickThreshold w t = sfWindow_setJoystickThreshold w (realToFrac t) - + {-# INLINABLE getSystemHandle #-} getSystemHandle = sfWindow_getSystemHandle - + {-# INLINABLE getMousePosition #-} getMousePosition Nothing = alloca $ \ptr -> sfMouse_getPosition_helper (Window nullPtr) ptr >> peek ptr getMousePosition (Just wnd) = alloca $ \ptr -> sfMouse_getPosition_helper wnd ptr >> peek ptr - + {-# INLINABLE setMousePosition #-} setMousePosition pos Nothing = with pos $ \ptr -> sfMouse_setPosition_helper ptr (Window nullPtr) setMousePosition pos (Just wnd) = with pos $ \ptr -> sfMouse_setPosition_helper ptr wnd @@ -307,29 +315,43 @@ --CSFML_WINDOW_API void sfWindow_setVisible(sfWindow* window, sfBool visible); + foreign import ccall unsafe "sfWindow_setMouseCursorVisible" sfWindow_setMouseCursorVisible :: Window -> CChar -> IO () --CSFML_WINDOW_API void sfWindow_setMouseCursorVisible(sfWindow* window, sfBool visible); + foreign import ccall unsafe "sfWindow_setVerticalSyncEnabled" sfWindow_setVerticalSyncEnabled :: Window -> CChar -> IO () --CSFML_WINDOW_API void sfWindow_setVerticalSyncEnabled(sfWindow* window, sfBool enabled); +foreign import ccall unsafe "sfWindow_setKeyRepeatEnabled" + sfWindow_setKeyRepeatEnabled :: Window -> CChar -> IO () + +--CSFML_WINDOW_API void sfWindow_setKeyRepeatEnabled(sfWindow* window, sfBool enabled); + + foreign import ccall unsafe "sfWindow_setActive" sfWindow_setActive :: Window -> CChar -> IO () --CSFML_WINDOW_API sfBool sfWindow_setActive(sfWindow* window, sfBool active); -foreign import ccall unsafe "sfWindow_setKeyRepeatEnabled" - sfWindow_setKeyRepeatEnabled :: Window -> CChar -> IO () +foreign import ccall unsafe "sfWindow_requestFocus" + sfWindow_requestFocus :: Window -> IO () ---CSFML_WINDOW_API void sfWindow_setKeyRepeatEnabled(sfWindow* window, sfBool enabled); +-- CSFML_WINDOW_API void sfWindow_requestFocus(sfWindow* window); +foreign import ccall unsafe "sfWindow_hasFocus" + sfWindow_hasFocus :: Window -> IO CInt + +--CSFML_WINDOW_API sfBool sfWindow_hasFocus(const sfWindow* window); + + foreign import ccall unsafe "sfWindow_display" sfWindow_display :: Window -> IO () @@ -347,6 +369,7 @@ --CSFML_WINDOW_API void sfWindow_setJoystickThreshold(sfWindow* window, float threshold); + foreign import ccall unsafe "sfWindow_getSystemHandle" sfWindow_getSystemHandle :: Window -> IO WindowHandle @@ -358,8 +381,8 @@ --CSFML_WINDOW_API sfVector2i sfMouse_getPosition(const sfWindow* relativeTo); + foreign import ccall unsafe "sfMouse_setPosition_helper" sfMouse_setPosition_helper :: Ptr Vec2i -> Window -> IO () --CSFML_WINDOW_API void sfMouse_setPosition(sfVector2i position, const sfWindow* relativeTo); -