diff --git a/Graphics/UI/SDL.hs b/Graphics/UI/SDL.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/SDL.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.SDL +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portablex +-- +----------------------------------------------------------------------------- +module Graphics.UI.SDL + ( module Graphics.UI.SDL.General + , module Graphics.UI.SDL.Rect + , module Graphics.UI.SDL.Time + , module Graphics.UI.SDL.Types + , module Graphics.UI.SDL.Video + , module Graphics.UI.SDL.WindowManagement + , module Graphics.UI.SDL.Audio + , module Graphics.UI.SDL.Color + , module Graphics.UI.SDL.Keysym + , module Graphics.UI.SDL.Events + , module Graphics.UI.SDL.RWOps + , module Graphics.UI.SDL.Version + , module Graphics.UI.SDL.Joystick + ) where + +import Graphics.UI.SDL.General +import Graphics.UI.SDL.Rect +import Graphics.UI.SDL.Time +import Graphics.UI.SDL.Types +import Graphics.UI.SDL.Video +import Graphics.UI.SDL.WindowManagement +import Graphics.UI.SDL.Audio +import Graphics.UI.SDL.Color +import Graphics.UI.SDL.Keysym +import Graphics.UI.SDL.Events +import Graphics.UI.SDL.RWOps +import Graphics.UI.SDL.Version +import Graphics.UI.SDL.Joystick diff --git a/Graphics/UI/SDL/Audio.hsc b/Graphics/UI/SDL/Audio.hsc new file mode 100644 --- /dev/null +++ b/Graphics/UI/SDL/Audio.hsc @@ -0,0 +1,51 @@ +#include "SDL.h" +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.SDL.Audio +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- +module Graphics.UI.SDL.Audio + ( AudioFormat (..) + , fromAudioFormat + , toAudioFormat + ) where + +import Data.Word (Word16) + +data AudioFormat + = AudioU8 + | AudioS8 + | AudioU16LSB + | AudioS16LSB + | AudioU16MSB + | AudioS16MSB + | AudioU16Sys + | AudioS16Sys + deriving (Show,Eq,Ord,Enum) + +fromAudioFormat :: AudioFormat -> Word16 +fromAudioFormat AudioU8 = #{const AUDIO_U8} +fromAudioFormat AudioS8 = #{const AUDIO_S8} +fromAudioFormat AudioU16LSB = #{const AUDIO_U16LSB} +fromAudioFormat AudioS16LSB = #{const AUDIO_S16LSB} +fromAudioFormat AudioU16MSB = #{const AUDIO_U16MSB} +fromAudioFormat AudioS16MSB = #{const AUDIO_S16MSB} +fromAudioFormat AudioU16Sys = #{const AUDIO_U16SYS} +fromAudioFormat AudioS16Sys = #{const AUDIO_S16SYS} + +toAudioFormat :: Word16 -> AudioFormat +toAudioFormat #{const AUDIO_U8} = AudioU8 +toAudioFormat #{const AUDIO_S8} = AudioS8 +toAudioFormat #{const AUDIO_U16LSB} = AudioU16LSB +toAudioFormat #{const AUDIO_S16LSB} = AudioS16LSB +toAudioFormat #{const AUDIO_U16MSB} = AudioU16MSB +toAudioFormat #{const AUDIO_S16MSB} = AudioS16MSB +toAudioFormat _ = error "Graphics.UI.SDL.Audio.toAudioFormat: bad argument" + + diff --git a/Graphics/UI/SDL/CPUInfo.hs b/Graphics/UI/SDL/CPUInfo.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/SDL/CPUInfo.hs @@ -0,0 +1,53 @@ +module Graphics.UI.SDL.CPUInfo + ( hasRDTSC + , hasMMX + , hasMMXExt + , has3DNow + , has3DNowExt + , hasSSE + , hasSSE2 + , hasAltiVec + ) where + +import Foreign.Marshal.Utils (toBool) + +foreign import ccall unsafe "SDL_HasRDTSC" sdlHasRDTSC :: Int +-- |This function returns @True@ if the CPU has the RDTSC instruction. +hasRDTSC :: Bool +hasRDTSC = toBool sdlHasRDTSC + +foreign import ccall unsafe "SDL_HasMMX" sdlHasMMX :: Int +-- |This function returns @True@ if the CPU has MMX features. +hasMMX :: Bool +hasMMX = toBool sdlHasMMX + +foreign import ccall unsafe "SDL_HasMMXExt" sdlHasMMXExt :: Int +-- |This function returns @True@ if the CPU has MMX Ext. features. +hasMMXExt :: Bool +hasMMXExt = toBool sdlHasMMXExt + +foreign import ccall unsafe "SDL_Has3DNow" sdlHas3DNow :: Int +-- |This function returns @True@ if the CPU has 3DNow features. +has3DNow :: Bool +has3DNow = toBool sdlHas3DNow + +foreign import ccall unsafe "SDL_Has3DNowExt" sdlHas3DNowExt :: Int +-- |This function returns @True@ if the CPU has 3DNow! Ext. features. +has3DNowExt :: Bool +has3DNowExt = toBool sdlHas3DNowExt + +foreign import ccall unsafe "SDL_HasSSE" sdlHasSSE :: Int +-- |This function returns @True@ if the CPU has SSE features. +hasSSE :: Bool +hasSSE = toBool sdlHasSSE + +foreign import ccall unsafe "SDL_HasSSE2" sdlHasSSE2 :: Int +-- |This function returns @True@ if the CPU has SSE2 features. +hasSSE2 :: Bool +hasSSE2 = toBool sdlHasSSE2 + +foreign import ccall unsafe "SDL_HasAltiVec" sdlHasAltiVec :: Int +-- |This function returns @True@ if the CPU has AltiVec features. +hasAltiVec :: Bool +hasAltiVec = toBool sdlHasAltiVec + diff --git a/Graphics/UI/SDL/Color.hs b/Graphics/UI/SDL/Color.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/SDL/Color.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.SDL.Color +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- +module Graphics.UI.SDL.Color + (Color (..) + ,Pixel (..) + ) where + +import Foreign (castPtr,pokeArray) +import Data.Word (Word8,Word32) +import Foreign.Storable (Storable(..)) + +data Color + = Color + { colorRed, colorGreen, colorBlue :: Word8 } + +instance Storable Color where + sizeOf = const 4 + alignment = const 1 + peek ptr + = do r <- peekByteOff ptr 0 + g <- peekByteOff ptr 1 + b <- peekByteOff ptr 2 + return (Color r g b) + poke ptr (Color r g b) = pokeArray (castPtr ptr) [r,g,b,0] + +newtype Pixel = Pixel Word32 deriving (Show,Eq,Ord) + +instance Storable Pixel where + sizeOf (Pixel v) = sizeOf v + alignment (Pixel v) = alignment v + peek p + = do v <- peek (castPtr p) + return $ Pixel v + poke p (Pixel v) = poke (castPtr p) v diff --git a/Graphics/UI/SDL/Events.hsc b/Graphics/UI/SDL/Events.hsc new file mode 100644 --- /dev/null +++ b/Graphics/UI/SDL/Events.hsc @@ -0,0 +1,625 @@ +#include "SDL.h" +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.SDL.Events +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- +module Graphics.UI.SDL.Events + ( Event (..) + , SDLEvent (..) + , UserEventID (..) + , MouseButton (..) + , Focus(..) + , toSafePtr + , tryFromSafePtr + , fromSafePtr + , typeOfSafePtr + , enableKeyRepeat + , enableUnicode + , queryUnicodeState + , getKeyName + , getMouseState + , getRelativeMouseState + , getModState + , setModState + , tryPushEvent + , pushEvent + , pollEvent + , waitEvent + , waitEventBlocking + , pumpEvents + , enableEvent + , queryEventState + , getAppState + ) where + +import Foreign (Int16, Word8, Word16, Word32, Ptr, + Storable(poke, sizeOf, alignment, peekByteOff, pokeByteOff, peek), + unsafePerformIO, toBool, new, alloca) +import Foreign.C (peekCString, CString) +import Data.Bits (Bits((.&.), shiftL)) +import Control.Concurrent (threadDelay) +import Prelude hiding (Enum(..)) +import qualified Prelude (Enum(..)) + +import Foreign.StablePtr (newStablePtr,castStablePtrToPtr,castPtrToStablePtr,deRefStablePtr) +import Data.Typeable (Typeable(typeOf),TypeRep) + +import Graphics.UI.SDL.Keysym (SDLKey, Modifier, Keysym) +import Graphics.UI.SDL.Utilities (Enum(..), intToBool, toBitmask, fromBitmask) +import Graphics.UI.SDL.General (unwrapBool, failWithError) +import Graphics.UI.SDL.Video (Toggle(..), fromToggle) + +-- |Low level event structure keeping a one-to-one relation with the C event structure. +data SDLEvent = SDLNoEvent + | SDLActiveEvent + | SDLKeyDown + | SDLKeyUp + | SDLMouseMotion + | SDLMouseButtonDown + | SDLMouseButtonUp + | SDLJoyAxisMotion + | SDLJoyBallMotion + | SDLJoyHatMotion + | SDLJoyButtonDown + | SDLJoyButtonUp + | SDLQuit + | SDLSysWMEvent + | SDLVideoResize + | SDLVideoExpose + | SDLUserEvent Word8 + | SDLNumEvents + deriving (Eq, Ord, Show) +instance Bounded SDLEvent where + minBound = SDLNoEvent + maxBound = SDLNumEvents + +fromSDLEvent :: SDLEvent -> Word8 +fromSDLEvent SDLNoEvent = #{const SDL_NOEVENT} +fromSDLEvent SDLActiveEvent = #{const SDL_ACTIVEEVENT} +fromSDLEvent SDLKeyDown = #{const SDL_KEYDOWN} +fromSDLEvent SDLKeyUp = #{const SDL_KEYUP} +fromSDLEvent SDLMouseMotion = #{const SDL_MOUSEMOTION} +fromSDLEvent SDLMouseButtonDown = #{const SDL_MOUSEBUTTONDOWN} +fromSDLEvent SDLMouseButtonUp = #{const SDL_MOUSEBUTTONUP} +fromSDLEvent SDLJoyAxisMotion = #{const SDL_JOYAXISMOTION} +fromSDLEvent SDLJoyBallMotion = #{const SDL_JOYBALLMOTION} +fromSDLEvent SDLJoyHatMotion = #{const SDL_JOYHATMOTION} +fromSDLEvent SDLJoyButtonDown = #{const SDL_JOYBUTTONDOWN} +fromSDLEvent SDLJoyButtonUp = #{const SDL_JOYBUTTONUP} +fromSDLEvent SDLQuit = #{const SDL_QUIT} +fromSDLEvent SDLSysWMEvent = #{const SDL_SYSWMEVENT} +fromSDLEvent SDLVideoResize = #{const SDL_VIDEORESIZE} +fromSDLEvent SDLVideoExpose = #{const SDL_VIDEOEXPOSE} +fromSDLEvent (SDLUserEvent n) = #{const SDL_USEREVENT} + n +fromSDLEvent SDLNumEvents = #{const SDL_NUMEVENTS} + +toSDLEvent :: Word8 -> SDLEvent +toSDLEvent #{const SDL_NOEVENT} = SDLNoEvent +toSDLEvent #{const SDL_ACTIVEEVENT} = SDLActiveEvent +toSDLEvent #{const SDL_KEYDOWN} = SDLKeyDown +toSDLEvent #{const SDL_KEYUP} = SDLKeyUp +toSDLEvent #{const SDL_MOUSEMOTION} = SDLMouseMotion +toSDLEvent #{const SDL_MOUSEBUTTONDOWN} = SDLMouseButtonDown +toSDLEvent #{const SDL_MOUSEBUTTONUP} = SDLMouseButtonUp +toSDLEvent #{const SDL_JOYAXISMOTION} = SDLJoyAxisMotion +toSDLEvent #{const SDL_JOYBALLMOTION} = SDLJoyBallMotion +toSDLEvent #{const SDL_JOYHATMOTION} = SDLJoyHatMotion +toSDLEvent #{const SDL_JOYBUTTONDOWN} = SDLJoyButtonDown +toSDLEvent #{const SDL_JOYBUTTONUP} = SDLJoyButtonUp +toSDLEvent #{const SDL_QUIT} = SDLQuit +toSDLEvent #{const SDL_SYSWMEVENT} = SDLSysWMEvent +toSDLEvent #{const SDL_VIDEORESIZE} = SDLVideoResize +toSDLEvent #{const SDL_VIDEOEXPOSE} = SDLVideoExpose +toSDLEvent n + | n >= #{const SDL_USEREVENT} && + n < #{const SDL_NUMEVENTS} = SDLUserEvent (n - #{const SDL_USEREVENT}) +toSDLEvent _ = error "Graphics.UI.SDL.Events.toSDLEvent: bad argument" + +-- |High level event structure. +data Event + = NoEvent + | GotFocus [Focus] + | LostFocus [Focus] + | KeyDown !Keysym + | KeyUp !Keysym + | MouseMotion !Word16 !Word16 !Word16 !Word16 + | MouseButtonDown !Word16 + !Word16 + !MouseButton + | MouseButtonUp !Word16 + !Word16 + !MouseButton + | JoyAxisMotion !Word8 !Word8 !Int16 + -- ^ device index, axis index, axis value. + | JoyBallMotion !Word8 !Word8 !Int16 !Int16 + -- ^ device index, trackball index, relative motion. + | JoyHatMotion !Word8 !Word8 !Word8 + -- ^ device index, hat index, hat position. + | JoyButtonDown !Word8 !Word8 + -- ^ device index, button index. + | JoyButtonUp !Word8 !Word8 + -- ^ device index, button index. + | VideoResize !Int !Int + -- ^ When @Resizable@ is passed as a flag to 'Graphics.UI.SDL.Video.setVideoMode' the user is + -- allowed to resize the applications window. When the window is resized + -- an @VideoResize@ is reported, with the new window width and height values. + -- When an @VideoResize@ is recieved the window should be resized to the + -- new dimensions using 'Graphics.UI.SDL.Video.setVideoMode'. + | VideoExpose + -- ^ A @VideoExpose@ event is triggered when the screen has been modified + -- outside of the application, usually by the window manager and needs to be redrawn. + | Quit + | User !UserEventID !Int !(Ptr ()) !(Ptr ()) + | Unknown + deriving (Show,Eq) + +data MouseButton + = ButtonLeft + | ButtonMiddle + | ButtonRight + | ButtonWheelUp + | ButtonWheelDown + deriving (Show,Eq,Ord) + +instance Enum MouseButton Word8 where + toEnum #{const SDL_BUTTON_LEFT} = ButtonLeft + toEnum #{const SDL_BUTTON_MIDDLE} = ButtonMiddle + toEnum #{const SDL_BUTTON_RIGHT} = ButtonRight + toEnum #{const SDL_BUTTON_WHEELUP} = ButtonWheelUp + toEnum #{const SDL_BUTTON_WHEELDOWN} = ButtonWheelDown + toEnum _ = error "Graphics.UI.SDL.Events.toEnum: bad argument" + fromEnum ButtonLeft = #{const SDL_BUTTON_LEFT} + fromEnum ButtonMiddle = #{const SDL_BUTTON_MIDDLE} + fromEnum ButtonRight = #{const SDL_BUTTON_RIGHT} + fromEnum ButtonWheelUp = #{const SDL_BUTTON_WHEELUP} + fromEnum ButtonWheelDown = #{const SDL_BUTTON_WHEELDOWN} + succ ButtonLeft = ButtonMiddle + succ ButtonMiddle = ButtonRight + succ ButtonRight = ButtonWheelUp + succ ButtonWheelUp = ButtonWheelDown + succ _ = error "Graphics.UI.SDL.Events.succ: bad argument" + pred ButtonMiddle = ButtonLeft + pred ButtonRight = ButtonMiddle + pred ButtonWheelUp = ButtonRight + pred ButtonWheelDown = ButtonWheelUp + pred _ = error "Graphics.UI.SDL.Events.pred: bad argument" + enumFromTo x y | x > y = [] + | x == y = [y] + | True = x : enumFromTo (succ x) y + + +data Focus + = MouseFocus + | InputFocus + | ApplicationFocus + deriving (Show,Eq,Ord) + +instance Bounded Focus where + minBound = MouseFocus + maxBound = ApplicationFocus + +instance Enum Focus Word8 where + fromEnum MouseFocus = #{const SDL_APPMOUSEFOCUS} + fromEnum InputFocus = #{const SDL_APPINPUTFOCUS} + fromEnum ApplicationFocus = #{const SDL_APPACTIVE} + toEnum #{const SDL_APPMOUSEFOCUS} = MouseFocus + toEnum #{const SDL_APPINPUTFOCUS} = InputFocus + toEnum #{const SDL_APPACTIVE} = ApplicationFocus + toEnum _ = error "Graphics.UI.SDL.Events.toEnum: bad argument" + succ MouseFocus = InputFocus + succ InputFocus = ApplicationFocus + succ _ = error "Graphics.UI.SDL.Events.succ: bad argument" + pred InputFocus = MouseFocus + pred ApplicationFocus = InputFocus + pred _ = error "Graphics.UI.SDL.Events.pred: bad argument" + enumFromTo x y | x > y = [] + | x == y = [y] + | True = x : enumFromTo (succ x) y + +-- |Typed user events ranging from 0 to 7 +data UserEventID + = UID0 | UID1 | UID2 | UID3 | UID4 | UID5 | UID6 | UID7 + deriving (Show,Eq,Prelude.Enum) + +-- |A safe pointer keeps the type of the object it was created from +-- and checks it when it's deconstructed. +type SafePtr = Ptr () + +-- |Constructs a safe pointer from an arbitrary value. +toSafePtr :: (Typeable a) => a -> IO SafePtr +toSafePtr val + = do stablePtr <- newStablePtr (typeOf val,val) + return (castStablePtrToPtr stablePtr) + +-- |Return the type of the object the safe pointer was created from. +typeOfSafePtr :: SafePtr -> IO TypeRep +typeOfSafePtr ptr + = fmap fst (deRefStablePtr (castPtrToStablePtr ptr)) + +-- |Get object from a safe pointer. @Nothing@ on type mismatch. +tryFromSafePtr :: (Typeable a) => SafePtr -> IO (Maybe a) +tryFromSafePtr ptr + = do (ty,val) <- deRefStablePtr (castPtrToStablePtr ptr) + if ty == typeOf val + then return (Just val) + else return Nothing + +-- |Get object from a safe pointer. Throws an exception on type mismatch. +fromSafePtr :: (Typeable a) => SafePtr -> IO a +fromSafePtr ptr + = do ret <- tryFromSafePtr ptr + case ret of + Nothing -> error "Graphics.UI.SDL.Events.fromSafePtr: invalid type." + Just a -> return a + +toEventType :: UserEventID -> Word8 +toEventType eid = fromIntegral (Prelude.fromEnum eid) + +fromEventType :: Word8 -> UserEventID +fromEventType etype = Prelude.toEnum (fromIntegral etype) + +peekActiveEvent :: Ptr Event -> IO Event +peekActiveEvent ptr + = do gain <- fmap toBool ((#{peek SDL_ActiveEvent, gain} ptr) :: IO Word8) + state <- #{peek SDL_ActiveEvent, state} ptr :: IO Word8 + return $! (if gain then GotFocus else LostFocus) (fromBitmask state) + +peekKey :: (Keysym -> Event) -> Ptr Event -> IO Event +peekKey mkEvent ptr + = do keysym <- #{peek SDL_KeyboardEvent, keysym} ptr + return $! mkEvent keysym + +peekMouseMotion :: Ptr Event -> IO Event +peekMouseMotion ptr + = do x <- #{peek SDL_MouseMotionEvent, x} ptr + y <- #{peek SDL_MouseMotionEvent, y} ptr + xrel <- #{peek SDL_MouseMotionEvent, xrel} ptr + yrel <- #{peek SDL_MouseMotionEvent, yrel} ptr + return $! MouseMotion x y xrel yrel + +peekMouse :: (Word16 -> Word16 -> MouseButton -> Event) -> Ptr Event -> IO Event +peekMouse mkEvent ptr + = do b <- #{peek SDL_MouseButtonEvent, button} ptr + x <- #{peek SDL_MouseButtonEvent, x} ptr + y <- #{peek SDL_MouseButtonEvent, y} ptr + return $! mkEvent x y (toEnum (b::Word8)) + +peekJoyAxisMotion :: Ptr Event -> IO Event +peekJoyAxisMotion ptr + = do which <- #{peek SDL_JoyAxisEvent, which} ptr + axis <- #{peek SDL_JoyAxisEvent, axis} ptr + value <- #{peek SDL_JoyAxisEvent, value} ptr + return $! JoyAxisMotion which axis value + +peekJoyBallMotion :: Ptr Event -> IO Event +peekJoyBallMotion ptr + = do which <- #{peek SDL_JoyBallEvent, which} ptr + ball <- #{peek SDL_JoyBallEvent, ball} ptr + xrel <- #{peek SDL_JoyBallEvent, xrel} ptr + yrel <- #{peek SDL_JoyBallEvent, yrel} ptr + return $! JoyBallMotion which ball xrel yrel + +peekJoyHatMotion :: Ptr Event -> IO Event +peekJoyHatMotion ptr + = do which <- #{peek SDL_JoyHatEvent, which} ptr + hat <- #{peek SDL_JoyHatEvent, hat} ptr + value <- #{peek SDL_JoyHatEvent, value} ptr + return $! JoyHatMotion which hat value + +peekJoyButton :: (Word8 -> Word8 -> Event) -> Ptr Event -> IO Event +peekJoyButton mkEvent ptr + = do which <- #{peek SDL_JoyButtonEvent, which} ptr + button <- #{peek SDL_JoyButtonEvent, button} ptr + return $! mkEvent which button + +peekResize :: Ptr Event -> IO Event +peekResize ptr + = do w <- #{peek SDL_ResizeEvent, w} ptr + h <- #{peek SDL_ResizeEvent, h} ptr + return $! VideoResize w h + +peekUserEvent :: Ptr Event -> Word8 -> IO Event +peekUserEvent ptr n + = do code <- #{peek SDL_UserEvent, code} ptr + data1 <- #{peek SDL_UserEvent, data1} ptr + data2 <- #{peek SDL_UserEvent, data2} ptr + return $ User (fromEventType n) code data1 data2 + +getEventType :: Event -> Word8 +getEventType = fromSDLEvent . eventToSDLEvent + +eventToSDLEvent :: Event -> SDLEvent +eventToSDLEvent NoEvent = SDLNoEvent +eventToSDLEvent (GotFocus _) = SDLActiveEvent +eventToSDLEvent (LostFocus _) = SDLActiveEvent +eventToSDLEvent (KeyDown _) = SDLKeyDown +eventToSDLEvent (KeyUp _) = SDLKeyUp +eventToSDLEvent (MouseMotion _ _ _ _) = SDLMouseMotion +eventToSDLEvent (MouseButtonDown _ _ _) = SDLMouseButtonDown +eventToSDLEvent (MouseButtonUp _ _ _) = SDLMouseButtonUp +eventToSDLEvent (JoyAxisMotion _ _ _) = SDLJoyAxisMotion +eventToSDLEvent (JoyBallMotion _ _ _ _) = SDLJoyBallMotion +eventToSDLEvent (JoyHatMotion _ _ _) = SDLJoyHatMotion +eventToSDLEvent (JoyButtonDown _ _) = SDLJoyButtonDown +eventToSDLEvent (JoyButtonUp _ _) = SDLJoyButtonUp +eventToSDLEvent Quit = SDLQuit +eventToSDLEvent (VideoResize _ _) = SDLVideoResize +eventToSDLEvent VideoExpose = SDLVideoExpose +eventToSDLEvent (User uid _ _ _) = SDLUserEvent (toEventType uid) +eventToSDLEvent _ = error "Graphics.UI.SDL.Events.eventToSDLEvent: bad argument" + +pokeActiveEvent :: Ptr Event -> Word8 -> [Focus] -> IO () +pokeActiveEvent ptr gain focus + = do #{poke SDL_ActiveEvent, gain} ptr gain + #{poke SDL_ActiveEvent, state} ptr (toBitmask focus) + +pokeKey :: Ptr Event -> Word8 -> Keysym -> IO () +pokeKey ptr state keysym + = do #{poke SDL_KeyboardEvent, state} ptr state + #{poke SDL_KeyboardEvent, keysym} ptr keysym + +pokeMouseMotion :: Ptr Event -> Word16 -> Word16 -> Word16 -> Word16 -> IO () +pokeMouseMotion ptr x y xrel yrel + = do #{poke SDL_MouseMotionEvent, x} ptr x + #{poke SDL_MouseMotionEvent, y} ptr y + #{poke SDL_MouseMotionEvent, xrel} ptr xrel + #{poke SDL_MouseMotionEvent, yrel} ptr yrel + +pokeMouseButton :: Ptr Event -> Word8 -> Word16 -> Word16 -> MouseButton -> IO () +pokeMouseButton ptr state x y b + = do #{poke SDL_MouseButtonEvent, x} ptr x + #{poke SDL_MouseButtonEvent, y} ptr y + #{poke SDL_MouseButtonEvent, state} ptr state + #{poke SDL_MouseButtonEvent, button} ptr (fromEnum b) + +pokeJoyAxisMotion :: Ptr Event -> Word8 -> Word8 -> Int16 -> IO () +pokeJoyAxisMotion ptr which axis value + = do #{poke SDL_JoyAxisEvent, which} ptr which + #{poke SDL_JoyAxisEvent, axis} ptr axis + #{poke SDL_JoyAxisEvent, value} ptr value + +pokeJoyBallMotion :: Ptr Event -> Word8 -> Word8 -> Int16 -> Int16 -> IO () +pokeJoyBallMotion ptr which ball xrel yrel + = do #{poke SDL_JoyBallEvent, which} ptr which + #{poke SDL_JoyBallEvent, ball} ptr ball + #{poke SDL_JoyBallEvent, xrel} ptr xrel + #{poke SDL_JoyBallEvent, yrel} ptr yrel + +pokeJoyHatMotion :: Ptr Event -> Word8 -> Word8 -> Word8 -> IO () +pokeJoyHatMotion ptr which hat value + = do #{poke SDL_JoyHatEvent, which} ptr which + #{poke SDL_JoyHatEvent, hat} ptr hat + #{poke SDL_JoyHatEvent, value} ptr value + +pokeJoyButton :: Ptr Event -> Word8 -> Word8 -> Word8 -> IO () +pokeJoyButton ptr which button state + = do #{poke SDL_JoyButtonEvent, which} ptr which + #{poke SDL_JoyButtonEvent, button} ptr button + #{poke SDL_JoyButtonEvent, state} ptr state + +pokeResize :: Ptr Event -> Int -> Int -> IO () +pokeResize ptr w h + = do #{poke SDL_ResizeEvent, w} ptr w + #{poke SDL_ResizeEvent, h} ptr h + +pokeUserEvent :: Ptr Event -> UserEventID -> Int -> Ptr () -> Ptr () -> IO () +pokeUserEvent ptr _eventId code data1 data2 + = do #{poke SDL_UserEvent, code} ptr code + #{poke SDL_UserEvent, data1} ptr data1 + #{poke SDL_UserEvent, data2} ptr data2 + +instance Storable Event where + sizeOf = const (#{size SDL_Event}) + alignment = const 4 + poke ptr event + = do pokeByteOff ptr 0 (getEventType event) + case event of + NoEvent -> return () + GotFocus focus -> pokeActiveEvent ptr 1 focus + LostFocus focus -> pokeActiveEvent ptr 0 focus + KeyDown keysym -> pokeKey ptr #{const SDL_PRESSED} keysym + KeyUp keysym -> pokeKey ptr #{const SDL_RELEASED} keysym + MouseMotion x y xrel yrel -> pokeMouseMotion ptr x y xrel yrel + MouseButtonDown x y b -> pokeMouseButton ptr #{const SDL_PRESSED} x y b + MouseButtonUp x y b -> pokeMouseButton ptr #{const SDL_RELEASED} x y b + JoyAxisMotion w a v -> pokeJoyAxisMotion ptr w a v + JoyBallMotion w b x y -> pokeJoyBallMotion ptr w b x y + JoyHatMotion w h v -> pokeJoyHatMotion ptr w h v + JoyButtonDown w b -> pokeJoyButton ptr w b #{const SDL_PRESSED} + JoyButtonUp w b -> pokeJoyButton ptr w b #{const SDL_RELEASED} + Quit -> return () + VideoResize w h -> pokeResize ptr w h + VideoExpose -> return () + User eventId c d1 d2 -> pokeUserEvent ptr eventId c d1 d2 + e -> failWithError $ "Unhandled eventtype: " ++ show e + peek ptr + = do eventType <- peekByteOff ptr 0 + case toSDLEvent eventType of + SDLNoEvent -> return NoEvent + SDLActiveEvent -> peekActiveEvent ptr + SDLKeyDown -> peekKey KeyDown ptr + SDLKeyUp -> peekKey KeyUp ptr + SDLMouseMotion -> peekMouseMotion ptr + SDLMouseButtonDown -> peekMouse MouseButtonDown ptr + SDLMouseButtonUp -> peekMouse MouseButtonUp ptr + SDLJoyAxisMotion -> peekJoyAxisMotion ptr + SDLJoyBallMotion -> peekJoyBallMotion ptr + SDLJoyHatMotion -> peekJoyHatMotion ptr + SDLJoyButtonDown -> peekJoyButton JoyButtonDown ptr + SDLJoyButtonUp -> peekJoyButton JoyButtonUp ptr + SDLQuit -> return Quit +-- SDLSysWMEvent + SDLVideoResize -> peekResize ptr + SDLVideoExpose -> return VideoExpose + SDLUserEvent n -> peekUserEvent ptr n +-- SDLNumEvents + e -> failWithError $ "Unhandled eventtype: " ++ show e + +-- int SDL_EnableKeyRepeat(int delay, int interval); +foreign import ccall unsafe "SDL_EnableKeyRepeat" sdlEnableKeyRepeat :: Int -> Int -> IO Int + +-- | Sets keyboard repeat rate. Returns @False@ on error. +enableKeyRepeat :: Int -- ^ Initial delay. @0@ to disable. + -> Int -- ^ Interval. + -> IO Bool +enableKeyRepeat delay interval + = intToBool (-1) (sdlEnableKeyRepeat delay interval) + +-- int SDL_EnableUNICODE(int enable); +foreign import ccall unsafe "SDL_EnableUNICODE" sdlEnableUnicode :: Int -> IO Int + +-- | Enables or disables unicode translation. +enableUnicode :: Bool -> IO () +enableUnicode enable = sdlEnableUnicode (fromToggle toggle) >> + return () + where toggle = case enable of + True -> Enable + False -> Disable + +-- | Returns the current state of unicode translation. See also 'enableUnicode'. +queryUnicodeState :: IO Bool +queryUnicodeState = fmap toBool (sdlEnableUnicode (fromToggle Query)) + +-- char *SDL_GetKeyName(SDLKey key); +foreign import ccall unsafe "SDL_GetKeyName" sdlGetKeyName :: #{type SDLKey} -> IO CString + +-- | Gets the name of an SDL virtual keysym. +getKeyName :: SDLKey -> String +getKeyName key = unsafePerformIO $ + sdlGetKeyName (fromEnum key) >>= peekCString + +-- SDLMod SDL_GetModState(void); +foreign import ccall unsafe "SDL_GetModState" sdlGetModState :: IO #{type SDLMod} + +-- | Gets the state of modifier keys. +getModState :: IO [Modifier] +getModState = fmap fromBitmask sdlGetModState + +-- void SDL_SetModState(SDLMod modstate); +foreign import ccall unsafe "SDL_SetModState" sdlSetModState :: #{type SDLMod} -> IO () + +-- | Sets the internal state of modifier keys. +setModState :: [Modifier] -> IO () +setModState = sdlSetModState . toBitmask + +mousePressed :: Word8 -> MouseButton -> Bool +mousePressed mask b + = mask .&. (1 `shiftL` num) /= 0 + where num = fromIntegral (fromEnum b) + + +-- Uint8 SDL_GetMouseState(int *x, int *y); +foreign import ccall "SDL_GetMouseState" sdlGetMouseState :: Ptr Int -> Ptr Int -> IO Word8 +foreign import ccall "SDL_GetRelativeMouseState" sdlGetRelativeMouseState :: Ptr Int -> Ptr Int -> IO Word8 + +-- | Retrieves the current state of the mouse. Returns (X position, Y position, pressed buttons). +getMouseState :: IO (Int, Int, [MouseButton]) +getMouseState = mouseStateGetter sdlGetMouseState + +-- | Retrieve the current state of the mouse. Like 'getMouseState' except that X and Y are +-- set to the change since last call to getRelativeMouseState. +getRelativeMouseState :: IO (Int, Int, [MouseButton]) +getRelativeMouseState = mouseStateGetter sdlGetRelativeMouseState + +mouseStateGetter :: (Ptr Int -> Ptr Int -> IO Word8) -> IO (Int, Int, [MouseButton]) +mouseStateGetter getter + = alloca $ \xPtr -> + alloca $ \yPtr -> + do ret <- getter xPtr yPtr + [x,y] <- mapM peek [xPtr,yPtr] + return (x,y,filter (mousePressed ret) [ButtonLeft + ,ButtonMiddle + ,ButtonRight + ,ButtonWheelUp + ,ButtonWheelDown]) + + + +-- int SDL_PollEvent(SDL_Event *event); +foreign import ccall "SDL_PollEvent" sdlPollEvent :: Ptr Event -> IO Int + +-- | Polls for currently pending events. +pollEvent :: IO Event +pollEvent + = alloca poll + where poll ptr + = do ret <- sdlPollEvent ptr + case ret of + 0 -> return NoEvent + _ -> do event <- peek ptr + case event of + NoEvent -> poll ptr + _ -> return event + +-- void SDL_PumpEvents(void); +-- | Pumps the event loop, gathering events from the input devices. +foreign import ccall unsafe "SDL_PumpEvents" pumpEvents :: IO () + +-- int SDL_PushEvent(SDL_Event *event); +foreign import ccall unsafe "SDL_PushEvent" sdlPushEvent :: Ptr Event -> IO Int + +-- | Pushes an event onto the event queue. Returns @False@ on error. +tryPushEvent :: Event -> IO Bool +tryPushEvent event + = new event >>= (fmap (0==) . sdlPushEvent) + +-- | Pushes an event onto the event queue. Throws an exception on error. +pushEvent :: Event -> IO () +pushEvent = unwrapBool "SDL_PushEvent" . tryPushEvent + +-- int SDL_WaitEvent(SDL_Event *event); +foreign import ccall unsafe "SDL_WaitEvent" sdlWaitEvent :: Ptr Event -> IO Int + +-- | Waits indefinitely for the next available event. +waitEvent :: IO Event +waitEvent + = loop + where loop = do pumpEvents + event <- pollEvent + case event of + NoEvent -> threadDelay 10 >> loop + _ -> return event + +-- | Waits indefinitely for the next available event. Blocks Haskell threads. +waitEventBlocking :: IO Event +waitEventBlocking + = alloca wait + where wait ptr + = do ret <- sdlWaitEvent ptr + case ret of + 0 -> failWithError "SDL_WaitEvent" + _ -> do event <- peek ptr + case event of + NoEvent -> wait ptr + _ -> return event + +-- Uint8 SDL_EventState(Uint8 type, int state); +foreign import ccall unsafe "SDL_EventState" sdlEventState :: Word8 -> Int -> IO Word8 + +-- |Enable or disable events from being processed. +enableEvent :: SDLEvent -> Bool -> IO () +enableEvent event on + = sdlEventState (fromSDLEvent event) (fromToggle state) >> return () + where state + | on = Enable + | otherwise = Disable + +-- |Checks current state of a event. See also 'enableEvent'. +queryEventState :: SDLEvent -> IO Bool +queryEventState event + = fmap (==1) (sdlEventState (fromSDLEvent event) (fromToggle Query)) + +-- Uint8 SDL_GetAppState(void); +foreign import ccall unsafe "SDL_GetAppState" sdlGetAppState :: IO Word8 + +-- | Gets the state of the application. +getAppState :: IO [Focus] +getAppState = fmap fromBitmask sdlGetAppState + diff --git a/Graphics/UI/SDL/General.hsc b/Graphics/UI/SDL/General.hsc new file mode 100644 --- /dev/null +++ b/Graphics/UI/SDL/General.hsc @@ -0,0 +1,160 @@ +#include "SDL.h" +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.SDL.General +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- +module Graphics.UI.SDL.General + ( init + , withInit + , initSubSystem + , quitSubSystem + , quit + , wasInit + , getError + , failWithError + , unwrapBool + , unwrapMaybe + , unwrapInt + , InitFlag(..) + ) where + +import Foreign.C (peekCString,CString) +import Data.Maybe (fromMaybe) +import Control.Monad (when) +import Data.Word (Word32) + +import Control.Exception (bracket_) + +import Prelude hiding (init,Enum(..)) + +import Graphics.UI.SDL.Utilities (Enum(..), toBitmask, fromBitmask) + + +data InitFlag = InitTimer + | InitAudio + | InitVideo + | InitCDROM + | InitJoystick + | InitNoParachute + | InitEventthread + | InitEverything + deriving (Eq, Ord, Show, Read) +instance Bounded InitFlag where + minBound = InitTimer + maxBound = InitEventthread + +instance Enum InitFlag Word32 where + fromEnum InitTimer = #{const SDL_INIT_TIMER} + fromEnum InitAudio = #{const SDL_INIT_AUDIO} + fromEnum InitVideo = #{const SDL_INIT_VIDEO} + fromEnum InitCDROM = #{const SDL_INIT_CDROM} + fromEnum InitJoystick = #{const SDL_INIT_JOYSTICK} + fromEnum InitNoParachute = #{const SDL_INIT_NOPARACHUTE} + fromEnum InitEventthread = #{const SDL_INIT_EVENTTHREAD} + fromEnum InitEverything = #{const SDL_INIT_EVERYTHING} + toEnum #{const SDL_INIT_TIMER} = InitTimer + toEnum #{const SDL_INIT_AUDIO} = InitAudio + toEnum #{const SDL_INIT_VIDEO}= InitVideo + toEnum #{const SDL_INIT_CDROM} = InitCDROM + toEnum #{const SDL_INIT_JOYSTICK} = InitJoystick + toEnum #{const SDL_INIT_NOPARACHUTE} = InitNoParachute + toEnum #{const SDL_INIT_EVENTTHREAD} = InitEventthread + toEnum #{const SDL_INIT_EVERYTHING} = InitEverything + toEnum _ = error "Graphics.UI.SDL.General.toEnum: bad argument" + succ InitTimer = InitAudio + succ InitAudio = InitVideo + succ InitVideo = InitCDROM + succ InitCDROM = InitJoystick + succ InitJoystick = InitNoParachute + succ InitNoParachute = InitEventthread + succ InitEventthread = InitEverything + succ _ = error "Graphics.UI.SDL.General.succ: bad argument" + pred InitAudio = InitTimer + pred InitVideo = InitAudio + pred InitCDROM = InitVideo + pred InitJoystick = InitCDROM + pred InitNoParachute = InitJoystick + pred InitEventthread = InitNoParachute + pred InitEverything = InitEventthread + pred _ = error "Graphics.UI.SDL.General.pred: bad argument" + enumFromTo x y | x > y = [] + | x == y = [y] + | True = x : enumFromTo (succ x) y + +unwrapMaybe :: String -> IO (Maybe a) -> IO a +unwrapMaybe errMsg action + = do val <- action + case val of + Just a -> return a + Nothing -> failWithError errMsg + +unwrapInt :: (Int -> Bool) -> String -> IO Int -> IO Int +unwrapInt fn errMsg action + = do val <- action + if fn val + then return val + else failWithError errMsg + +unwrapBool :: String -> IO Bool -> IO () +unwrapBool errMsg action + = do val <- action + case val of + True -> return () + False -> failWithError errMsg + +foreign import ccall unsafe "SDL_Init" sdlInit :: Word32 -> IO Int +-- | Initializes SDL. This should be called before all other SDL functions. +init :: [InitFlag] -> IO () +init flags + = do ret <- sdlInit (fromIntegral (toBitmask flags)) + when (ret == (-1)) (failWithError "SDL_Init") + +withInit :: [InitFlag] -> IO a -> IO a +withInit flags action + = bracket_ (init flags) quit action + +foreign import ccall unsafe "SDL_InitSubSystem" sdlInitSubSystem :: Word32 -> IO Int +-- | After SDL has been initialized with SDL_Init you may initialize +-- uninitialized subsystems with SDL_InitSubSystem. +initSubSystem :: [InitFlag] -> IO () +initSubSystem flags + = do ret <- sdlInitSubSystem (fromIntegral (toBitmask flags)) + when (ret == (-1)) (failWithError "SDL_InitSubSystem") + +foreign import ccall unsafe "SDL_QuitSubSystem" sdlQuitSubSystem :: Word32 -> IO () +quitSubSystem :: [InitFlag] -> IO () +quitSubSystem = sdlQuitSubSystem . fromIntegral . toBitmask + +foreign import ccall unsafe "SDL_Quit" sdlQuit :: IO () +quit :: IO () +quit = sdlQuit + +foreign import ccall unsafe "SDL_WasInit" sdlWasInit :: Word32 -> IO Word32 +-- | wasInit allows you to see which SDL subsytems have been initialized +wasInit :: [InitFlag] -> IO [InitFlag] +wasInit flags + = do ret <- sdlWasInit (fromIntegral (toBitmask flags)) + return (fromBitmask (fromIntegral ret)) + + +foreign import ccall unsafe "SDL_GetError" sdlGetError :: IO CString +-- | Returns a string containing the last error. Nothing if no error. +getError :: IO (Maybe String) +getError + = do str <- peekCString =<< sdlGetError + if null str + then return Nothing + else return (Just str) + +failWithError :: String -> IO a +failWithError msg + = do err <- fmap (fromMaybe "No SDL error") getError + ioError $ userError $ msg ++ "\nSDL message: " ++ err + diff --git a/Graphics/UI/SDL/Joystick.hsc b/Graphics/UI/SDL/Joystick.hsc new file mode 100644 --- /dev/null +++ b/Graphics/UI/SDL/Joystick.hsc @@ -0,0 +1,176 @@ +#include "SDL.h" +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.SDL.Joystick +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- +module Graphics.UI.SDL.Joystick + ( countAvailable + , tryName + , name + , tryOpen + , open + , opened + , index + , axesAvailable + , ballsAvailable + , hatsAvailable + , buttonsAvailable + , update + , getAxis + , getHat + , getButton + , getBall + , close + ) where + +import Foreign (Int16, Word8, Ptr, FunPtr, Storable(peek), unsafePerformIO, + finalizeForeignPtr, toBool, maybePeek, alloca, withForeignPtr, newForeignPtr) +import Foreign.C (peekCString, CString) + +import Graphics.UI.SDL.General (unwrapMaybe) +import Graphics.UI.SDL.Utilities (fromBitmask) +import Graphics.UI.SDL.Types (Hat, Joystick, JoystickStruct) + +type JoystickIndex = Int + +--int SDL_NumJoysticks(void); +-- | Counts the number of joysticks attached to the system. +foreign import ccall unsafe "SDL_NumJoysticks" countAvailable :: IO Int + +-- const char *SDL_JoystickName(int index); +foreign import ccall unsafe "SDL_JoystickName" sdlJoystickName :: JoystickIndex -> IO CString +-- | Gets joystick name. Returns @Nothing@ on error. +tryName :: JoystickIndex -> IO (Maybe String) +tryName idx = sdlJoystickName idx >>= maybePeek peekCString + +-- | Gets joystick name. Throws an exception on error. +name :: JoystickIndex -> IO String +name = unwrapMaybe "SDL_JoystickName" . tryName + +-- SDL_Joystick *SDL_JoystickOpen(int index); +foreign import ccall unsafe "SDL_JoystickOpen" sdlJoystickOpen :: JoystickIndex -> IO (Ptr JoystickStruct) +-- | Opens a joystick for use. Returns @Nothing@ on error. +tryOpen :: JoystickIndex -> IO (Maybe Joystick) +tryOpen idx = sdlJoystickOpen idx >>= maybePeek mkFinalizedJoystick + +-- | Opens a joystick for use. Throws an exception on error. +open :: JoystickIndex -> IO Joystick +open = unwrapMaybe "SDL_JoystickOpen" . tryOpen + +-- int SDL_JoystickOpened(int index); +foreign import ccall unsafe "SDL_JoystickOpened" sdlJoystickOpened :: JoystickIndex -> IO Int + +-- | Determines if a joystick has been opened. +opened :: JoystickIndex -> IO Bool +opened = fmap toBool . sdlJoystickOpened + +-- int SDL_JoystickIndex(SDL_Joystick *joystick); +foreign import ccall unsafe "SDL_JoystickIndex" sdlJoystickIndex :: Ptr JoystickStruct -> JoystickIndex +-- | Gets the index of an @Joystick@. +index :: Joystick -> JoystickIndex +index joystick + = unsafePerformIO $ + withForeignPtr joystick $ + return . sdlJoystickIndex + +-- int SDL_JoystickNumAxes(SDL_Joystick *joystick); +foreign import ccall unsafe "SDL_JoystickNumAxes" sdlJoystickNumAxes :: Ptr JoystickStruct -> Int +-- | Gets the number of joystick axes. +axesAvailable :: Joystick -> Int +axesAvailable joystick + = unsafePerformIO $ + withForeignPtr joystick $ + return . sdlJoystickNumAxes + +-- int SDL_JoystickNumBalls(SDL_Joystick *joystick); +foreign import ccall unsafe "SDL_JoystickNumBalls" sdlJoystickNumBalls :: Ptr JoystickStruct -> Int +-- | Gets the number of joystick trackballs. +ballsAvailable :: Joystick -> Int +ballsAvailable joystick + = unsafePerformIO $ + withForeignPtr joystick $ + return . sdlJoystickNumBalls + +-- int SDL_JoystickNumHats(SDL_Joystick *joystick); +foreign import ccall unsafe "SDL_JoystickNumHats" sdlJoystickNumHats :: Ptr JoystickStruct -> Int +-- | Gets the number of joystick hats. +hatsAvailable :: Joystick -> Int +hatsAvailable joystick + = unsafePerformIO $ + withForeignPtr joystick $ + return . sdlJoystickNumHats + +-- int SDL_JoystickNumButtons(SDL_Joystick *joystick); +foreign import ccall unsafe "SDL_JoystickNumButtons" sdlJoystickNumButtons :: Ptr JoystickStruct -> Int +-- | Gets the number of joystick buttons. +buttonsAvailable :: Joystick -> Int +buttonsAvailable joystick + = unsafePerformIO $ + withForeignPtr joystick $ + return . sdlJoystickNumButtons + +-- void SDL_JoystickUpdate(void); +-- | Updates the state of all joysticks. +foreign import ccall unsafe "SDL_JoystickUpdate" update :: IO () + +-- Sint16 SDL_JoystickGetAxis(SDL_Joystick *joystick, int axis); +foreign import ccall unsafe "SDL_JoystickGetAxis" joystickGetAxis :: Ptr JoystickStruct -> Int -> IO Int16 +-- | Gets the current state of an axis. +getAxis :: Joystick -> Word8 -> IO Int16 +getAxis joystick axis + = withForeignPtr joystick $ \ptr -> + joystickGetAxis ptr (fromIntegral axis) + +-- Uint8 SDL_JoystickGetHat(SDL_Joystick *joystick, int hat); +foreign import ccall unsafe "SDL_JoystickGetHat" joystickGetHat :: Ptr JoystickStruct -> Int -> IO Word8 +-- | Gets the current state of a joystick hat. +getHat :: Joystick -> Word8 -> IO [Hat] +getHat joystick axis + = withForeignPtr joystick $ \ptr -> + fmap (fromBitmask.fromIntegral) (joystickGetHat ptr (fromIntegral axis)) + +-- Uint8 SDL_JoystickGetButton(SDL_Joystick *joystick, int button); +foreign import ccall unsafe "SDL_JoystickGetButton" joystickGetButton :: Ptr JoystickStruct -> Int -> IO Word8 +-- | Gets the current state of a given button on a given joystick. +getButton :: Joystick -> Word8 -> IO Bool +getButton joystick button + = withForeignPtr joystick $ \ptr -> + fmap toBool (joystickGetButton ptr (fromIntegral button)) + +-- int SDL_JoystickGetBall(SDL_Joystick *joystick, int ball, int *dx, int *dy); +foreign import ccall unsafe "SDL_JoystickGetBall" joystickGetBall + :: Ptr JoystickStruct -> Int -> Ptr Int -> Ptr Int -> IO Int +-- | Gets relative trackball motion. +getBall :: Joystick -> Word8 -> IO (Maybe (Int16,Int16)) +getBall joystick ball + = withForeignPtr joystick $ \ptr -> + alloca $ \xrelPtr -> + alloca $ \yrelPtr -> + do ret <- joystickGetBall ptr (fromIntegral ball) xrelPtr yrelPtr + case ret of + 0 -> do [xrel,yrel] <- mapM (fmap fromIntegral . peek) [xrelPtr,yrelPtr] + return $! Just (xrel,yrel) + _ -> return Nothing + +-- | Force finalization of a previous opened @Joystick@. Only supported with GHC. +close :: Joystick -> IO () +close = +#if defined(__GLASGOW_HASKELL__) + finalizeForeignPtr +#else + const (return ()) +#endif + +-- void SDL_JoystickClose(SDL_Joystick *joystick); +foreign import ccall unsafe "&SDL_JoystickClose" sdlCloseJoystickFinal :: FunPtr (Ptr JoystickStruct -> IO ()) + +mkFinalizedJoystick :: Ptr JoystickStruct -> IO Joystick +mkFinalizedJoystick = newForeignPtr sdlCloseJoystickFinal + diff --git a/Graphics/UI/SDL/Keysym.hsc b/Graphics/UI/SDL/Keysym.hsc new file mode 100644 --- /dev/null +++ b/Graphics/UI/SDL/Keysym.hsc @@ -0,0 +1,1310 @@ +#include "SDL.h" +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.SDL.Keysym +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- +module Graphics.UI.SDL.Keysym where + +import Foreign (Word16, Word32, + Storable(poke, sizeOf, alignment, peekByteOff, pokeByteOff, peek)) +import Data.Char (chr, ord) +import Prelude hiding (Enum(..)) + +import Graphics.UI.SDL.Utilities (Enum(..), toBitmask, fromBitmask) + +data Keysym + = Keysym + { symKey :: SDLKey, + symModifiers :: [Modifier], + symUnicode :: Char} + deriving (Show,Eq) + +instance Storable Keysym where + sizeOf = const #{size SDL_keysym} + alignment = const 4 + poke ptr (Keysym key mods unicode) + = do #{poke SDL_keysym, sym} ptr (fromEnum key) + #{poke SDL_keysym, mod} ptr (toBitmask mods) + #{poke SDL_keysym, unicode} ptr (fromIntegral (ord unicode) :: Word16) + peek ptr + = do sym <- #{peek SDL_keysym, sym} ptr + mods <- #{peek SDL_keysym, mod} ptr + uni <- #{peek SDL_keysym, unicode} ptr + return $! Keysym (toEnum sym) (fromBitmask mods) (chr $ fromIntegral (uni::Word16)) + + +data Modifier = KeyModNone + | KeyModLeftShift + | KeyModRightShift + | KeyModLeftCtrl + | KeyModRightCtrl + | KeyModLeftAlt + | KeyModRightAlt + | KeyModLeftMeta + | KeyModRightMeta + | KeyModNum + | KeyModCaps + | KeyModMode + | KeyModCtrl + | KeyModShift + | KeyModAlt + | KeyModMeta + deriving (Eq, Ord, Show) +instance Bounded Modifier where + minBound = KeyModNone + maxBound = KeyModMode +instance Enum Modifier #{type SDLMod} where + fromEnum KeyModNone = 0 + fromEnum KeyModLeftShift = 1 + fromEnum KeyModRightShift = 2 + fromEnum KeyModLeftCtrl = 64 + fromEnum KeyModRightCtrl = 128 + fromEnum KeyModLeftAlt = 256 + fromEnum KeyModRightAlt = 512 + fromEnum KeyModLeftMeta = 1024 + fromEnum KeyModRightMeta = 2048 + fromEnum KeyModNum = 4096 + fromEnum KeyModCaps = 8192 + fromEnum KeyModMode = 16384 + fromEnum KeyModCtrl = 192 + fromEnum KeyModShift = 3 + fromEnum KeyModAlt = 768 + fromEnum KeyModMeta = 3072 + toEnum 0 = KeyModNone + toEnum 1 = KeyModLeftShift + toEnum 2 = KeyModRightShift + toEnum 64 = KeyModLeftCtrl + toEnum 128 = KeyModRightCtrl + toEnum 256 = KeyModLeftAlt + toEnum 512 = KeyModRightAlt + toEnum 1024 = KeyModLeftMeta + toEnum 2048 = KeyModRightMeta + toEnum 4096 = KeyModNum + toEnum 8192 = KeyModCaps + toEnum 16384 = KeyModMode + toEnum 192 = KeyModCtrl + toEnum 3 = KeyModShift + toEnum 768 = KeyModAlt + toEnum 3072 = KeyModMeta + toEnum _ = error "Graphics.UI.SDL.Keysym.toEnum: bad argument" + succ KeyModNone = KeyModLeftShift + succ KeyModLeftShift = KeyModRightShift + succ KeyModRightShift = KeyModLeftCtrl + succ KeyModLeftCtrl = KeyModRightCtrl + succ KeyModRightCtrl = KeyModLeftAlt + succ KeyModLeftAlt = KeyModRightAlt + succ KeyModRightAlt = KeyModLeftMeta + succ KeyModLeftMeta = KeyModRightMeta + succ KeyModRightMeta = KeyModNum + succ KeyModNum = KeyModCaps + succ KeyModCaps = KeyModMode + succ KeyModMode = KeyModCtrl + succ KeyModCtrl = KeyModShift + succ KeyModShift = KeyModAlt + succ KeyModAlt = KeyModMeta + succ _ = error "Graphics.UI.SDL.Keysym.succ: bad argument" + pred KeyModLeftShift = KeyModNone + pred KeyModRightShift = KeyModLeftShift + pred KeyModLeftCtrl = KeyModRightShift + pred KeyModRightCtrl = KeyModLeftCtrl + pred KeyModLeftAlt = KeyModRightCtrl + pred KeyModRightAlt = KeyModLeftAlt + pred KeyModLeftMeta = KeyModRightAlt + pred KeyModRightMeta = KeyModLeftMeta + pred KeyModNum = KeyModRightMeta + pred KeyModCaps = KeyModNum + pred KeyModMode = KeyModCaps + pred KeyModCtrl = KeyModMode + pred KeyModShift = KeyModCtrl + pred KeyModAlt = KeyModShift + pred KeyModMeta = KeyModAlt + pred _ = error "Graphics.UI.SDL.Keysym.pred: bad argument" + enumFromTo x y | x > y = [] + | x == y = [y] + | True = x : enumFromTo (succ x) y + +data SDLKey = SDLK_UNKNOWN + | SDLK_FIRST + | SDLK_BACKSPACE + | SDLK_TAB + | SDLK_CLEAR + | SDLK_RETURN + | SDLK_PAUSE + | SDLK_ESCAPE + | SDLK_SPACE + | SDLK_EXCLAIM + | SDLK_QUOTEDBL + | SDLK_HASH + | SDLK_DOLLAR + | SDLK_AMPERSAND + | SDLK_QUOTE + | SDLK_LEFTPAREN + | SDLK_RIGHTPAREN + | SDLK_ASTERISK + | SDLK_PLUS + | SDLK_COMMA + | SDLK_MINUS + | SDLK_PERIOD + | SDLK_SLASH + | SDLK_0 + | SDLK_1 + | SDLK_2 + | SDLK_3 + | SDLK_4 + | SDLK_5 + | SDLK_6 + | SDLK_7 + | SDLK_8 + | SDLK_9 + | SDLK_COLON + | SDLK_SEMICOLON + | SDLK_LESS + | SDLK_EQUALS + | SDLK_GREATER + | SDLK_QUESTION + | SDLK_AT + | SDLK_LEFTBRACKET + | SDLK_BACKSLASH + | SDLK_RIGHTBRACKET + | SDLK_CARET + | SDLK_UNDERSCORE + | SDLK_BACKQUOTE + | SDLK_a + | SDLK_b + | SDLK_c + | SDLK_d + | SDLK_e + | SDLK_f + | SDLK_g + | SDLK_h + | SDLK_i + | SDLK_j + | SDLK_k + | SDLK_l + | SDLK_m + | SDLK_n + | SDLK_o + | SDLK_p + | SDLK_q + | SDLK_r + | SDLK_s + | SDLK_t + | SDLK_u + | SDLK_v + | SDLK_w + | SDLK_x + | SDLK_y + | SDLK_z + | SDLK_DELETE + | SDLK_WORLD_0 + | SDLK_WORLD_1 + | SDLK_WORLD_2 + | SDLK_WORLD_3 + | SDLK_WORLD_4 + | SDLK_WORLD_5 + | SDLK_WORLD_6 + | SDLK_WORLD_7 + | SDLK_WORLD_8 + | SDLK_WORLD_9 + | SDLK_WORLD_10 + | SDLK_WORLD_11 + | SDLK_WORLD_12 + | SDLK_WORLD_13 + | SDLK_WORLD_14 + | SDLK_WORLD_15 + | SDLK_WORLD_16 + | SDLK_WORLD_17 + | SDLK_WORLD_18 + | SDLK_WORLD_19 + | SDLK_WORLD_20 + | SDLK_WORLD_21 + | SDLK_WORLD_22 + | SDLK_WORLD_23 + | SDLK_WORLD_24 + | SDLK_WORLD_25 + | SDLK_WORLD_26 + | SDLK_WORLD_27 + | SDLK_WORLD_28 + | SDLK_WORLD_29 + | SDLK_WORLD_30 + | SDLK_WORLD_31 + | SDLK_WORLD_32 + | SDLK_WORLD_33 + | SDLK_WORLD_34 + | SDLK_WORLD_35 + | SDLK_WORLD_36 + | SDLK_WORLD_37 + | SDLK_WORLD_38 + | SDLK_WORLD_39 + | SDLK_WORLD_40 + | SDLK_WORLD_41 + | SDLK_WORLD_42 + | SDLK_WORLD_43 + | SDLK_WORLD_44 + | SDLK_WORLD_45 + | SDLK_WORLD_46 + | SDLK_WORLD_47 + | SDLK_WORLD_48 + | SDLK_WORLD_49 + | SDLK_WORLD_50 + | SDLK_WORLD_51 + | SDLK_WORLD_52 + | SDLK_WORLD_53 + | SDLK_WORLD_54 + | SDLK_WORLD_55 + | SDLK_WORLD_56 + | SDLK_WORLD_57 + | SDLK_WORLD_58 + | SDLK_WORLD_59 + | SDLK_WORLD_60 + | SDLK_WORLD_61 + | SDLK_WORLD_62 + | SDLK_WORLD_63 + | SDLK_WORLD_64 + | SDLK_WORLD_65 + | SDLK_WORLD_66 + | SDLK_WORLD_67 + | SDLK_WORLD_68 + | SDLK_WORLD_69 + | SDLK_WORLD_70 + | SDLK_WORLD_71 + | SDLK_WORLD_72 + | SDLK_WORLD_73 + | SDLK_WORLD_74 + | SDLK_WORLD_75 + | SDLK_WORLD_76 + | SDLK_WORLD_77 + | SDLK_WORLD_78 + | SDLK_WORLD_79 + | SDLK_WORLD_80 + | SDLK_WORLD_81 + | SDLK_WORLD_82 + | SDLK_WORLD_83 + | SDLK_WORLD_84 + | SDLK_WORLD_85 + | SDLK_WORLD_86 + | SDLK_WORLD_87 + | SDLK_WORLD_88 + | SDLK_WORLD_89 + | SDLK_WORLD_90 + | SDLK_WORLD_91 + | SDLK_WORLD_92 + | SDLK_WORLD_93 + | SDLK_WORLD_94 + | SDLK_WORLD_95 + | SDLK_KP0 + | SDLK_KP1 + | SDLK_KP2 + | SDLK_KP3 + | SDLK_KP4 + | SDLK_KP5 + | SDLK_KP6 + | SDLK_KP7 + | SDLK_KP8 + | SDLK_KP9 + | SDLK_KP_PERIOD + | SDLK_KP_DIVIDE + | SDLK_KP_MULTIPLY + | SDLK_KP_MINUS + | SDLK_KP_PLUS + | SDLK_KP_ENTER + | SDLK_KP_EQUALS + | SDLK_UP + | SDLK_DOWN + | SDLK_RIGHT + | SDLK_LEFT + | SDLK_INSERT + | SDLK_HOME + | SDLK_END + | SDLK_PAGEUP + | SDLK_PAGEDOWN + | SDLK_F1 + | SDLK_F2 + | SDLK_F3 + | SDLK_F4 + | SDLK_F5 + | SDLK_F6 + | SDLK_F7 + | SDLK_F8 + | SDLK_F9 + | SDLK_F10 + | SDLK_F11 + | SDLK_F12 + | SDLK_F13 + | SDLK_F14 + | SDLK_F15 + | SDLK_NUMLOCK + | SDLK_CAPSLOCK + | SDLK_SCROLLOCK + | SDLK_RSHIFT + | SDLK_LSHIFT + | SDLK_RCTRL + | SDLK_LCTRL + | SDLK_RALT + | SDLK_LALT + | SDLK_RMETA + | SDLK_LMETA + | SDLK_LSUPER + | SDLK_RSUPER + | SDLK_MODE + | SDLK_COMPOSE + | SDLK_HELP + | SDLK_PRINT + | SDLK_SYSREQ + | SDLK_BREAK + | SDLK_MENU + | SDLK_POWER + | SDLK_EURO + | SDLK_UNDO + | SDLK_LAST + deriving (Eq, Ord, Show) +instance Bounded SDLKey where + minBound = SDLK_UNKNOWN + maxBound = SDLK_LAST +instance Enum SDLKey #{type SDLMod} where + fromEnum SDLK_UNKNOWN = 0 + fromEnum SDLK_FIRST = 0 + fromEnum SDLK_BACKSPACE = 8 + fromEnum SDLK_TAB = 9 + fromEnum SDLK_CLEAR = 12 + fromEnum SDLK_RETURN = 13 + fromEnum SDLK_PAUSE = 19 + fromEnum SDLK_ESCAPE = 27 + fromEnum SDLK_SPACE = 32 + fromEnum SDLK_EXCLAIM = 33 + fromEnum SDLK_QUOTEDBL = 34 + fromEnum SDLK_HASH = 35 + fromEnum SDLK_DOLLAR = 36 + fromEnum SDLK_AMPERSAND = 38 + fromEnum SDLK_QUOTE = 39 + fromEnum SDLK_LEFTPAREN = 40 + fromEnum SDLK_RIGHTPAREN = 41 + fromEnum SDLK_ASTERISK = 42 + fromEnum SDLK_PLUS = 43 + fromEnum SDLK_COMMA = 44 + fromEnum SDLK_MINUS = 45 + fromEnum SDLK_PERIOD = 46 + fromEnum SDLK_SLASH = 47 + fromEnum SDLK_0 = 48 + fromEnum SDLK_1 = 49 + fromEnum SDLK_2 = 50 + fromEnum SDLK_3 = 51 + fromEnum SDLK_4 = 52 + fromEnum SDLK_5 = 53 + fromEnum SDLK_6 = 54 + fromEnum SDLK_7 = 55 + fromEnum SDLK_8 = 56 + fromEnum SDLK_9 = 57 + fromEnum SDLK_COLON = 58 + fromEnum SDLK_SEMICOLON = 59 + fromEnum SDLK_LESS = 60 + fromEnum SDLK_EQUALS = 61 + fromEnum SDLK_GREATER = 62 + fromEnum SDLK_QUESTION = 63 + fromEnum SDLK_AT = 64 + fromEnum SDLK_LEFTBRACKET = 91 + fromEnum SDLK_BACKSLASH = 92 + fromEnum SDLK_RIGHTBRACKET = 93 + fromEnum SDLK_CARET = 94 + fromEnum SDLK_UNDERSCORE = 95 + fromEnum SDLK_BACKQUOTE = 96 + fromEnum SDLK_a = 97 + fromEnum SDLK_b = 98 + fromEnum SDLK_c = 99 + fromEnum SDLK_d = 100 + fromEnum SDLK_e = 101 + fromEnum SDLK_f = 102 + fromEnum SDLK_g = 103 + fromEnum SDLK_h = 104 + fromEnum SDLK_i = 105 + fromEnum SDLK_j = 106 + fromEnum SDLK_k = 107 + fromEnum SDLK_l = 108 + fromEnum SDLK_m = 109 + fromEnum SDLK_n = 110 + fromEnum SDLK_o = 111 + fromEnum SDLK_p = 112 + fromEnum SDLK_q = 113 + fromEnum SDLK_r = 114 + fromEnum SDLK_s = 115 + fromEnum SDLK_t = 116 + fromEnum SDLK_u = 117 + fromEnum SDLK_v = 118 + fromEnum SDLK_w = 119 + fromEnum SDLK_x = 120 + fromEnum SDLK_y = 121 + fromEnum SDLK_z = 122 + fromEnum SDLK_DELETE = 127 + fromEnum SDLK_WORLD_0 = 160 + fromEnum SDLK_WORLD_1 = 161 + fromEnum SDLK_WORLD_2 = 162 + fromEnum SDLK_WORLD_3 = 163 + fromEnum SDLK_WORLD_4 = 164 + fromEnum SDLK_WORLD_5 = 165 + fromEnum SDLK_WORLD_6 = 166 + fromEnum SDLK_WORLD_7 = 167 + fromEnum SDLK_WORLD_8 = 168 + fromEnum SDLK_WORLD_9 = 169 + fromEnum SDLK_WORLD_10 = 170 + fromEnum SDLK_WORLD_11 = 171 + fromEnum SDLK_WORLD_12 = 172 + fromEnum SDLK_WORLD_13 = 173 + fromEnum SDLK_WORLD_14 = 174 + fromEnum SDLK_WORLD_15 = 175 + fromEnum SDLK_WORLD_16 = 176 + fromEnum SDLK_WORLD_17 = 177 + fromEnum SDLK_WORLD_18 = 178 + fromEnum SDLK_WORLD_19 = 179 + fromEnum SDLK_WORLD_20 = 180 + fromEnum SDLK_WORLD_21 = 181 + fromEnum SDLK_WORLD_22 = 182 + fromEnum SDLK_WORLD_23 = 183 + fromEnum SDLK_WORLD_24 = 184 + fromEnum SDLK_WORLD_25 = 185 + fromEnum SDLK_WORLD_26 = 186 + fromEnum SDLK_WORLD_27 = 187 + fromEnum SDLK_WORLD_28 = 188 + fromEnum SDLK_WORLD_29 = 189 + fromEnum SDLK_WORLD_30 = 190 + fromEnum SDLK_WORLD_31 = 191 + fromEnum SDLK_WORLD_32 = 192 + fromEnum SDLK_WORLD_33 = 193 + fromEnum SDLK_WORLD_34 = 194 + fromEnum SDLK_WORLD_35 = 195 + fromEnum SDLK_WORLD_36 = 196 + fromEnum SDLK_WORLD_37 = 197 + fromEnum SDLK_WORLD_38 = 198 + fromEnum SDLK_WORLD_39 = 199 + fromEnum SDLK_WORLD_40 = 200 + fromEnum SDLK_WORLD_41 = 201 + fromEnum SDLK_WORLD_42 = 202 + fromEnum SDLK_WORLD_43 = 203 + fromEnum SDLK_WORLD_44 = 204 + fromEnum SDLK_WORLD_45 = 205 + fromEnum SDLK_WORLD_46 = 206 + fromEnum SDLK_WORLD_47 = 207 + fromEnum SDLK_WORLD_48 = 208 + fromEnum SDLK_WORLD_49 = 209 + fromEnum SDLK_WORLD_50 = 210 + fromEnum SDLK_WORLD_51 = 211 + fromEnum SDLK_WORLD_52 = 212 + fromEnum SDLK_WORLD_53 = 213 + fromEnum SDLK_WORLD_54 = 214 + fromEnum SDLK_WORLD_55 = 215 + fromEnum SDLK_WORLD_56 = 216 + fromEnum SDLK_WORLD_57 = 217 + fromEnum SDLK_WORLD_58 = 218 + fromEnum SDLK_WORLD_59 = 219 + fromEnum SDLK_WORLD_60 = 220 + fromEnum SDLK_WORLD_61 = 221 + fromEnum SDLK_WORLD_62 = 222 + fromEnum SDLK_WORLD_63 = 223 + fromEnum SDLK_WORLD_64 = 224 + fromEnum SDLK_WORLD_65 = 225 + fromEnum SDLK_WORLD_66 = 226 + fromEnum SDLK_WORLD_67 = 227 + fromEnum SDLK_WORLD_68 = 228 + fromEnum SDLK_WORLD_69 = 229 + fromEnum SDLK_WORLD_70 = 230 + fromEnum SDLK_WORLD_71 = 231 + fromEnum SDLK_WORLD_72 = 232 + fromEnum SDLK_WORLD_73 = 233 + fromEnum SDLK_WORLD_74 = 234 + fromEnum SDLK_WORLD_75 = 235 + fromEnum SDLK_WORLD_76 = 236 + fromEnum SDLK_WORLD_77 = 237 + fromEnum SDLK_WORLD_78 = 238 + fromEnum SDLK_WORLD_79 = 239 + fromEnum SDLK_WORLD_80 = 240 + fromEnum SDLK_WORLD_81 = 241 + fromEnum SDLK_WORLD_82 = 242 + fromEnum SDLK_WORLD_83 = 243 + fromEnum SDLK_WORLD_84 = 244 + fromEnum SDLK_WORLD_85 = 245 + fromEnum SDLK_WORLD_86 = 246 + fromEnum SDLK_WORLD_87 = 247 + fromEnum SDLK_WORLD_88 = 248 + fromEnum SDLK_WORLD_89 = 249 + fromEnum SDLK_WORLD_90 = 250 + fromEnum SDLK_WORLD_91 = 251 + fromEnum SDLK_WORLD_92 = 252 + fromEnum SDLK_WORLD_93 = 253 + fromEnum SDLK_WORLD_94 = 254 + fromEnum SDLK_WORLD_95 = 255 + fromEnum SDLK_KP0 = 256 + fromEnum SDLK_KP1 = 257 + fromEnum SDLK_KP2 = 258 + fromEnum SDLK_KP3 = 259 + fromEnum SDLK_KP4 = 260 + fromEnum SDLK_KP5 = 261 + fromEnum SDLK_KP6 = 262 + fromEnum SDLK_KP7 = 263 + fromEnum SDLK_KP8 = 264 + fromEnum SDLK_KP9 = 265 + fromEnum SDLK_KP_PERIOD = 266 + fromEnum SDLK_KP_DIVIDE = 267 + fromEnum SDLK_KP_MULTIPLY = 268 + fromEnum SDLK_KP_MINUS = 269 + fromEnum SDLK_KP_PLUS = 270 + fromEnum SDLK_KP_ENTER = 271 + fromEnum SDLK_KP_EQUALS = 272 + fromEnum SDLK_UP = 273 + fromEnum SDLK_DOWN = 274 + fromEnum SDLK_RIGHT = 275 + fromEnum SDLK_LEFT = 276 + fromEnum SDLK_INSERT = 277 + fromEnum SDLK_HOME = 278 + fromEnum SDLK_END = 279 + fromEnum SDLK_PAGEUP = 280 + fromEnum SDLK_PAGEDOWN = 281 + fromEnum SDLK_F1 = 282 + fromEnum SDLK_F2 = 283 + fromEnum SDLK_F3 = 284 + fromEnum SDLK_F4 = 285 + fromEnum SDLK_F5 = 286 + fromEnum SDLK_F6 = 287 + fromEnum SDLK_F7 = 288 + fromEnum SDLK_F8 = 289 + fromEnum SDLK_F9 = 290 + fromEnum SDLK_F10 = 291 + fromEnum SDLK_F11 = 292 + fromEnum SDLK_F12 = 293 + fromEnum SDLK_F13 = 294 + fromEnum SDLK_F14 = 295 + fromEnum SDLK_F15 = 296 + fromEnum SDLK_NUMLOCK = 300 + fromEnum SDLK_CAPSLOCK = 301 + fromEnum SDLK_SCROLLOCK = 302 + fromEnum SDLK_RSHIFT = 303 + fromEnum SDLK_LSHIFT = 304 + fromEnum SDLK_RCTRL = 305 + fromEnum SDLK_LCTRL = 306 + fromEnum SDLK_RALT = 307 + fromEnum SDLK_LALT = 308 + fromEnum SDLK_RMETA = 309 + fromEnum SDLK_LMETA = 310 + fromEnum SDLK_LSUPER = 311 + fromEnum SDLK_RSUPER = 312 + fromEnum SDLK_MODE = 313 + fromEnum SDLK_COMPOSE = 314 + fromEnum SDLK_HELP = 315 + fromEnum SDLK_PRINT = 316 + fromEnum SDLK_SYSREQ = 317 + fromEnum SDLK_BREAK = 318 + fromEnum SDLK_MENU = 319 + fromEnum SDLK_POWER = 320 + fromEnum SDLK_EURO = 321 + fromEnum SDLK_UNDO = 322 + fromEnum SDLK_LAST = 323 + toEnum 0 = SDLK_UNKNOWN + toEnum 8 = SDLK_BACKSPACE + toEnum 9 = SDLK_TAB + toEnum 12 = SDLK_CLEAR + toEnum 13 = SDLK_RETURN + toEnum 19 = SDLK_PAUSE + toEnum 27 = SDLK_ESCAPE + toEnum 32 = SDLK_SPACE + toEnum 33 = SDLK_EXCLAIM + toEnum 34 = SDLK_QUOTEDBL + toEnum 35 = SDLK_HASH + toEnum 36 = SDLK_DOLLAR + toEnum 38 = SDLK_AMPERSAND + toEnum 39 = SDLK_QUOTE + toEnum 40 = SDLK_LEFTPAREN + toEnum 41 = SDLK_RIGHTPAREN + toEnum 42 = SDLK_ASTERISK + toEnum 43 = SDLK_PLUS + toEnum 44 = SDLK_COMMA + toEnum 45 = SDLK_MINUS + toEnum 46 = SDLK_PERIOD + toEnum 47 = SDLK_SLASH + toEnum 48 = SDLK_0 + toEnum 49 = SDLK_1 + toEnum 50 = SDLK_2 + toEnum 51 = SDLK_3 + toEnum 52 = SDLK_4 + toEnum 53 = SDLK_5 + toEnum 54 = SDLK_6 + toEnum 55 = SDLK_7 + toEnum 56 = SDLK_8 + toEnum 57 = SDLK_9 + toEnum 58 = SDLK_COLON + toEnum 59 = SDLK_SEMICOLON + toEnum 60 = SDLK_LESS + toEnum 61 = SDLK_EQUALS + toEnum 62 = SDLK_GREATER + toEnum 63 = SDLK_QUESTION + toEnum 64 = SDLK_AT + toEnum 91 = SDLK_LEFTBRACKET + toEnum 92 = SDLK_BACKSLASH + toEnum 93 = SDLK_RIGHTBRACKET + toEnum 94 = SDLK_CARET + toEnum 95 = SDLK_UNDERSCORE + toEnum 96 = SDLK_BACKQUOTE + toEnum 97 = SDLK_a + toEnum 98 = SDLK_b + toEnum 99 = SDLK_c + toEnum 100 = SDLK_d + toEnum 101 = SDLK_e + toEnum 102 = SDLK_f + toEnum 103 = SDLK_g + toEnum 104 = SDLK_h + toEnum 105 = SDLK_i + toEnum 106 = SDLK_j + toEnum 107 = SDLK_k + toEnum 108 = SDLK_l + toEnum 109 = SDLK_m + toEnum 110 = SDLK_n + toEnum 111 = SDLK_o + toEnum 112 = SDLK_p + toEnum 113 = SDLK_q + toEnum 114 = SDLK_r + toEnum 115 = SDLK_s + toEnum 116 = SDLK_t + toEnum 117 = SDLK_u + toEnum 118 = SDLK_v + toEnum 119 = SDLK_w + toEnum 120 = SDLK_x + toEnum 121 = SDLK_y + toEnum 122 = SDLK_z + toEnum 127 = SDLK_DELETE + toEnum 160 = SDLK_WORLD_0 + toEnum 161 = SDLK_WORLD_1 + toEnum 162 = SDLK_WORLD_2 + toEnum 163 = SDLK_WORLD_3 + toEnum 164 = SDLK_WORLD_4 + toEnum 165 = SDLK_WORLD_5 + toEnum 166 = SDLK_WORLD_6 + toEnum 167 = SDLK_WORLD_7 + toEnum 168 = SDLK_WORLD_8 + toEnum 169 = SDLK_WORLD_9 + toEnum 170 = SDLK_WORLD_10 + toEnum 171 = SDLK_WORLD_11 + toEnum 172 = SDLK_WORLD_12 + toEnum 173 = SDLK_WORLD_13 + toEnum 174 = SDLK_WORLD_14 + toEnum 175 = SDLK_WORLD_15 + toEnum 176 = SDLK_WORLD_16 + toEnum 177 = SDLK_WORLD_17 + toEnum 178 = SDLK_WORLD_18 + toEnum 179 = SDLK_WORLD_19 + toEnum 180 = SDLK_WORLD_20 + toEnum 181 = SDLK_WORLD_21 + toEnum 182 = SDLK_WORLD_22 + toEnum 183 = SDLK_WORLD_23 + toEnum 184 = SDLK_WORLD_24 + toEnum 185 = SDLK_WORLD_25 + toEnum 186 = SDLK_WORLD_26 + toEnum 187 = SDLK_WORLD_27 + toEnum 188 = SDLK_WORLD_28 + toEnum 189 = SDLK_WORLD_29 + toEnum 190 = SDLK_WORLD_30 + toEnum 191 = SDLK_WORLD_31 + toEnum 192 = SDLK_WORLD_32 + toEnum 193 = SDLK_WORLD_33 + toEnum 194 = SDLK_WORLD_34 + toEnum 195 = SDLK_WORLD_35 + toEnum 196 = SDLK_WORLD_36 + toEnum 197 = SDLK_WORLD_37 + toEnum 198 = SDLK_WORLD_38 + toEnum 199 = SDLK_WORLD_39 + toEnum 200 = SDLK_WORLD_40 + toEnum 201 = SDLK_WORLD_41 + toEnum 202 = SDLK_WORLD_42 + toEnum 203 = SDLK_WORLD_43 + toEnum 204 = SDLK_WORLD_44 + toEnum 205 = SDLK_WORLD_45 + toEnum 206 = SDLK_WORLD_46 + toEnum 207 = SDLK_WORLD_47 + toEnum 208 = SDLK_WORLD_48 + toEnum 209 = SDLK_WORLD_49 + toEnum 210 = SDLK_WORLD_50 + toEnum 211 = SDLK_WORLD_51 + toEnum 212 = SDLK_WORLD_52 + toEnum 213 = SDLK_WORLD_53 + toEnum 214 = SDLK_WORLD_54 + toEnum 215 = SDLK_WORLD_55 + toEnum 216 = SDLK_WORLD_56 + toEnum 217 = SDLK_WORLD_57 + toEnum 218 = SDLK_WORLD_58 + toEnum 219 = SDLK_WORLD_59 + toEnum 220 = SDLK_WORLD_60 + toEnum 221 = SDLK_WORLD_61 + toEnum 222 = SDLK_WORLD_62 + toEnum 223 = SDLK_WORLD_63 + toEnum 224 = SDLK_WORLD_64 + toEnum 225 = SDLK_WORLD_65 + toEnum 226 = SDLK_WORLD_66 + toEnum 227 = SDLK_WORLD_67 + toEnum 228 = SDLK_WORLD_68 + toEnum 229 = SDLK_WORLD_69 + toEnum 230 = SDLK_WORLD_70 + toEnum 231 = SDLK_WORLD_71 + toEnum 232 = SDLK_WORLD_72 + toEnum 233 = SDLK_WORLD_73 + toEnum 234 = SDLK_WORLD_74 + toEnum 235 = SDLK_WORLD_75 + toEnum 236 = SDLK_WORLD_76 + toEnum 237 = SDLK_WORLD_77 + toEnum 238 = SDLK_WORLD_78 + toEnum 239 = SDLK_WORLD_79 + toEnum 240 = SDLK_WORLD_80 + toEnum 241 = SDLK_WORLD_81 + toEnum 242 = SDLK_WORLD_82 + toEnum 243 = SDLK_WORLD_83 + toEnum 244 = SDLK_WORLD_84 + toEnum 245 = SDLK_WORLD_85 + toEnum 246 = SDLK_WORLD_86 + toEnum 247 = SDLK_WORLD_87 + toEnum 248 = SDLK_WORLD_88 + toEnum 249 = SDLK_WORLD_89 + toEnum 250 = SDLK_WORLD_90 + toEnum 251 = SDLK_WORLD_91 + toEnum 252 = SDLK_WORLD_92 + toEnum 253 = SDLK_WORLD_93 + toEnum 254 = SDLK_WORLD_94 + toEnum 255 = SDLK_WORLD_95 + toEnum 256 = SDLK_KP0 + toEnum 257 = SDLK_KP1 + toEnum 258 = SDLK_KP2 + toEnum 259 = SDLK_KP3 + toEnum 260 = SDLK_KP4 + toEnum 261 = SDLK_KP5 + toEnum 262 = SDLK_KP6 + toEnum 263 = SDLK_KP7 + toEnum 264 = SDLK_KP8 + toEnum 265 = SDLK_KP9 + toEnum 266 = SDLK_KP_PERIOD + toEnum 267 = SDLK_KP_DIVIDE + toEnum 268 = SDLK_KP_MULTIPLY + toEnum 269 = SDLK_KP_MINUS + toEnum 270 = SDLK_KP_PLUS + toEnum 271 = SDLK_KP_ENTER + toEnum 272 = SDLK_KP_EQUALS + toEnum 273 = SDLK_UP + toEnum 274 = SDLK_DOWN + toEnum 275 = SDLK_RIGHT + toEnum 276 = SDLK_LEFT + toEnum 277 = SDLK_INSERT + toEnum 278 = SDLK_HOME + toEnum 279 = SDLK_END + toEnum 280 = SDLK_PAGEUP + toEnum 281 = SDLK_PAGEDOWN + toEnum 282 = SDLK_F1 + toEnum 283 = SDLK_F2 + toEnum 284 = SDLK_F3 + toEnum 285 = SDLK_F4 + toEnum 286 = SDLK_F5 + toEnum 287 = SDLK_F6 + toEnum 288 = SDLK_F7 + toEnum 289 = SDLK_F8 + toEnum 290 = SDLK_F9 + toEnum 291 = SDLK_F10 + toEnum 292 = SDLK_F11 + toEnum 293 = SDLK_F12 + toEnum 294 = SDLK_F13 + toEnum 295 = SDLK_F14 + toEnum 296 = SDLK_F15 + toEnum 300 = SDLK_NUMLOCK + toEnum 301 = SDLK_CAPSLOCK + toEnum 302 = SDLK_SCROLLOCK + toEnum 303 = SDLK_RSHIFT + toEnum 304 = SDLK_LSHIFT + toEnum 305 = SDLK_RCTRL + toEnum 306 = SDLK_LCTRL + toEnum 307 = SDLK_RALT + toEnum 308 = SDLK_LALT + toEnum 309 = SDLK_RMETA + toEnum 310 = SDLK_LMETA + toEnum 311 = SDLK_LSUPER + toEnum 312 = SDLK_RSUPER + toEnum 313 = SDLK_MODE + toEnum 314 = SDLK_COMPOSE + toEnum 315 = SDLK_HELP + toEnum 316 = SDLK_PRINT + toEnum 317 = SDLK_SYSREQ + toEnum 318 = SDLK_BREAK + toEnum 319 = SDLK_MENU + toEnum 320 = SDLK_POWER + toEnum 321 = SDLK_EURO + toEnum 322 = SDLK_UNDO + toEnum 323 = SDLK_LAST + toEnum _ = error "Graphics.UI.SDL.Keysym.toEnum: bad argument" + succ SDLK_UNKNOWN = SDLK_FIRST + succ SDLK_FIRST = SDLK_BACKSPACE + succ SDLK_BACKSPACE = SDLK_TAB + succ SDLK_TAB = SDLK_CLEAR + succ SDLK_CLEAR = SDLK_RETURN + succ SDLK_RETURN = SDLK_PAUSE + succ SDLK_PAUSE = SDLK_ESCAPE + succ SDLK_ESCAPE = SDLK_SPACE + succ SDLK_SPACE = SDLK_EXCLAIM + succ SDLK_EXCLAIM = SDLK_QUOTEDBL + succ SDLK_QUOTEDBL = SDLK_HASH + succ SDLK_HASH = SDLK_DOLLAR + succ SDLK_DOLLAR = SDLK_AMPERSAND + succ SDLK_AMPERSAND = SDLK_QUOTE + succ SDLK_QUOTE = SDLK_LEFTPAREN + succ SDLK_LEFTPAREN = SDLK_RIGHTPAREN + succ SDLK_RIGHTPAREN = SDLK_ASTERISK + succ SDLK_ASTERISK = SDLK_PLUS + succ SDLK_PLUS = SDLK_COMMA + succ SDLK_COMMA = SDLK_MINUS + succ SDLK_MINUS = SDLK_PERIOD + succ SDLK_PERIOD = SDLK_SLASH + succ SDLK_SLASH = SDLK_0 + succ SDLK_0 = SDLK_1 + succ SDLK_1 = SDLK_2 + succ SDLK_2 = SDLK_3 + succ SDLK_3 = SDLK_4 + succ SDLK_4 = SDLK_5 + succ SDLK_5 = SDLK_6 + succ SDLK_6 = SDLK_7 + succ SDLK_7 = SDLK_8 + succ SDLK_8 = SDLK_9 + succ SDLK_9 = SDLK_COLON + succ SDLK_COLON = SDLK_SEMICOLON + succ SDLK_SEMICOLON = SDLK_LESS + succ SDLK_LESS = SDLK_EQUALS + succ SDLK_EQUALS = SDLK_GREATER + succ SDLK_GREATER = SDLK_QUESTION + succ SDLK_QUESTION = SDLK_AT + succ SDLK_AT = SDLK_LEFTBRACKET + succ SDLK_LEFTBRACKET = SDLK_BACKSLASH + succ SDLK_BACKSLASH = SDLK_RIGHTBRACKET + succ SDLK_RIGHTBRACKET = SDLK_CARET + succ SDLK_CARET = SDLK_UNDERSCORE + succ SDLK_UNDERSCORE = SDLK_BACKQUOTE + succ SDLK_BACKQUOTE = SDLK_a + succ SDLK_a = SDLK_b + succ SDLK_b = SDLK_c + succ SDLK_c = SDLK_d + succ SDLK_d = SDLK_e + succ SDLK_e = SDLK_f + succ SDLK_f = SDLK_g + succ SDLK_g = SDLK_h + succ SDLK_h = SDLK_i + succ SDLK_i = SDLK_j + succ SDLK_j = SDLK_k + succ SDLK_k = SDLK_l + succ SDLK_l = SDLK_m + succ SDLK_m = SDLK_n + succ SDLK_n = SDLK_o + succ SDLK_o = SDLK_p + succ SDLK_p = SDLK_q + succ SDLK_q = SDLK_r + succ SDLK_r = SDLK_s + succ SDLK_s = SDLK_t + succ SDLK_t = SDLK_u + succ SDLK_u = SDLK_v + succ SDLK_v = SDLK_w + succ SDLK_w = SDLK_x + succ SDLK_x = SDLK_y + succ SDLK_y = SDLK_z + succ SDLK_z = SDLK_DELETE + succ SDLK_DELETE = SDLK_WORLD_0 + succ SDLK_WORLD_0 = SDLK_WORLD_1 + succ SDLK_WORLD_1 = SDLK_WORLD_2 + succ SDLK_WORLD_2 = SDLK_WORLD_3 + succ SDLK_WORLD_3 = SDLK_WORLD_4 + succ SDLK_WORLD_4 = SDLK_WORLD_5 + succ SDLK_WORLD_5 = SDLK_WORLD_6 + succ SDLK_WORLD_6 = SDLK_WORLD_7 + succ SDLK_WORLD_7 = SDLK_WORLD_8 + succ SDLK_WORLD_8 = SDLK_WORLD_9 + succ SDLK_WORLD_9 = SDLK_WORLD_10 + succ SDLK_WORLD_10 = SDLK_WORLD_11 + succ SDLK_WORLD_11 = SDLK_WORLD_12 + succ SDLK_WORLD_12 = SDLK_WORLD_13 + succ SDLK_WORLD_13 = SDLK_WORLD_14 + succ SDLK_WORLD_14 = SDLK_WORLD_15 + succ SDLK_WORLD_15 = SDLK_WORLD_16 + succ SDLK_WORLD_16 = SDLK_WORLD_17 + succ SDLK_WORLD_17 = SDLK_WORLD_18 + succ SDLK_WORLD_18 = SDLK_WORLD_19 + succ SDLK_WORLD_19 = SDLK_WORLD_20 + succ SDLK_WORLD_20 = SDLK_WORLD_21 + succ SDLK_WORLD_21 = SDLK_WORLD_22 + succ SDLK_WORLD_22 = SDLK_WORLD_23 + succ SDLK_WORLD_23 = SDLK_WORLD_24 + succ SDLK_WORLD_24 = SDLK_WORLD_25 + succ SDLK_WORLD_25 = SDLK_WORLD_26 + succ SDLK_WORLD_26 = SDLK_WORLD_27 + succ SDLK_WORLD_27 = SDLK_WORLD_28 + succ SDLK_WORLD_28 = SDLK_WORLD_29 + succ SDLK_WORLD_29 = SDLK_WORLD_30 + succ SDLK_WORLD_30 = SDLK_WORLD_31 + succ SDLK_WORLD_31 = SDLK_WORLD_32 + succ SDLK_WORLD_32 = SDLK_WORLD_33 + succ SDLK_WORLD_33 = SDLK_WORLD_34 + succ SDLK_WORLD_34 = SDLK_WORLD_35 + succ SDLK_WORLD_35 = SDLK_WORLD_36 + succ SDLK_WORLD_36 = SDLK_WORLD_37 + succ SDLK_WORLD_37 = SDLK_WORLD_38 + succ SDLK_WORLD_38 = SDLK_WORLD_39 + succ SDLK_WORLD_39 = SDLK_WORLD_40 + succ SDLK_WORLD_40 = SDLK_WORLD_41 + succ SDLK_WORLD_41 = SDLK_WORLD_42 + succ SDLK_WORLD_42 = SDLK_WORLD_43 + succ SDLK_WORLD_43 = SDLK_WORLD_44 + succ SDLK_WORLD_44 = SDLK_WORLD_45 + succ SDLK_WORLD_45 = SDLK_WORLD_46 + succ SDLK_WORLD_46 = SDLK_WORLD_47 + succ SDLK_WORLD_47 = SDLK_WORLD_48 + succ SDLK_WORLD_48 = SDLK_WORLD_49 + succ SDLK_WORLD_49 = SDLK_WORLD_50 + succ SDLK_WORLD_50 = SDLK_WORLD_51 + succ SDLK_WORLD_51 = SDLK_WORLD_52 + succ SDLK_WORLD_52 = SDLK_WORLD_53 + succ SDLK_WORLD_53 = SDLK_WORLD_54 + succ SDLK_WORLD_54 = SDLK_WORLD_55 + succ SDLK_WORLD_55 = SDLK_WORLD_56 + succ SDLK_WORLD_56 = SDLK_WORLD_57 + succ SDLK_WORLD_57 = SDLK_WORLD_58 + succ SDLK_WORLD_58 = SDLK_WORLD_59 + succ SDLK_WORLD_59 = SDLK_WORLD_60 + succ SDLK_WORLD_60 = SDLK_WORLD_61 + succ SDLK_WORLD_61 = SDLK_WORLD_62 + succ SDLK_WORLD_62 = SDLK_WORLD_63 + succ SDLK_WORLD_63 = SDLK_WORLD_64 + succ SDLK_WORLD_64 = SDLK_WORLD_65 + succ SDLK_WORLD_65 = SDLK_WORLD_66 + succ SDLK_WORLD_66 = SDLK_WORLD_67 + succ SDLK_WORLD_67 = SDLK_WORLD_68 + succ SDLK_WORLD_68 = SDLK_WORLD_69 + succ SDLK_WORLD_69 = SDLK_WORLD_70 + succ SDLK_WORLD_70 = SDLK_WORLD_71 + succ SDLK_WORLD_71 = SDLK_WORLD_72 + succ SDLK_WORLD_72 = SDLK_WORLD_73 + succ SDLK_WORLD_73 = SDLK_WORLD_74 + succ SDLK_WORLD_74 = SDLK_WORLD_75 + succ SDLK_WORLD_75 = SDLK_WORLD_76 + succ SDLK_WORLD_76 = SDLK_WORLD_77 + succ SDLK_WORLD_77 = SDLK_WORLD_78 + succ SDLK_WORLD_78 = SDLK_WORLD_79 + succ SDLK_WORLD_79 = SDLK_WORLD_80 + succ SDLK_WORLD_80 = SDLK_WORLD_81 + succ SDLK_WORLD_81 = SDLK_WORLD_82 + succ SDLK_WORLD_82 = SDLK_WORLD_83 + succ SDLK_WORLD_83 = SDLK_WORLD_84 + succ SDLK_WORLD_84 = SDLK_WORLD_85 + succ SDLK_WORLD_85 = SDLK_WORLD_86 + succ SDLK_WORLD_86 = SDLK_WORLD_87 + succ SDLK_WORLD_87 = SDLK_WORLD_88 + succ SDLK_WORLD_88 = SDLK_WORLD_89 + succ SDLK_WORLD_89 = SDLK_WORLD_90 + succ SDLK_WORLD_90 = SDLK_WORLD_91 + succ SDLK_WORLD_91 = SDLK_WORLD_92 + succ SDLK_WORLD_92 = SDLK_WORLD_93 + succ SDLK_WORLD_93 = SDLK_WORLD_94 + succ SDLK_WORLD_94 = SDLK_WORLD_95 + succ SDLK_WORLD_95 = SDLK_KP0 + succ SDLK_KP0 = SDLK_KP1 + succ SDLK_KP1 = SDLK_KP2 + succ SDLK_KP2 = SDLK_KP3 + succ SDLK_KP3 = SDLK_KP4 + succ SDLK_KP4 = SDLK_KP5 + succ SDLK_KP5 = SDLK_KP6 + succ SDLK_KP6 = SDLK_KP7 + succ SDLK_KP7 = SDLK_KP8 + succ SDLK_KP8 = SDLK_KP9 + succ SDLK_KP9 = SDLK_KP_PERIOD + succ SDLK_KP_PERIOD = SDLK_KP_DIVIDE + succ SDLK_KP_DIVIDE = SDLK_KP_MULTIPLY + succ SDLK_KP_MULTIPLY = SDLK_KP_MINUS + succ SDLK_KP_MINUS = SDLK_KP_PLUS + succ SDLK_KP_PLUS = SDLK_KP_ENTER + succ SDLK_KP_ENTER = SDLK_KP_EQUALS + succ SDLK_KP_EQUALS = SDLK_UP + succ SDLK_UP = SDLK_DOWN + succ SDLK_DOWN = SDLK_RIGHT + succ SDLK_RIGHT = SDLK_LEFT + succ SDLK_LEFT = SDLK_INSERT + succ SDLK_INSERT = SDLK_HOME + succ SDLK_HOME = SDLK_END + succ SDLK_END = SDLK_PAGEUP + succ SDLK_PAGEUP = SDLK_PAGEDOWN + succ SDLK_PAGEDOWN = SDLK_F1 + succ SDLK_F1 = SDLK_F2 + succ SDLK_F2 = SDLK_F3 + succ SDLK_F3 = SDLK_F4 + succ SDLK_F4 = SDLK_F5 + succ SDLK_F5 = SDLK_F6 + succ SDLK_F6 = SDLK_F7 + succ SDLK_F7 = SDLK_F8 + succ SDLK_F8 = SDLK_F9 + succ SDLK_F9 = SDLK_F10 + succ SDLK_F10 = SDLK_F11 + succ SDLK_F11 = SDLK_F12 + succ SDLK_F12 = SDLK_F13 + succ SDLK_F13 = SDLK_F14 + succ SDLK_F14 = SDLK_F15 + succ SDLK_F15 = SDLK_NUMLOCK + succ SDLK_NUMLOCK = SDLK_CAPSLOCK + succ SDLK_CAPSLOCK = SDLK_SCROLLOCK + succ SDLK_SCROLLOCK = SDLK_RSHIFT + succ SDLK_RSHIFT = SDLK_LSHIFT + succ SDLK_LSHIFT = SDLK_RCTRL + succ SDLK_RCTRL = SDLK_LCTRL + succ SDLK_LCTRL = SDLK_RALT + succ SDLK_RALT = SDLK_LALT + succ SDLK_LALT = SDLK_RMETA + succ SDLK_RMETA = SDLK_LMETA + succ SDLK_LMETA = SDLK_LSUPER + succ SDLK_LSUPER = SDLK_RSUPER + succ SDLK_RSUPER = SDLK_MODE + succ SDLK_MODE = SDLK_COMPOSE + succ SDLK_COMPOSE = SDLK_HELP + succ SDLK_HELP = SDLK_PRINT + succ SDLK_PRINT = SDLK_SYSREQ + succ SDLK_SYSREQ = SDLK_BREAK + succ SDLK_BREAK = SDLK_MENU + succ SDLK_MENU = SDLK_POWER + succ SDLK_POWER = SDLK_EURO + succ SDLK_EURO = SDLK_UNDO + succ SDLK_UNDO = SDLK_LAST + succ _ = error "Graphics.UI.SDL.Keysym.succ: bad argument" + pred SDLK_FIRST = SDLK_UNKNOWN + pred SDLK_BACKSPACE = SDLK_FIRST + pred SDLK_TAB = SDLK_BACKSPACE + pred SDLK_CLEAR = SDLK_TAB + pred SDLK_RETURN = SDLK_CLEAR + pred SDLK_PAUSE = SDLK_RETURN + pred SDLK_ESCAPE = SDLK_PAUSE + pred SDLK_SPACE = SDLK_ESCAPE + pred SDLK_EXCLAIM = SDLK_SPACE + pred SDLK_QUOTEDBL = SDLK_EXCLAIM + pred SDLK_HASH = SDLK_QUOTEDBL + pred SDLK_DOLLAR = SDLK_HASH + pred SDLK_AMPERSAND = SDLK_DOLLAR + pred SDLK_QUOTE = SDLK_AMPERSAND + pred SDLK_LEFTPAREN = SDLK_QUOTE + pred SDLK_RIGHTPAREN = SDLK_LEFTPAREN + pred SDLK_ASTERISK = SDLK_RIGHTPAREN + pred SDLK_PLUS = SDLK_ASTERISK + pred SDLK_COMMA = SDLK_PLUS + pred SDLK_MINUS = SDLK_COMMA + pred SDLK_PERIOD = SDLK_MINUS + pred SDLK_SLASH = SDLK_PERIOD + pred SDLK_0 = SDLK_SLASH + pred SDLK_1 = SDLK_0 + pred SDLK_2 = SDLK_1 + pred SDLK_3 = SDLK_2 + pred SDLK_4 = SDLK_3 + pred SDLK_5 = SDLK_4 + pred SDLK_6 = SDLK_5 + pred SDLK_7 = SDLK_6 + pred SDLK_8 = SDLK_7 + pred SDLK_9 = SDLK_8 + pred SDLK_COLON = SDLK_9 + pred SDLK_SEMICOLON = SDLK_COLON + pred SDLK_LESS = SDLK_SEMICOLON + pred SDLK_EQUALS = SDLK_LESS + pred SDLK_GREATER = SDLK_EQUALS + pred SDLK_QUESTION = SDLK_GREATER + pred SDLK_AT = SDLK_QUESTION + pred SDLK_LEFTBRACKET = SDLK_AT + pred SDLK_BACKSLASH = SDLK_LEFTBRACKET + pred SDLK_RIGHTBRACKET = SDLK_BACKSLASH + pred SDLK_CARET = SDLK_RIGHTBRACKET + pred SDLK_UNDERSCORE = SDLK_CARET + pred SDLK_BACKQUOTE = SDLK_UNDERSCORE + pred SDLK_a = SDLK_BACKQUOTE + pred SDLK_b = SDLK_a + pred SDLK_c = SDLK_b + pred SDLK_d = SDLK_c + pred SDLK_e = SDLK_d + pred SDLK_f = SDLK_e + pred SDLK_g = SDLK_f + pred SDLK_h = SDLK_g + pred SDLK_i = SDLK_h + pred SDLK_j = SDLK_i + pred SDLK_k = SDLK_j + pred SDLK_l = SDLK_k + pred SDLK_m = SDLK_l + pred SDLK_n = SDLK_m + pred SDLK_o = SDLK_n + pred SDLK_p = SDLK_o + pred SDLK_q = SDLK_p + pred SDLK_r = SDLK_q + pred SDLK_s = SDLK_r + pred SDLK_t = SDLK_s + pred SDLK_u = SDLK_t + pred SDLK_v = SDLK_u + pred SDLK_w = SDLK_v + pred SDLK_x = SDLK_w + pred SDLK_y = SDLK_x + pred SDLK_z = SDLK_y + pred SDLK_DELETE = SDLK_z + pred SDLK_WORLD_0 = SDLK_DELETE + pred SDLK_WORLD_1 = SDLK_WORLD_0 + pred SDLK_WORLD_2 = SDLK_WORLD_1 + pred SDLK_WORLD_3 = SDLK_WORLD_2 + pred SDLK_WORLD_4 = SDLK_WORLD_3 + pred SDLK_WORLD_5 = SDLK_WORLD_4 + pred SDLK_WORLD_6 = SDLK_WORLD_5 + pred SDLK_WORLD_7 = SDLK_WORLD_6 + pred SDLK_WORLD_8 = SDLK_WORLD_7 + pred SDLK_WORLD_9 = SDLK_WORLD_8 + pred SDLK_WORLD_10 = SDLK_WORLD_9 + pred SDLK_WORLD_11 = SDLK_WORLD_10 + pred SDLK_WORLD_12 = SDLK_WORLD_11 + pred SDLK_WORLD_13 = SDLK_WORLD_12 + pred SDLK_WORLD_14 = SDLK_WORLD_13 + pred SDLK_WORLD_15 = SDLK_WORLD_14 + pred SDLK_WORLD_16 = SDLK_WORLD_15 + pred SDLK_WORLD_17 = SDLK_WORLD_16 + pred SDLK_WORLD_18 = SDLK_WORLD_17 + pred SDLK_WORLD_19 = SDLK_WORLD_18 + pred SDLK_WORLD_20 = SDLK_WORLD_19 + pred SDLK_WORLD_21 = SDLK_WORLD_20 + pred SDLK_WORLD_22 = SDLK_WORLD_21 + pred SDLK_WORLD_23 = SDLK_WORLD_22 + pred SDLK_WORLD_24 = SDLK_WORLD_23 + pred SDLK_WORLD_25 = SDLK_WORLD_24 + pred SDLK_WORLD_26 = SDLK_WORLD_25 + pred SDLK_WORLD_27 = SDLK_WORLD_26 + pred SDLK_WORLD_28 = SDLK_WORLD_27 + pred SDLK_WORLD_29 = SDLK_WORLD_28 + pred SDLK_WORLD_30 = SDLK_WORLD_29 + pred SDLK_WORLD_31 = SDLK_WORLD_30 + pred SDLK_WORLD_32 = SDLK_WORLD_31 + pred SDLK_WORLD_33 = SDLK_WORLD_32 + pred SDLK_WORLD_34 = SDLK_WORLD_33 + pred SDLK_WORLD_35 = SDLK_WORLD_34 + pred SDLK_WORLD_36 = SDLK_WORLD_35 + pred SDLK_WORLD_37 = SDLK_WORLD_36 + pred SDLK_WORLD_38 = SDLK_WORLD_37 + pred SDLK_WORLD_39 = SDLK_WORLD_38 + pred SDLK_WORLD_40 = SDLK_WORLD_39 + pred SDLK_WORLD_41 = SDLK_WORLD_40 + pred SDLK_WORLD_42 = SDLK_WORLD_41 + pred SDLK_WORLD_43 = SDLK_WORLD_42 + pred SDLK_WORLD_44 = SDLK_WORLD_43 + pred SDLK_WORLD_45 = SDLK_WORLD_44 + pred SDLK_WORLD_46 = SDLK_WORLD_45 + pred SDLK_WORLD_47 = SDLK_WORLD_46 + pred SDLK_WORLD_48 = SDLK_WORLD_47 + pred SDLK_WORLD_49 = SDLK_WORLD_48 + pred SDLK_WORLD_50 = SDLK_WORLD_49 + pred SDLK_WORLD_51 = SDLK_WORLD_50 + pred SDLK_WORLD_52 = SDLK_WORLD_51 + pred SDLK_WORLD_53 = SDLK_WORLD_52 + pred SDLK_WORLD_54 = SDLK_WORLD_53 + pred SDLK_WORLD_55 = SDLK_WORLD_54 + pred SDLK_WORLD_56 = SDLK_WORLD_55 + pred SDLK_WORLD_57 = SDLK_WORLD_56 + pred SDLK_WORLD_58 = SDLK_WORLD_57 + pred SDLK_WORLD_59 = SDLK_WORLD_58 + pred SDLK_WORLD_60 = SDLK_WORLD_59 + pred SDLK_WORLD_61 = SDLK_WORLD_60 + pred SDLK_WORLD_62 = SDLK_WORLD_61 + pred SDLK_WORLD_63 = SDLK_WORLD_62 + pred SDLK_WORLD_64 = SDLK_WORLD_63 + pred SDLK_WORLD_65 = SDLK_WORLD_64 + pred SDLK_WORLD_66 = SDLK_WORLD_65 + pred SDLK_WORLD_67 = SDLK_WORLD_66 + pred SDLK_WORLD_68 = SDLK_WORLD_67 + pred SDLK_WORLD_69 = SDLK_WORLD_68 + pred SDLK_WORLD_70 = SDLK_WORLD_69 + pred SDLK_WORLD_71 = SDLK_WORLD_70 + pred SDLK_WORLD_72 = SDLK_WORLD_71 + pred SDLK_WORLD_73 = SDLK_WORLD_72 + pred SDLK_WORLD_74 = SDLK_WORLD_73 + pred SDLK_WORLD_75 = SDLK_WORLD_74 + pred SDLK_WORLD_76 = SDLK_WORLD_75 + pred SDLK_WORLD_77 = SDLK_WORLD_76 + pred SDLK_WORLD_78 = SDLK_WORLD_77 + pred SDLK_WORLD_79 = SDLK_WORLD_78 + pred SDLK_WORLD_80 = SDLK_WORLD_79 + pred SDLK_WORLD_81 = SDLK_WORLD_80 + pred SDLK_WORLD_82 = SDLK_WORLD_81 + pred SDLK_WORLD_83 = SDLK_WORLD_82 + pred SDLK_WORLD_84 = SDLK_WORLD_83 + pred SDLK_WORLD_85 = SDLK_WORLD_84 + pred SDLK_WORLD_86 = SDLK_WORLD_85 + pred SDLK_WORLD_87 = SDLK_WORLD_86 + pred SDLK_WORLD_88 = SDLK_WORLD_87 + pred SDLK_WORLD_89 = SDLK_WORLD_88 + pred SDLK_WORLD_90 = SDLK_WORLD_89 + pred SDLK_WORLD_91 = SDLK_WORLD_90 + pred SDLK_WORLD_92 = SDLK_WORLD_91 + pred SDLK_WORLD_93 = SDLK_WORLD_92 + pred SDLK_WORLD_94 = SDLK_WORLD_93 + pred SDLK_WORLD_95 = SDLK_WORLD_94 + pred SDLK_KP0 = SDLK_WORLD_95 + pred SDLK_KP1 = SDLK_KP0 + pred SDLK_KP2 = SDLK_KP1 + pred SDLK_KP3 = SDLK_KP2 + pred SDLK_KP4 = SDLK_KP3 + pred SDLK_KP5 = SDLK_KP4 + pred SDLK_KP6 = SDLK_KP5 + pred SDLK_KP7 = SDLK_KP6 + pred SDLK_KP8 = SDLK_KP7 + pred SDLK_KP9 = SDLK_KP8 + pred SDLK_KP_PERIOD = SDLK_KP9 + pred SDLK_KP_DIVIDE = SDLK_KP_PERIOD + pred SDLK_KP_MULTIPLY = SDLK_KP_DIVIDE + pred SDLK_KP_MINUS = SDLK_KP_MULTIPLY + pred SDLK_KP_PLUS = SDLK_KP_MINUS + pred SDLK_KP_ENTER = SDLK_KP_PLUS + pred SDLK_KP_EQUALS = SDLK_KP_ENTER + pred SDLK_UP = SDLK_KP_EQUALS + pred SDLK_DOWN = SDLK_UP + pred SDLK_RIGHT = SDLK_DOWN + pred SDLK_LEFT = SDLK_RIGHT + pred SDLK_INSERT = SDLK_LEFT + pred SDLK_HOME = SDLK_INSERT + pred SDLK_END = SDLK_HOME + pred SDLK_PAGEUP = SDLK_END + pred SDLK_PAGEDOWN = SDLK_PAGEUP + pred SDLK_F1 = SDLK_PAGEDOWN + pred SDLK_F2 = SDLK_F1 + pred SDLK_F3 = SDLK_F2 + pred SDLK_F4 = SDLK_F3 + pred SDLK_F5 = SDLK_F4 + pred SDLK_F6 = SDLK_F5 + pred SDLK_F7 = SDLK_F6 + pred SDLK_F8 = SDLK_F7 + pred SDLK_F9 = SDLK_F8 + pred SDLK_F10 = SDLK_F9 + pred SDLK_F11 = SDLK_F10 + pred SDLK_F12 = SDLK_F11 + pred SDLK_F13 = SDLK_F12 + pred SDLK_F14 = SDLK_F13 + pred SDLK_F15 = SDLK_F14 + pred SDLK_NUMLOCK = SDLK_F15 + pred SDLK_CAPSLOCK = SDLK_NUMLOCK + pred SDLK_SCROLLOCK = SDLK_CAPSLOCK + pred SDLK_RSHIFT = SDLK_SCROLLOCK + pred SDLK_LSHIFT = SDLK_RSHIFT + pred SDLK_RCTRL = SDLK_LSHIFT + pred SDLK_LCTRL = SDLK_RCTRL + pred SDLK_RALT = SDLK_LCTRL + pred SDLK_LALT = SDLK_RALT + pred SDLK_RMETA = SDLK_LALT + pred SDLK_LMETA = SDLK_RMETA + pred SDLK_LSUPER = SDLK_LMETA + pred SDLK_RSUPER = SDLK_LSUPER + pred SDLK_MODE = SDLK_RSUPER + pred SDLK_COMPOSE = SDLK_MODE + pred SDLK_HELP = SDLK_COMPOSE + pred SDLK_PRINT = SDLK_HELP + pred SDLK_SYSREQ = SDLK_PRINT + pred SDLK_BREAK = SDLK_SYSREQ + pred SDLK_MENU = SDLK_BREAK + pred SDLK_POWER = SDLK_MENU + pred SDLK_EURO = SDLK_POWER + pred SDLK_UNDO = SDLK_EURO + pred SDLK_LAST = SDLK_UNDO + pred _ = error "Graphics.UI.SDL.Keysym.pred: bad argument" + enumFromTo x y | x > y = [] + | x == y = [y] + | True = x : enumFromTo (succ x) y diff --git a/Graphics/UI/SDL/RWOps.hs b/Graphics/UI/SDL/RWOps.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/SDL/RWOps.hs @@ -0,0 +1,69 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.SDL.Video +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- +module Graphics.UI.SDL.RWOps + ( fromFile + , tryFromFile + , free + , with + , mkFinalizedRW + ) where + +import Foreign (Ptr, FunPtr, +#if defined(__GLASGOW_HASKELL__) + finalizeForeignPtr, +#endif + maybePeek, newForeignPtr) +import Foreign.C (withCString, CString) + +import Control.Exception (bracket) + +import Graphics.UI.SDL.Types (RWops, RWopsStruct) +import Graphics.UI.SDL.General (unwrapMaybe) + + +with :: FilePath -> String -> (RWops -> IO a) -> IO a +with path mode action + = bracket (fromFile path mode) + (free) + action + + +-- extern DECLSPEC SDL_RWops * SDLCALL SDL_RWFromFile(const char *file, const char *mode); +foreign import ccall unsafe "SDL_RWFromFile" rwFromFile :: CString -> CString -> IO (Ptr RWopsStruct) +tryFromFile :: FilePath -> String -> IO (Maybe RWops) +tryFromFile filepath mode + = withCString filepath $ \cPath -> + withCString mode $ \cMode -> + rwFromFile cPath cMode >>= maybePeek mkFinalizedRW + +fromFile :: FilePath -> String -> IO RWops +fromFile filepath mode = unwrapMaybe "SDL_RWFromFile" (tryFromFile filepath mode) + +-- extern DECLSPEC void SDLCALL SDL_FreeRW(SDL_RWops *area); +foreign import ccall unsafe "&SDL_FreeRW" rwFreeFinal :: FunPtr (Ptr RWopsStruct -> IO ()) +mkFinalizedRW :: Ptr RWopsStruct -> IO RWops +mkFinalizedRW = newForeignPtr rwFreeFinal + +free :: RWops -> IO () +free = +#if defined(__GLASGOW_HASKELL__) + finalizeForeignPtr +#else + const (return ()) +#endif + +{- +foreign import ccall unsafe "SDL_FreeRW" rwFree :: Ptr RWopsStruct -> IO () +free :: RWops -> IO () +free rw = withForeignPtr rw rwFree +-} + diff --git a/Graphics/UI/SDL/Rect.hsc b/Graphics/UI/SDL/Rect.hsc new file mode 100644 --- /dev/null +++ b/Graphics/UI/SDL/Rect.hsc @@ -0,0 +1,40 @@ +#include "SDL.h" +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.SDL.Video +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- +module Graphics.UI.SDL.Rect where + +import Foreign (Storable(poke, sizeOf, alignment, peekByteOff, pokeByteOff, + peek)) +import Data.Word (Word16) +import Data.Int (Int16) + +data Rect + = Rect + { rectX, rectY :: Int, -- Actually Int16 + rectW, rectH :: Int } -- Actually Word16 + deriving (Show,Eq,Ord) + +instance Storable Rect where + sizeOf = const #{size SDL_Rect} + alignment = const 2 + peek ptr + = do x <- #{peek SDL_Rect, x} ptr :: IO Int16 + y <- #{peek SDL_Rect, y} ptr :: IO Int16 + w <- #{peek SDL_Rect, w} ptr :: IO Word16 + h <- #{peek SDL_Rect, h} ptr :: IO Word16 + return $! Rect (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) + poke ptr (Rect x y w h) + = do #{poke SDL_Rect, x} ptr (fromIntegral x :: Int16) + #{poke SDL_Rect, y} ptr (fromIntegral y :: Int16) + #{poke SDL_Rect, w} ptr (fromIntegral w :: Word16) + #{poke SDL_Rect, h} ptr (fromIntegral h :: Word16) + diff --git a/Graphics/UI/SDL/Time.hs b/Graphics/UI/SDL/Time.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/SDL/Time.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.SDL.Time +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- +module Graphics.UI.SDL.Time where + + +import Foreign + +-- Uint32 SDL_GetTicks(void); +foreign import ccall unsafe "SDL_GetTicks" getTicks :: IO Word32 + +-- void SDL_Delay(Uint32 ms); +foreign import ccall unsafe "SDL_Delay" delay :: Word32 -> IO () + diff --git a/Graphics/UI/SDL/Types.hsc b/Graphics/UI/SDL/Types.hsc new file mode 100644 --- /dev/null +++ b/Graphics/UI/SDL/Types.hsc @@ -0,0 +1,274 @@ +#include "SDL.h" +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.SDL.Types +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- +module Graphics.UI.SDL.Types + ( SurfaceStruct + , Surface + , VideoInfoStruct + , VideoInfo + , RWopsStruct + , RWops + , PixelFormatStruct + , PixelFormat + , JoystickStruct + , Joystick + , Hat(..) + , TimerIDStruct + , SurfaceFlag (..) + , surfaceGetPixelFormat + , surfaceGetWidth + , surfaceGetHeight + , surfaceGetFlags + , surfaceGetPitch + , surfaceGetPixels + , pixelFormatGetAlpha + , pixelFormatGetColorKey + , pixelFormatGetBitsPerPixel + , pixelFormatGetBytesPerPixel + ) where + +import Foreign (Word8, Word16, Word32, Ptr, Storable(peekByteOff), + unsafePerformIO, newForeignPtr_, ForeignPtr, withForeignPtr) + +import Graphics.UI.SDL.Utilities (Enum(..), fromBitmask) +import Graphics.UI.SDL.Color (Pixel(..)) + +import Prelude hiding (Enum(..)) + +data SurfaceStruct +type Surface = ForeignPtr SurfaceStruct + +data VideoInfoStruct +type VideoInfo = ForeignPtr VideoInfoStruct + +data RWopsStruct +type RWops = ForeignPtr RWopsStruct + +data PixelFormatStruct +type PixelFormat = ForeignPtr PixelFormatStruct + +data TimerIDStruct + +data PixelsData +type Pixels = Ptr PixelsData + +data JoystickStruct +type Joystick = ForeignPtr JoystickStruct + +data Hat + = HatCentered + | HatUp + | HatRight + | HatDown + | HatLeft + | HatRightUp + | HatRightDown + | HatLeftUp + | HatLeftDown + deriving (Show,Eq,Ord) + +instance Bounded Hat where + minBound = HatCentered + maxBound = HatLeftDown + +instance Enum Hat Word8 where + fromEnum HatCentered = #{const SDL_HAT_CENTERED} + fromEnum HatUp = #{const SDL_HAT_UP} + fromEnum HatRight = #{const SDL_HAT_RIGHT} + fromEnum HatDown = #{const SDL_HAT_DOWN} + fromEnum HatLeft = #{const SDL_HAT_LEFT} + fromEnum HatRightUp = #{const SDL_HAT_RIGHTUP} + fromEnum HatRightDown = #{const SDL_HAT_RIGHTDOWN} + fromEnum HatLeftUp = #{const SDL_HAT_LEFTUP} + fromEnum HatLeftDown = #{const SDL_HAT_LEFTDOWN} + toEnum #{const SDL_HAT_CENTERED} = HatCentered + toEnum #{const SDL_HAT_UP} = HatUp + toEnum #{const SDL_HAT_RIGHT} = HatRight + toEnum #{const SDL_HAT_DOWN} = HatDown + toEnum #{const SDL_HAT_LEFT} = HatLeft + toEnum #{const SDL_HAT_RIGHTUP} = HatRightUp + toEnum #{const SDL_HAT_RIGHTDOWN} = HatRightDown + toEnum #{const SDL_HAT_LEFTUP} = HatLeftUp + toEnum #{const SDL_HAT_LEFTDOWN} = HatLeftDown + toEnum _ = error "Graphics.UI.SDL.Types.toEnum: bad argument" + succ HatCentered = HatUp + succ HatUp = HatRight + succ HatRight = HatDown + succ HatDown = HatLeft + succ HatLeft = HatRightUp + succ HatRightUp = HatRightDown + succ HatRightDown = HatLeftUp + succ HatLeftUp = HatLeftDown + succ _ = error "Graphics.UI.SDL.Types.succ: bad argument" + pred HatUp = HatCentered + pred HatRight = HatUp + pred HatDown = HatRight + pred HatLeft = HatDown + pred HatRightUp = HatLeft + pred HatRightDown = HatRightUp + pred HatLeftUp = HatRightDown + pred HatLeftDown = HatLeftUp + pred _ = error "Graphics.UI.SDL.Types.pred: bad argument" + enumFromTo x y | x > y = [] + | x == y = [y] + | True = x : enumFromTo (succ x) y + + +data SurfaceFlag + = SWSurface + | HWSurface + | OpenGL + | ASyncBlit + | OpenGLBlit + | Resizable + | NoFrame + | HWAccel + | SrcColorKey + | RLEAccel + | SrcAlpha + | PreAlloc + | AnyFormat + | HWPalette + | DoubleBuf + | Fullscreen + deriving (Eq, Ord, Show, Read) +instance Bounded SurfaceFlag where + minBound = SWSurface + maxBound = Fullscreen +instance Enum SurfaceFlag Word32 where + fromEnum SWSurface = 0 + fromEnum HWSurface = 1 + fromEnum OpenGL = 2 + fromEnum ASyncBlit = 4 + fromEnum OpenGLBlit = 10 + fromEnum Resizable = 16 + fromEnum NoFrame = 32 + fromEnum HWAccel = 256 + fromEnum SrcColorKey = 4096 + fromEnum RLEAccel = 16384 + fromEnum SrcAlpha = 65536 + fromEnum PreAlloc = 16777216 + fromEnum AnyFormat = 268435456 + fromEnum HWPalette = 536870912 + fromEnum DoubleBuf = 1073741824 + fromEnum Fullscreen = 2147483648 + toEnum 0 = SWSurface + toEnum 1 = HWSurface + toEnum 4 = ASyncBlit + toEnum 2 = OpenGL + toEnum 10 = OpenGLBlit + toEnum 16 = Resizable + toEnum 32 = NoFrame + toEnum 256 = HWAccel + toEnum 4096 = SrcColorKey + toEnum 16384 = RLEAccel + toEnum 65536 = SrcAlpha + toEnum 16777216 = PreAlloc + toEnum 268435456 = AnyFormat + toEnum 536870912 = HWPalette + toEnum 1073741824 = DoubleBuf + toEnum 2147483648 = Fullscreen + toEnum _ = error "Graphics.UI.SDL.Types.fromEnum: bad argument" + succ SWSurface = HWSurface + succ HWSurface = OpenGL + succ OpenGL = ASyncBlit + succ ASyncBlit = OpenGLBlit + succ OpenGLBlit = Resizable + succ Resizable = NoFrame + succ NoFrame = HWAccel + succ HWAccel = SrcColorKey + succ SrcColorKey = RLEAccel + succ RLEAccel = SrcAlpha + succ SrcAlpha = PreAlloc + succ PreAlloc = AnyFormat + succ AnyFormat = HWPalette + succ HWPalette = DoubleBuf + succ DoubleBuf = Fullscreen + succ _ = error "Graphics.UI.SDL.Types.succ: bad argument" + + pred HWSurface = SWSurface + pred OpenGL = HWSurface + pred ASyncBlit = OpenGL + pred OpenGLBlit = ASyncBlit + pred Resizable = OpenGLBlit + pred NoFrame = Resizable + pred HWAccel = NoFrame + pred SrcColorKey = HWAccel + pred RLEAccel = SrcColorKey + pred SrcAlpha = RLEAccel + pred PreAlloc = SrcAlpha + pred AnyFormat = PreAlloc + pred HWPalette = AnyFormat + pred DoubleBuf = HWPalette + pred Fullscreen = DoubleBuf + pred _ = error "Graphics.UI.SDL.Types.pred: bad argument" + + enumFromTo x y | x > y = [] + | x == y = [y] + | True = x : enumFromTo (succ x) y + + +surfaceGetPixelFormat :: Surface -> PixelFormat +surfaceGetPixelFormat surface + = unsafePerformIO $ + withForeignPtr surface $ \ptr -> + newForeignPtr_ =<< #{peek SDL_Surface, format} ptr + +pixelFormatGetAlpha :: PixelFormat -> IO Word8 +pixelFormatGetAlpha format = + withForeignPtr format $ + #{peek SDL_PixelFormat, alpha} + +pixelFormatGetColorKey :: PixelFormat -> IO Pixel +pixelFormatGetColorKey format = + fmap Pixel $ + withForeignPtr format $ + #{peek SDL_PixelFormat, colorkey} + +pixelFormatGetBitsPerPixel :: PixelFormat -> IO Word8 +pixelFormatGetBitsPerPixel format + = withForeignPtr format $ + #{peek SDL_PixelFormat, BitsPerPixel} + +pixelFormatGetBytesPerPixel :: PixelFormat -> IO Word8 +pixelFormatGetBytesPerPixel format + = withForeignPtr format $ + #{peek SDL_PixelFormat, BytesPerPixel} + +surfaceGetWidth :: Surface -> Int +surfaceGetWidth surface + = unsafePerformIO $ + withForeignPtr surface $ + #{peek SDL_Surface, w} + +surfaceGetHeight :: Surface -> Int +surfaceGetHeight surface + = unsafePerformIO $ + withForeignPtr surface $ + #{peek SDL_Surface, h} + +surfaceGetFlags :: Surface -> IO [SurfaceFlag] +surfaceGetFlags surface + = withForeignPtr surface $ + fmap fromBitmask . #{peek SDL_Surface, flags} + +surfaceGetPitch :: Surface -> Word16 +surfaceGetPitch surface + = unsafePerformIO $ + withForeignPtr surface $ + #peek SDL_Surface, pitch + +surfaceGetPixels :: Surface -> IO Pixels +surfaceGetPixels surface + = withForeignPtr surface $ + #peek SDL_Surface, pixels + diff --git a/Graphics/UI/SDL/Utilities.hs b/Graphics/UI/SDL/Utilities.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/SDL/Utilities.hs @@ -0,0 +1,54 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.SDL.General +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Various small functions which makes the binding process easier. +----------------------------------------------------------------------------- +module Graphics.UI.SDL.Utilities where + +import Foreign (Bits((.|.), (.&.))) + +import Prelude hiding (Enum(..)) + +class Enum a b | a -> b where + succ :: a -> a + pred :: a -> a + toEnum :: b -> a + fromEnum :: a -> b + enumFromTo :: a -> a -> [a] + + + +intToBool :: Int -> IO Int -> IO Bool +intToBool err action + = fmap (err/=) action + +toBitmask :: (Enum a b,Bits b) => [a] -> b +toBitmask = foldr (.|.) 0 . map fromEnum + +fromBitmask :: (Bounded a,Enum a b,Bits b) => b -> [a] +fromBitmask mask = foldr worker [] lst + where lst = enumFromTo minBound maxBound + worker v + = if (mask .&. fromEnum v) /= 0 + then (:) v + else id +{- +toBitmaskW :: (UnsignedEnum a) => [a] -> Word32 +toBitmaskW = foldr (.|.) 0 . map fromEnumW + +fromBitmaskW :: (Bounded a,UnsignedEnum a) => Word32 -> [a] +fromBitmaskW mask = foldr worker [] lst + where lst = enumFromToW minBound maxBound + worker v + = if (mask .&. fromEnumW v) /= 0 + then (:) v + else id + +-} diff --git a/Graphics/UI/SDL/Version.hsc b/Graphics/UI/SDL/Version.hsc new file mode 100644 --- /dev/null +++ b/Graphics/UI/SDL/Version.hsc @@ -0,0 +1,33 @@ +#include "SDL.h" +module Graphics.UI.SDL.Version + ( compiledFor + , linkedWith + ) where + +import Data.Version (Version(Version)) + +import Foreign (Word8, Ptr, Storable(sizeOf, alignment, peekByteOff, peek)) + +data SDLVersion + = SDLVersion Word8 Word8 Word8 + +instance Storable SDLVersion where + sizeOf _ = #{size SDL_version} + alignment _ = 1 + peek ptr = do major <- #{peek SDL_version, major} ptr + minor <- #{peek SDL_version, minor} ptr + patch <- #{peek SDL_version, patch} ptr + return (SDLVersion major minor patch) + +compiledFor :: Version +compiledFor = Version [ #{const SDL_MAJOR_VERSION} + , #{const SDL_MINOR_VERSION} + , #{const SDL_PATCHLEVEL} + ] [] + +-- const SDL_version * SDL_Linked_Version(void); +foreign import ccall unsafe "SDL_Linked_Version" sdlLinkedVersion :: IO (Ptr SDLVersion) +linkedWith :: IO Version +linkedWith = do versionPtr <- sdlLinkedVersion + SDLVersion major minor patch <- peek versionPtr + return (Version (map fromIntegral [major,minor,patch]) []) diff --git a/Graphics/UI/SDL/Video.hsc b/Graphics/UI/SDL/Video.hsc new file mode 100644 --- /dev/null +++ b/Graphics/UI/SDL/Video.hsc @@ -0,0 +1,700 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.SDL.Video +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- +module Graphics.UI.SDL.Video + ( Palette + , Toggle (..) + , fromToggle + , toToggle + , tryGetVideoSurface + , getVideoSurface + , tryVideoDriverName + , videoDriverName + , getVideoInfo + , ListModes(..) + , listModes + , videoModeOK + , trySetVideoMode + , setVideoMode + , updateRect + , updateRects + , tryFlip + , flip + , setColors + , setPalette + , setGamma + , tryGetGammaRamp + , getGammaRamp + , trySetGammaRamp + , setGammaRamp + , mapRGB + , mapRGBA + , getRGB + , getRGBA + , tryCreateRGBSurface + , createRGBSurface + , tryCreateRGBSurfaceEndian + , createRGBSurfaceEndian + , tryCreateRGBSurfaceFrom + , createRGBSurfaceFrom + , freeSurface + , lockSurface + , unlockSurface + , loadBMP + , saveBMP + , setColorKey + , setAlpha + , setClipRect + , getClipRect + , withClipRect + , tryConvertSurface + , convertSurface + , blitSurface + , fillRect + , tryDisplayFormat + , displayFormat + , tryDisplayFormatAlpha + , displayFormatAlpha + , warpMouse + , showCursor + , queryCursorState + , GLAttr, GLValue + , glRedSize, glGreenSize, glBlueSize, glAlphaSize, glBufferSize, glDoubleBuffer + , glDepthSize, glStencilSize, glAccumRedSize, glAccumGreenSize, glAccumBlueSize + , glAccumAlphaSize, glStereo, glMultiSampleBuffers, glMultiSampleSamples + , tryGLGetAttribute, glGetAttribute + , tryGLSetAttribute, glSetAttribute + , glSwapBuffers + , mkFinalizedSurface + ) where + +#include + +import Foreign (Ptr, FunPtr, Storable(peek), castPtr, plusPtr, nullPtr, newForeignPtr_, + finalizeForeignPtr, alloca, withForeignPtr, newForeignPtr) +import Foreign.C (peekCString, CString) +import Foreign.Marshal.Array (withArrayLen, peekArray0, peekArray, allocaArray) +import Foreign.Marshal.Utils (with, toBool, maybeWith, maybePeek, fromBool) +import Control.Exception (bracket) +import Data.Word (Word8, Word16, Word32) +import Data.Int (Int32) + +import Graphics.UI.SDL.Utilities (Enum(..), intToBool, toBitmask) +import Graphics.UI.SDL.General (unwrapMaybe, unwrapBool) +import Graphics.UI.SDL.Rect (Rect(rectY, rectX, rectW, rectH)) +import Graphics.UI.SDL.Color (Pixel(..), Color) +import Graphics.UI.SDL.Types (SurfaceFlag, PixelFormat, PixelFormatStruct, RWops, + RWopsStruct, VideoInfo, VideoInfoStruct, Surface, SurfaceStruct) +import qualified Graphics.UI.SDL.RWOps as RW + +import Prelude hiding (flip,Enum(..)) + +--import Foreign.HacanonLight.Generate +--import Foreign.HacanonLight.DIS (foreignPtr,mkOut,word8) + +data Palette + = Logical + | Physical + deriving (Show,Eq,Ord) + +instance Bounded Palette where + minBound = Logical + maxBound = Physical + +instance Enum Palette Int where + fromEnum Logical = #{const SDL_LOGPAL} + fromEnum Physical = #{const SDL_PHYSPAL} + toEnum #{const SDL_LOGPAL} = Logical + toEnum #{const SDL_PHYSPAL} = Physical + toEnum _ = error "Graphics.UI.SDL.Video.toEnum: bad argument" + succ Logical = Physical + succ _ = error "Graphics.UI.SDL.Video.succ: bad argument" + pred Physical = Logical + pred _ = error "Graphics.UI.SDL.Video.pred: bad argument" + enumFromTo x y | x > y = [] + | x == y = [y] + | True = x : enumFromTo (succ x) y + + +data Toggle = Disable | Enable | Query + deriving (Eq, Ord, Show) + +toToggle :: (Num a) => a -> Toggle +toToggle (#{const SDL_DISABLE}) = Disable +toToggle (#{const SDL_ENABLE}) = Enable +toToggle (#{const SDL_QUERY}) = Query +toToggle _ = error "Graphics.UI.SDL.Video.toToggle: bad argument" + +fromToggle :: (Num a) => Toggle -> a +fromToggle Disable = 0 +fromToggle Enable = 1 +fromToggle Query = (-1) + + +foreign import ccall unsafe "SDL_GetVideoSurface" sdlGetVideoSurface :: IO (Ptr SurfaceStruct) + +-- | Returns the video surface or @Nothing@ on error. +tryGetVideoSurface :: IO (Maybe Surface) +tryGetVideoSurface = + sdlGetVideoSurface >>= maybePeek newForeignPtr_ + +-- | Returns the video surface, throwing an exception on error. +getVideoSurface :: IO Surface +getVideoSurface = unwrapMaybe "SDL_GetVideoSurface" tryGetVideoSurface + +foreign import ccall unsafe "SDL_VideoDriverName" sdlVideoDriverName :: CString -> Int -> IO CString + +-- | Returns the video driver name or @Nothing@ on error. Notice, the driver name is limited to 256 chars. +tryVideoDriverName :: IO (Maybe String) +tryVideoDriverName + = allocaArray size (\ptr -> sdlVideoDriverName ptr size >>= maybePeek peekCString) + where size = 256 + +-- | Returns the video driver name, throwing an exception on error. See also 'tryVideoDriverName'. +videoDriverName :: IO String +videoDriverName = unwrapMaybe "SDL_VideoDriverName" tryVideoDriverName + +foreign import ccall unsafe "SDL_GetVideoInfo" sdlGetVideoInfo :: IO (Ptr VideoInfoStruct) +getVideoInfo :: IO VideoInfo +getVideoInfo = sdlGetVideoInfo >>= newForeignPtr_ + +data ListModes + = Modes [Rect] -- ^ List of available resolutions. + | NonAvailable -- ^ No modes available! + | AnyOK -- ^ All resolutions available. + deriving (Show,Eq,Ord) + +foreign import ccall unsafe "SDL_ListModes" sdlListModes :: Ptr PixelFormatStruct -> Word32 -> IO (Ptr (Ptr Rect)) + +-- | Returns the available screen resolutions for the given format and video flags. +listModes :: Maybe PixelFormat -- ^ Will use SDL_GetVideoInfo()->vfmt when @Nothing@. + -> [SurfaceFlag] + -> IO ListModes +listModes mbFormat flags + = do ret <- getFormat (\ptr -> sdlListModes ptr (toBitmask flags)) + if ret == nullPtr `plusPtr` (-1) + then return AnyOK + else if ret == nullPtr + then return NonAvailable + else do array <- peekArray0 nullPtr ret + fmap Modes (mapM peek array) + where getFormat = maybe (\action -> action nullPtr) withForeignPtr mbFormat + +-- int SDL_VideoModeOK(int width, int height, int bpp, Uint32 flags); +foreign import ccall unsafe "SDL_VideoModeOK" sdlVideoModeOK :: Int -> Int -> Int -> Word32 -> IO Int + +-- | Check to see if a particular video mode is supported. +-- Returns the bits-per-pixel of the closest available mode with the given width, +-- height and requested surface flags, or @Nothing@ on error. +videoModeOK :: Int -- ^ Width. + -> Int -- ^ Height. + -> Int -- ^ Bits-per-pixel. + -> [SurfaceFlag] -- ^ Flags. + -> IO (Maybe Int) +videoModeOK width height bpp flags + = do ret <- sdlVideoModeOK width height bpp (toBitmask flags) + case ret of + 0 -> return Nothing + x -> return (Just x) + +-- SDL_Surface *SDL_SetVideoMode(int width, int height, int bpp, Uint32 flags); +foreign import ccall unsafe "SDL_SetVideoMode" sdlSetVideoMode :: Int -> Int -> Int -> Word32 -> IO (Ptr SurfaceStruct) + +-- | Set up a video mode with the specified width, height and bits-per-pixel. +-- Returns @Nothing@ on error. +trySetVideoMode :: Int -- ^ Width. + -> Int -- ^ Height. + -> Int -- ^ Bits-per-pixel. + -> [SurfaceFlag] -- ^ Flags. + -> IO (Maybe Surface) +trySetVideoMode width height bpp flags + = sdlSetVideoMode width height bpp (toBitmask flags) >>= maybePeek newForeignPtr_ + +-- | Same as 'trySetVideoMode' except it throws an exception on error. +setVideoMode :: Int -> Int -> Int -> [SurfaceFlag] -> IO Surface +setVideoMode width height bpp flags + = unwrapMaybe "SDL_SetVideoMode" (trySetVideoMode width height bpp flags) + +-- void SDL_UpdateRect(SDL_Surface *screen, Sint32 x, Sint32 y, Sint32 w, Sint32 h); +foreign import ccall unsafe "SDL_UpdateRect" sdlUpdateRect :: Ptr SurfaceStruct + -> Int32 -> Int32 -> Word32 -> Word32 -> IO () + +-- | Makes sure the given area is updated on the given screen. +updateRect :: Surface -> Rect -> IO () +updateRect surface rect + = withForeignPtr surface (\ptr -> sdlUpdateRect ptr x y w h) + where x = fromIntegral (rectX rect) + y = fromIntegral (rectY rect) + w = fromIntegral (rectW rect) + h = fromIntegral (rectH rect) + + +-- void SDL_UpdateRects(SDL_Surface *screen, int numrects, SDL_Rect *rects); +foreign import ccall unsafe "SDL_UpdateRects" sdlUpdateRects :: Ptr SurfaceStruct -> Int -> Ptr Rect -> IO () + +-- | Makes sure the given list of rectangles is updated on the given screen. +-- The rectangles are not automatically merged or checked for overlap. +-- In general, the programmer can use his knowledge about his particular +-- rectangles to merge them in an efficient way, to avoid overdraw. +updateRects :: Surface -> [Rect] -> IO () +updateRects surface rects + = withForeignPtr surface $ \ptr -> + withArrayLen rects $ \len array -> + sdlUpdateRects ptr len array + +-- int SDL_Flip(SDL_Surface *screen); +foreign import ccall unsafe "SDL_Flip" sdlFlip :: Ptr SurfaceStruct -> IO Int + +-- | Swaps screen buffers. +tryFlip :: Surface -> IO Bool +tryFlip surface + = withForeignPtr surface $ \ptr -> + do ret <- sdlFlip ptr + case ret of + (-1) -> return False + _ -> return True + +-- | Same as 'tryFlip' but throws an exception on error. +flip :: Surface -> IO () +flip = unwrapBool "SDL_Flip" . tryFlip + +-- int SDL_SetColors(SDL_Surface *surface, SDL_Color *colors, int firstcolor, int ncolors); +foreign import ccall unsafe "SDL_SetColors" sdlSetColors :: Ptr SurfaceStruct -> Ptr Color -> Int -> Int -> IO Int + +-- | Sets a portion of the colormap for the given 8-bit surface. +setColors :: Surface -> [Color] -> Int -> IO Bool +setColors surface colors start + = withForeignPtr surface $ \ptr -> + withArrayLen colors $ \len array -> + fmap toBool (sdlSetColors ptr array start len) + +-- int SDL_SetPalette(SDL_Surface *surface, int flags, SDL_Color *colors, int firstcolor, int ncolors); +foreign import ccall unsafe "SDL_SetPalette" sdlSetPalette + :: Ptr SurfaceStruct -> Int -> Ptr Color -> Int -> Int -> IO Int + +-- | Sets the colors in the palette of an 8-bit surface. +setPalette :: Surface -> [Palette] -> [Color] -> Int -> IO Bool +setPalette surface flags colors start + = withForeignPtr surface $ \ptr -> + withArrayLen colors $ \len array -> + fmap toBool (sdlSetPalette ptr (toBitmask flags) array start len) + +--int SDL_SetGamma(float redgamma, float greengamma, float bluegamma); +foreign import ccall unsafe "SDL_SetGamma" sdlSetGamma :: Float -> Float -> Float -> IO Int +setGamma :: Float -> Float -> Float -> IO Bool +setGamma red green blue + = intToBool (-1) (sdlSetGamma red green blue) + +-- int SDL_GetGammaRamp(Uint16 *redtable, Uint16 *greentable, Uint16 *bluetable); +foreign import ccall unsafe "SDL_GetGammaRamp" sdlGetGammaRamp :: Ptr Word16 -> Ptr Word16 -> Ptr Word16 -> IO Int +tryGetGammaRamp :: IO (Maybe ([Word16],[Word16],[Word16])) +tryGetGammaRamp + = allocaArray size $ \red -> + allocaArray size $ \green -> + allocaArray size $ \blue -> + do ret <- sdlGetGammaRamp red green blue + case ret of + (-1) -> return Nothing + _ -> do [r,g,b] <- mapM (peekArray size) [red,green,blue] + return (Just (r,g,b)) + where size = 256 + +getGammaRamp :: IO ([Word16],[Word16],[Word16]) +getGammaRamp = unwrapMaybe "SDL_GetGammaRamp" tryGetGammaRamp + +-- int SDL_SetGammaRamp(Uint16 *redtable, Uint16 *greentable, Uint16 *bluetable); +foreign import ccall unsafe "SDL_SetGammaRamp" sdlSetGammaRamp :: Ptr Word16 -> Ptr Word16 -> Ptr Word16 -> IO Int +trySetGammaRamp :: [Word16] -> [Word16] -> [Word16] -> IO Bool +trySetGammaRamp red green blue + = withArrayLen red $ check $ \ptrRed -> + withArrayLen green $ check $ \ptrGreen -> + withArrayLen blue $ check $ \ptrBlue -> + intToBool (-1) (sdlSetGammaRamp ptrRed ptrGreen ptrBlue) + where check action 256 ptr = action ptr + check _ _ _ = return False + +setGammaRamp :: [Word16] -> [Word16] -> [Word16] -> IO () +setGammaRamp red green blue = unwrapBool "setGammaRamp_" (trySetGammaRamp red green blue) + +-- Uint32 SDL_MapRGB(SDL_PixelFormat *fmt, Uint8 r, Uint8 g, Uint8 b); +foreign import ccall unsafe "SDL_MapRGB" sdlMapRGB :: Ptr PixelFormatStruct -> Word8 -> Word8 -> Word8 -> IO Word32 + +-- | Map a RGB color value to a pixel format. +mapRGB :: PixelFormat + -> Word8 -- ^ Red value. + -> Word8 -- ^ Green value. + -> Word8 -- ^ Blue value. + -> IO Pixel +mapRGB format r g b + = withForeignPtr format $ \ptr -> + fmap Pixel (sdlMapRGB ptr r g b) + +-- Uint32 SDL_MapRGBA(SDL_PixelFormat *fmt, Uint8 r, Uint8 g, Uint8 b, Uint8 a); + +foreign import ccall unsafe "SDL_MapRGBA" sdlMapRGBA + :: Ptr PixelFormatStruct -> Word8 -> Word8 -> Word8 -> Word8 -> IO Word32 + +-- | Map a RGBA color value to a pixel format. +mapRGBA :: PixelFormat + -> Word8 -- ^ Red value. + -> Word8 -- ^ Green value. + -> Word8 -- ^ Blue value. + -> Word8 -- ^ Alpha value. + -> IO Pixel +mapRGBA format r g b a + = withForeignPtr format $ \ptr -> + fmap Pixel (sdlMapRGBA ptr r g b a) + +-- void SDL_GetRGB(Uint32 pixel, SDL_PixelFormat *fmt, Uint8 *r, Uint8 *g, Uint8 *b); +foreign import ccall unsafe "SDL_GetRGB" sdlGetRGB + :: Word32 -> Ptr PixelFormatStruct -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> IO () + +-- | Get RGB values from a pixel in the specified pixel format. +getRGB :: Pixel -> PixelFormat -> IO (Word8,Word8,Word8) +getRGB (Pixel p) format + = alloca $ \red -> + alloca $ \green -> + alloca $ \blue -> + withForeignPtr format $ \ptr -> + do sdlGetRGB p ptr red green blue + [r,g,b] <- mapM peek [red,green,blue] + return (r,g,b) + +-- void SDL_GetRGBA(Uint32 pixel, SDL_PixelFormat *fmt, Uint8 *r, Uint8 *g, Uint8 *b, Uint8 *a); +foreign import ccall unsafe "SDL_GetRGBA" sdlGetRGBA + :: Word32 -> Ptr PixelFormatStruct -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> IO () + +-- | Gets RGBA values from a pixel in the specified pixel format. +getRGBA :: Pixel -> PixelFormat -> IO (Word8,Word8,Word8,Word8) +getRGBA (Pixel p) format + = alloca $ \red -> + alloca $ \green -> + alloca $ \blue -> + alloca $ \alpha -> + withForeignPtr format $ \ptr -> + do sdlGetRGBA p ptr red green blue alpha + [r,g,b,a] <- mapM peek [red,green,blue,alpha] + return (r,g,b,a) + +-- SDL_Surface *SDL_CreateRGBSurface(Uint32 flags, int width, int height, int depth, Uint32 Rmask, Uint32 Gmask, Uint32 Bmask, Uint32 Amask); +foreign import ccall unsafe "SDL_CreateRGBSurface" sdlCreateRGBSurface + :: Word32 -> Int -> Int -> Int -> Word32 -> Word32 -> Word32 -> Word32 -> IO (Ptr SurfaceStruct) + +-- | Creates an empty @Surface@. Returns @Nothing@ on error. +tryCreateRGBSurface :: [SurfaceFlag] -> Int -> Int -> Int + -> Word32 -> Word32 -> Word32 -> Word32 -> IO (Maybe Surface) +tryCreateRGBSurface flags width height bpp rmask gmask bmask amask + = sdlCreateRGBSurface (toBitmask flags) width height bpp rmask gmask bmask amask >>= + maybePeek mkFinalizedSurface + +-- | Creates an empty @Surface@. Throws an exception on error. +createRGBSurface :: [SurfaceFlag] -> Int -> Int -> Int + -> Word32 -> Word32 -> Word32 -> Word32 -> IO Surface +createRGBSurface flags width height bpp rmask gmask bmask amask + = unwrapMaybe "SDL_CreateRGBSurface" (tryCreateRGBSurface flags width height bpp rmask gmask bmask amask) + +-- | Creates an empty @Surface@ with (r\/g\/b\/a)mask determined from the local endian. +-- Returns @Nothing@ on error. +tryCreateRGBSurfaceEndian :: [SurfaceFlag] -> Int -> Int -> Int -> IO (Maybe Surface) +tryCreateRGBSurfaceEndian flags width height bpp + = tryCreateRGBSurface flags width height bpp +#if SDL_BYTEORDER == SDL_LIL_ENDIAN + 0x000000FF 0x0000FF00 0x00FF0000 0xFF000000 +#else + 0xFF000000 0x00FF0000 0x0000FF00 0x000000FF +#endif + +-- | Creates an empty @Surface@ with (r\/g\/b\/a)mask determined from the local endian. +-- Throws an exception on error. +createRGBSurfaceEndian :: [SurfaceFlag] -> Int -> Int -> Int -> IO Surface +createRGBSurfaceEndian flags width height bpp + = unwrapMaybe "SDL_CreateRGBSurface" (tryCreateRGBSurfaceEndian flags width height bpp) + +-- SDL_Surface *SDL_CreateRGBSurfaceFrom(void *pixels, int width, int height, int depth, int pitch, Uint32 Rmask, Uint32 Gmask, Uint32 Bmask, Uint32 Amask); +foreign import ccall unsafe "SDL_CreateRGBSurfaceFrom" sdlCreateRGBSurfaceFrom + :: Ptr Word8 -> Int -> Int -> Int -> Int -> Word32 -> Word32 -> Word32 -> Word32 -> IO (Ptr SurfaceStruct) +tryCreateRGBSurfaceFrom :: Ptr a -> Int -> Int -> Int -> Int + -> Word32 -> Word32 -> Word32 -> Word32 -> IO (Maybe Surface) +tryCreateRGBSurfaceFrom pixels width height depth pitch rmask gmask bmask amask + = sdlCreateRGBSurfaceFrom (castPtr pixels) width height depth pitch rmask gmask bmask amask >>= + maybePeek mkFinalizedSurface + +createRGBSurfaceFrom :: Ptr a -> Int -> Int -> Int -> Int + -> Word32 -> Word32 -> Word32 -> Word32 -> IO Surface +createRGBSurfaceFrom pixels width height depth pitch rmask gmask bmask amask + = unwrapMaybe "SDL_CreateRGBSurfaceFrom" + (tryCreateRGBSurfaceFrom pixels width height depth pitch rmask gmask bmask amask) + +{- +-- void SDL_FreeSurface(SDL_Surface *surface); +foreign import ccall unsafe "SDL_FreeSurface" sdlFreeSurface :: Ptr SurfaceStruct -> IO () +-- | Frees (deletes) a @Surface@. Don\'t use it unless you really know what you're doing. All surfaces +-- are automatically deleted when they're out of scope or forced with @finalizeForeignPtr@. +freeSurface :: Surface -> IO () +freeSurface surface + = withForeignPtr surface sdlFreeSurface +-} + +-- | Forces the finalization of a @Surface@. Only supported with GHC. +freeSurface :: Surface -> IO () +freeSurface = +#if defined(__GLASGOW_HASKELL__) + finalizeForeignPtr +#else + const (return ()) +#endif + +-- int SDL_LockSurface(SDL_Surface *surface); +foreign import ccall unsafe "SDL_LockSurface" sdlLockSurface :: Ptr SurfaceStruct -> IO Int + +-- | Locks a surface for direct access. +lockSurface :: Surface -> IO Bool +lockSurface surface + = withForeignPtr surface $ \ptr -> + intToBool (-1) (sdlLockSurface ptr) + +-- void SDL_UnlockSurface(SDL_Surface *surface); +foreign import ccall unsafe "SDL_UnlockSurface" sdlUnlockSurface :: Ptr SurfaceStruct -> IO () + +-- | Unlocks a previously locked surface. +unlockSurface :: Surface -> IO () +unlockSurface surface = withForeignPtr surface sdlUnlockSurface + +-- extern DECLSPEC SDL_Surface * SDLCALL SDL_LoadBMP_RW(SDL_RWops *src, int freesrc); +-- define SDL_LoadBMP(file) SDL_LoadBMP_RW(SDL_RWFromFile(file, "rb"), 1) +foreign import ccall unsafe "SDL_LoadBMP_RW" sdlLoadBMP_RW :: Ptr RWopsStruct -> Int -> IO (Ptr SurfaceStruct) + +tryLoadBMPRW :: RWops -> Bool -> IO (Maybe Surface) +tryLoadBMPRW rw freesrc + = withForeignPtr rw $ \rwPtr -> + sdlLoadBMP_RW rwPtr (fromBool freesrc) >>= maybePeek mkFinalizedSurface + +loadBMPRW :: RWops -> Bool -> IO Surface +loadBMPRW rw freesrc = unwrapMaybe "SDL_LoadBMP_RW" (tryLoadBMPRW rw freesrc) + +loadBMP :: FilePath -> IO Surface +loadBMP filepath + = RW.with filepath "rb" $ \rw -> + loadBMPRW rw False + +-- extern DECLSPEC int SDLCALL SDL_SaveBMP_RW +-- (SDL_Surface *surface, SDL_RWops *dst, int freedst); +foreign import ccall unsafe "SDL_SaveBMP_RW" sdlSaveBMP_RW :: Ptr SurfaceStruct -> Ptr RWopsStruct -> Int -> IO Int + +saveBMPRW :: Surface -> RWops -> Bool -> IO Bool +saveBMPRW surface rw freedst + = withForeignPtr surface $ \ptr -> + withForeignPtr rw $ \rwPtr -> + intToBool (-1) (sdlSaveBMP_RW ptr rwPtr (fromBool freedst)) + +saveBMP :: Surface -> FilePath -> IO Bool +saveBMP surface filepath + = RW.with filepath "wb" $ \rw -> + saveBMPRW surface rw False + + +-- int SDL_SetColorKey(SDL_Surface *surface, Uint32 flag, Uint32 key); +foreign import ccall unsafe "SDL_SetColorKey" sdlSetColorKey :: Ptr SurfaceStruct -> Word32 -> Word32 -> IO Int +setColorKey :: Surface -> [SurfaceFlag] -> Pixel -> IO Bool +setColorKey surface flags (Pixel w) + = withForeignPtr surface $ \ptr -> + intToBool (-1) (sdlSetColorKey ptr (toBitmask flags) w) + +-- int SDL_SetAlpha(SDL_Surface *surface, Uint32 flag, Uint8 alpha); +foreign import ccall unsafe "SDL_SetAlpha" sdlSetAlpha :: Ptr SurfaceStruct -> Word32 -> Word8 -> IO Int + +-- | Adjusts the alpha properties of a surface. +setAlpha :: Surface -> [SurfaceFlag] -> Word8 -> IO Bool +setAlpha surface flags alpha + = withForeignPtr surface $ \ptr -> + intToBool (-1) (sdlSetAlpha ptr (toBitmask flags) alpha) + +-- void SDL_SetClipRect(SDL_Surface *surface, SDL_Rect *rect); +foreign import ccall unsafe "SDL_SetClipRect" sdlSetClipRect :: Ptr SurfaceStruct -> Ptr Rect -> IO () + +-- | Sets the clipping rectangle for a surface. +setClipRect :: Surface -> Maybe Rect -> IO () +setClipRect surface mbRect + = withForeignPtr surface $ \ptr -> + maybeWith with mbRect $ \rect -> + sdlSetClipRect ptr rect + +-- void SDL_GetClipRect(SDL_Surface *surface, SDL_Rect *rect); +foreign import ccall unsafe "SDL_GetClipRect" sdlGetClipRect :: Ptr SurfaceStruct -> Ptr Rect -> IO () + +-- | Gets the clipping rectangle for a surface. +getClipRect :: Surface -> IO Rect +getClipRect surface + = withForeignPtr surface $ \ptr -> + alloca $ \rectPtr -> + do sdlGetClipRect ptr rectPtr + peek rectPtr + +-- | Run an action with a given clipping rect applied. +-- If an exception is raised, then withClipRect will re-raise the exception (after resetting the original clipping rect). +withClipRect :: Surface -> Maybe Rect -> IO a -> IO a +withClipRect surface rect action + = bracket (getClipRect surface) -- Get the current cliprect + (setClipRect surface . Just) -- Reset to old cliprect when done. + (const (setClipRect surface rect >> action)) -- Set new cliprect. + +-- SDL_Surface *SDL_ConvertSurface(SDL_Surface *src, SDL_PixelFormat *fmt, Uint32 flags); +foreign import ccall unsafe "SDL_ConvertSurface" sdlConvertSurface + :: Ptr SurfaceStruct -> Ptr PixelFormatStruct -> Word32 -> IO (Ptr SurfaceStruct) + +-- | Converts a surface to the same format as another surface. Returns @Nothing@ on error. +tryConvertSurface :: Surface -> PixelFormat -> [SurfaceFlag] -> IO (Maybe Surface) +tryConvertSurface surface format flags + = withForeignPtr surface $ \ptr -> + withForeignPtr format $ \formatPtr -> + sdlConvertSurface ptr formatPtr (toBitmask flags) >>= maybePeek mkFinalizedSurface + +-- | Converts a surface to the same format as another surface. Throws an exception on error. +convertSurface :: Surface -> PixelFormat -> [SurfaceFlag] -> IO Surface +convertSurface surface format flags + = unwrapMaybe "SDL_ConvertSurface" + (tryConvertSurface surface format flags) + + +-- int SDL_UpperBlit(SDL_Surface *src, SDL_Rect *srcrect, SDL_Surface *dst, SDL_Rect *dstrect); +foreign import ccall unsafe "SDL_UpperBlit" sdlBlitSurface + :: Ptr SurfaceStruct -> Ptr Rect -> Ptr SurfaceStruct -> Ptr Rect -> IO Int + +-- | This function performs a fast blit from the source surface to the destination surface. +blitSurface :: Surface -> Maybe Rect -> Surface -> Maybe Rect -> IO Bool +blitSurface src srcRect dst dstRect + = withForeignPtr src $ \srcPtr -> + withForeignPtr dst $ \dstPtr -> + maybeWith with srcRect $ \srcRectPtr -> + maybeWith with dstRect $ \dstRectPtr -> + intToBool (-1) (sdlBlitSurface srcPtr srcRectPtr dstPtr dstRectPtr) + + +-- int SDL_FillRect(SDL_Surface *dst, SDL_Rect *dstrect, Uint32 color); +foreign import ccall unsafe "SDL_FillRect" sdlFillRect :: Ptr SurfaceStruct -> Ptr Rect -> Word32 -> IO Int + +-- | This function performs a fast fill of the given rectangle with some color. +fillRect :: Surface -> Maybe Rect -> Pixel -> IO Bool +fillRect surface mbRect (Pixel w) + = withForeignPtr surface $ \ptr -> + maybeWith with mbRect $ \rect -> + intToBool (-1) (sdlFillRect ptr rect w) + +-- SDL_Surface *SDL_DisplayFormat(SDL_Surface *surface); +foreign import ccall unsafe "SDL_DisplayFormat" sdlDisplayFormat :: Ptr SurfaceStruct -> IO (Ptr SurfaceStruct) + +-- | Converts a surface to the display format. Returns @Nothing@ on error. +tryDisplayFormat :: Surface -> IO (Maybe Surface) +tryDisplayFormat surface + = withForeignPtr surface $ \ptr -> + sdlDisplayFormat ptr >>= maybePeek mkFinalizedSurface + +-- | Converts a surface to the display format. Throws an exception on error. +displayFormat :: Surface -> IO Surface +displayFormat = unwrapMaybe "SDL_DisplayFormat" . tryDisplayFormat + +-- SDL_Surface *SDL_DisplayFormatAlpha(SDL_Surface *surface); +foreign import ccall unsafe "SDL_DisplayFormatAlpha" sdlDisplayFormatAlpha :: Ptr SurfaceStruct -> IO (Ptr SurfaceStruct) + +-- | Converts a surface to the display format. Returns @Nothing@ on error. +tryDisplayFormatAlpha :: Surface -> IO (Maybe Surface) +tryDisplayFormatAlpha surface + = withForeignPtr surface $ \ptr -> + sdlDisplayFormatAlpha ptr >>= maybePeek mkFinalizedSurface + +-- | Converts a surface to the display format. Throws an exception on error. +displayFormatAlpha :: Surface -> IO Surface +displayFormatAlpha = unwrapMaybe "SDL_DisplayFormatAlpha" . tryDisplayFormat + +-- void SDL_WarpMouse(Uint16 x, Uint16 y); +foreign import ccall unsafe "SDL_WarpMouse" sdlWarpMouse :: Word16 -> Word16 -> IO () + +-- | Sets the position of the mouse cursor. +warpMouse :: Word16 -- ^ Mouse X position. + -> Word16 -- ^ Mouse Y position. + -> IO () +warpMouse = sdlWarpMouse + +-- int SDL_ShowCursor(int toggle); +foreign import ccall unsafe "SDL_ShowCursor" sdlShowCursor :: Int -> IO Int + +-- | Toggle whether or not the cursor is shown on the screen. +showCursor :: Bool -> IO () +showCursor enable + = sdlShowCursor (fromToggle toggle) >> + return () + where toggle = case enable of + True -> Enable + False -> Disable + +-- | Returns @True@ when the cursor is set to visible. See also 'showCursor'. +queryCursorState :: IO Bool +queryCursorState = fmap toBool (sdlShowCursor (fromToggle Query)) + + +type GLAttr = Int +type GLValue = Int + +glRedSize, glGreenSize, glBlueSize, glAlphaSize, glBufferSize, glDoubleBuffer :: GLAttr +glDepthSize, glStencilSize, glAccumRedSize, glAccumGreenSize, glAccumBlueSize :: GLAttr +glAccumAlphaSize, glStereo, glMultiSampleBuffers, glMultiSampleSamples :: GLAttr + +glRedSize = #{const SDL_GL_RED_SIZE} +glGreenSize = #{const SDL_GL_GREEN_SIZE} +glBlueSize = #{const SDL_GL_BLUE_SIZE} +glAlphaSize = #{const SDL_GL_ALPHA_SIZE} +glBufferSize = #{const SDL_GL_BUFFER_SIZE} +glDoubleBuffer = #{const SDL_GL_DOUBLEBUFFER} +glDepthSize = #{const SDL_GL_DEPTH_SIZE} +glStencilSize = #{const SDL_GL_STENCIL_SIZE} +glAccumRedSize = #{const SDL_GL_ACCUM_RED_SIZE} +glAccumGreenSize = #{const SDL_GL_ACCUM_GREEN_SIZE} +glAccumBlueSize = #{const SDL_GL_ACCUM_BLUE_SIZE} +glAccumAlphaSize = #{const SDL_GL_ACCUM_ALPHA_SIZE} +glStereo = #{const SDL_GL_STEREO} +glMultiSampleBuffers = #{const SDL_GL_MULTISAMPLEBUFFERS} +glMultiSampleSamples = #{const SDL_GL_MULTISAMPLESAMPLES} + +--int SDL_GL_SetAttribute(SDL_GLattr attr, int value); +foreign import ccall unsafe "SDL_GL_SetAttribute" sdlGLSetAttribute :: Int -> Int -> IO Int +-- | Sets a special SDL\/OpenGL attribute. Returns @False@ on error. +tryGLSetAttribute :: GLAttr -> GLValue -> IO Bool +tryGLSetAttribute attr value = fmap (==0) (sdlGLSetAttribute attr value) + +-- | Sets a special SDL\/OpenGL attribute. Throws an exception on error. +glSetAttribute :: GLAttr -> GLValue -> IO () +glSetAttribute attr value = unwrapBool "SDL_GL_SetAttribute" (tryGLSetAttribute attr value) + +-- int SDL_GL_GetAttribute(SDLGLattr attr, int *value); +foreign import ccall unsafe "SDL_GL_GetAttribute" sdlGLGetAttribute :: Int -> Ptr Int -> IO Int + +-- | Gets the value of a special SDL\/OpenGL attribute. Returns @Nothing@ on error. +tryGLGetAttribute :: GLAttr -> IO (Maybe GLValue) +tryGLGetAttribute attr + = alloca $ \valuePtr -> + do ret <- sdlGLGetAttribute attr valuePtr + case ret of + 0 -> fmap Just (peek valuePtr) + _ -> return Nothing + +-- | Gets the value of a special SDL\/OpenGL attribute. Throws an exception on error. +glGetAttribute :: GLAttr -> IO GLValue +glGetAttribute = unwrapMaybe "SDL_GL_GetAttribute" . tryGLGetAttribute + +--void SDLCALL SDL_GL_SwapBuffers(void); +-- | Swaps OpenGL framebuffers\/Update Display. +foreign import ccall unsafe "SDL_GL_SwapBuffers" glSwapBuffers :: IO () + +foreign import ccall unsafe "&SDL_FreeSurface" sdlFreeSurfaceFinal :: FunPtr (Ptr SurfaceStruct -> IO ()) + +mkFinalizedSurface :: Ptr SurfaceStruct -> IO Surface +mkFinalizedSurface = newForeignPtr sdlFreeSurfaceFinal + diff --git a/Graphics/UI/SDL/WindowManagement.hsc b/Graphics/UI/SDL/WindowManagement.hsc new file mode 100644 --- /dev/null +++ b/Graphics/UI/SDL/WindowManagement.hsc @@ -0,0 +1,110 @@ +#include "SDL.h" +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.SDL.WindowManagement +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- +module Graphics.UI.SDL.WindowManagement + ( GrabMode (..) + , setCaption + , rawSetCaption + , getCaption + , iconifyWindow + , tryToggleFullscreen + , toggleFullscreen + , grabInput + , queryGrabMode + ) where + +import Foreign (Int32, Ptr, Storable(peek), nullPtr, toBool, maybePeek, + void, alloca, withForeignPtr) +import Foreign.C (withCString, peekCString, CString) + +import Graphics.UI.SDL.Types (Surface, SurfaceStruct) +import Graphics.UI.SDL.General (unwrapBool) + + +data GrabMode + = GrabQuery + | GrabOff + | GrabOn + deriving (Show,Eq) + +toGrabMode :: #{type SDL_GrabMode} -> GrabMode +toGrabMode (#{const SDL_GRAB_QUERY}) = GrabQuery +toGrabMode (#{const SDL_GRAB_OFF}) = GrabOff +toGrabMode (#{const SDL_GRAB_ON}) = GrabOn +toGrabMode _ = error "Graphics.UI.SDL.WindowManagement.toGrabMode: bad argument" + +fromGrabMode :: GrabMode -> #{type SDL_GrabMode} +fromGrabMode GrabQuery = (#{const SDL_GRAB_QUERY}) +fromGrabMode GrabOff = (#{const SDL_GRAB_OFF}) +fromGrabMode GrabOn = (#{const SDL_GRAB_ON}) + +-- void SDL_WM_SetCaption(const char *title, const char *icon); +foreign import ccall unsafe "SDL_WM_SetCaption" sdlSetCaption :: CString -> CString -> IO () +-- | Sets the window title and icon name. +setCaption :: String -> String -> IO () +setCaption title icon + = withCString title $ \titlePtr -> + withCString icon $ \iconPtr -> + sdlSetCaption titlePtr iconPtr + +-- | Sets the window title and icon name. Use @Nothing@ to unset. +rawSetCaption :: Maybe String -> Maybe String -> IO () +rawSetCaption title icon + = maybeStr title $ \titlePtr -> + maybeStr icon $ \iconPtr -> + sdlSetCaption titlePtr iconPtr + where maybeStr Nothing action = action nullPtr + maybeStr (Just s) action = withCString s action +-- void SDL_WM_GetCaption(char **title, char **icon); +foreign import ccall unsafe "SDL_WM_GetCaption" sdlGetCaption :: Ptr CString -> Ptr CString -> IO () +-- | Gets the window title and icon name. +getCaption :: IO (Maybe String,Maybe String) +getCaption + = alloca $ \cTitle -> + alloca $ \cIcon -> + do sdlGetCaption cTitle cIcon + title <- maybePeek ((peekCString =<<).peek) cTitle + icon <- maybePeek ((peekCString =<<).peek) cIcon + return (title,icon) + +-- int SDL_WM_IconifyWindow(void); +foreign import ccall unsafe "SDL_WM_IconifyWindow" sdlIconifyWindow :: IO Int +-- | Iconify\/Minimise the window. +iconifyWindow :: IO Bool +iconifyWindow = fmap toBool sdlIconifyWindow + +-- int SDL_WM_ToggleFullScreen(SDL_Surface *surface); +foreign import ccall unsafe "SDL_WM_ToggleFullScreen" sdlToggleFullScreen :: Ptr SurfaceStruct -> IO Int +-- |Toggles fullscreen mode. Returns @False@ on error. +tryToggleFullscreen :: Surface -> IO Bool +tryToggleFullscreen surface + = withForeignPtr surface $ fmap toBool . sdlToggleFullScreen + +-- | Toggles fullscreen mode. Throws an exception on error. +toggleFullscreen :: Surface -> IO () +toggleFullscreen = unwrapBool "SDL_WM_ToggleFullScreen" . tryToggleFullscreen + +-- SDL_GrabMode SDL_WM_GrabInput(SDL_GrabMode mode); +foreign import ccall unsafe "SDL_WM_GrabInput" sdlGrabInput :: #{type SDL_GrabMode} -> IO #{type SDL_GrabMode} +-- | Grabbing means that the mouse is confined to the application +-- window, and nearly all keyboard input is passed directly to +-- the application, and not interpreted by a window manager, if any. +grabInput :: Bool -> IO () +grabInput = void . sdlGrabInput . fromGrabMode . mkGrabMode + where mkGrabMode True = GrabOn + mkGrabMode False = GrabOff + +-- | Returns the current grabbing mode. +queryGrabMode :: IO GrabMode +queryGrabMode = fmap toGrabMode . sdlGrabInput . fromGrabMode $ GrabQuery + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,35 @@ +Copyright (c) 2004-2006, David Himmelstrup +All rights reserved. + +Redistribution and use in source and binary forms, +with or without modification, are permitted provided +that the following conditions are met: + + * Redistributions of source code must retain + the above copyright notice, this list of + conditions and the following disclaimer. + * Redistributions in binary form must reproduce + the above copyright notice, this list of + conditions and the following disclaimer in the + documentation and/or other materials provided + with the distribution. + * Neither the name of David Himmelstrup nor the + names of other contributors may be used to + endorse or promote products derived from this + software without specific prior written permission. + + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND +CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY +OF SUCH DAMAGE. diff --git a/SDL.cabal b/SDL.cabal new file mode 100644 --- /dev/null +++ b/SDL.cabal @@ -0,0 +1,34 @@ +Name: SDL +Version: 0.4.0 +Maintainer: Lemmih (lemmih@gmail.com) +Author: Lemmih (lemmih@gmail.com) +Copyright: 2004-2005, Lemmih +License-File: LICENSE +License: BSD3 +Build-Depends: base +Category: Foreign binding +Synopsis: Binding to libSDL +Tested-with: GHC ==6.4, Hugs ==20050308 +Extensions: CPP, ForeignFunctionInterface, MultiParamTypeClasses, FunctionalDependencies +Exposed-Modules: + Graphics.UI.SDL, + Graphics.UI.SDL.CPUInfo, + Graphics.UI.SDL.General, + Graphics.UI.SDL.Video, + Graphics.UI.SDL.WindowManagement, + Graphics.UI.SDL.Audio, + Graphics.UI.SDL.Events, + Graphics.UI.SDL.Time, + Graphics.UI.SDL.Keysym, + Graphics.UI.SDL.Color, + Graphics.UI.SDL.RWOps, + Graphics.UI.SDL.Types, + Graphics.UI.SDL.Rect, + Graphics.UI.SDL.Utilities, + Graphics.UI.SDL.Version, + Graphics.UI.SDL.Joystick +Includes: SDL.h +-- Include-Dirs: /usr/local/lib/ghc-6.4.1/include, /sw/include/SDL +Extra-Libraries: SDL +Frameworks: AppKit +GHC-Options: -fglasgow-exts -Wall -Werror diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMainWithHooks defaultUserHooks