diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,28 @@ +Unreleased +========== + + + +2.3.0 +===== + +* Windows builds now use `-D_SDL_main_h`. See https://github.com/haskell-game/sdl2/issues/139 for more discussion. +* Some basic support for game controller events have been added. See `SDL.Input.GameController` and changes to `ControllerDeviceEventData`. +* Support for event watching: `addEventWatch` and `delEventWatch`. +* High-level bindings now distinguish between finger down / motion / up. + See SDL.Event.TouchFingerEvent and SDL.Event.TouchFingerMotionEvent. +* Several event payloads now have their `Window` fields modified to use `Maybe Window`, substituting `Nothing` for null pointers. +* High-level structure for controller button state: `ControllerButtonState`. +* High-level structure for controller buttons: `ControllerButton`. +* High-level structure for controller connection: `ControllerDeviceConnection`. +* High-level structure for joystick device connection: `JoyDeviceConnection`. +* High-level structure for joystick button state: `JoyButtonState`. +* Support for user defined events: `registerEvent`, `pushRegisteredEvent`, and `getRegisteredEvent`. +* Initial window visibility can be specified in `WindowConfig` for `createWindow` function. +* `WarpMouseOrigin` is now fully exported and can warp to global coordinates. +* It's possible to retrieve palette information with `paletteNColors`, `paletteColors` and `palletColor`. + + 2.2.0 ===== @@ -43,7 +68,7 @@ * `getRelativeMouseMode` in `SDL.Input.Mouse` * `getMouseLocation` in `SDL.Input.Mouse` * Remove `ClipboardUpdateEventData` -* Merge `isScreenSaverEnabled, `enableScreenSaver`, and `disableScreenSaver` +* Merge `isScreenSaverEnabled`, `enableScreenSaver`, and `disableScreenSaver` into a `screenSaverEnabled` StateVar. * Make function `surfaceBlit` in `SDL.Video.Renderer` return final blit rectangle post-clipping. diff --git a/examples/EventWatch.hs b/examples/EventWatch.hs new file mode 100644 --- /dev/null +++ b/examples/EventWatch.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| + +The following example shows how setting a watch for the WindowSizeChangedEvent +allows us to handle the events as they are generated. Handling them in the +event loop, on the other hand, only allows us to see a final, coalesced, event. + +To demonstrate this, run the program, resize the window with your mouse, +and check your console output. + +-} +module EventWatch where + +import SDL + +main :: IO () +main = do + initializeAll + window <- createWindow "resize" WindowConfig { + windowBorder = True + , windowHighDPI = False + , windowInputGrabbed = False + , windowMode = Windowed + , windowOpenGL = Nothing + , windowPosition = Wherever + , windowResizable = True + , windowInitialSize = V2 800 600 + , windowVisible = True + } + renderer <- createRenderer window (-1) defaultRenderer + addEventWatch $ \ev -> + case eventPayload ev of + WindowSizeChangedEvent sizeChangeData -> + putStrLn $ "eventWatch windowSizeChanged: " ++ show sizeChangeData + _ -> return () + appLoop + +appLoop :: IO () +appLoop = waitEvent >>= go + where + go :: Event -> IO () + go ev = + case eventPayload ev of + WindowSizeChangedEvent sizeChangeData -> do + putStrLn $ "waitEvent windowSizeChanged: " ++ show sizeChangeData + waitEvent >>= go + KeyboardEvent keyboardEvent + | keyboardEventKeyMotion keyboardEvent == Pressed && + keysymKeycode (keyboardEventKeysym keyboardEvent) == KeycodeQ + -> return () + _ -> waitEvent >>= go diff --git a/examples/UserEvents.hs b/examples/UserEvents.hs new file mode 100644 --- /dev/null +++ b/examples/UserEvents.hs @@ -0,0 +1,64 @@ +module UserEvents where + +import Control.Concurrent (myThreadId) +import Data.Maybe (Maybe(Nothing)) +import Data.Word (Word32) +import qualified Data.Text as Text +import Foreign.Ptr (nullPtr) +import SDL + +-- | A timer event with timestamp +data TimerEvent = TimerEvent Word32 + +timerEvent :: IO TimerEvent +timerEvent = do + t <- show <$> ticks + tid <- show <$> myThreadId + putStrLn $ "Created timer event at " ++ t ++ " ticks. Threadid: " ++ tid + return $ TimerEvent 0 + +main :: IO () +main = do + initializeAll + let toTimerEvent _ = return . Just . TimerEvent + fromTimerEvent = const $ return emptyRegisteredEvent + registeredEvent <- registerEvent toTimerEvent fromTimerEvent + case registeredEvent of + Nothing -> putStrLn "Fatal error: unable to register timer events." + Just registeredTimerEvent -> do + addTimer 1000 $ mkTimerCb registeredTimerEvent + putStrLn "press q at any time to quit" + appLoop registeredTimerEvent + +mkTimerCb :: RegisteredEventType TimerEvent -> TimerCallback +mkTimerCb (RegisteredEventType pushTimerEvent _) interval = do + pushResult <- pushTimerEvent =<< timerEvent + case pushResult of + EventPushSuccess -> return () + EventPushFiltered -> putStrLn "event push was filtered: this is impossible" + EventPushFailure e -> putStrLn $ "Couldn't push event: " ++ Text.unpack e + return $ Reschedule interval + +appLoop :: RegisteredEventType TimerEvent -> IO () +appLoop (RegisteredEventType pushTimerEvent getTimerEvent) = waitEvent >>= go + where + go :: Event -> IO () + go ev = + case eventPayload ev of + -- Press Q to quit + KeyboardEvent keyboardEvent + | keyboardEventKeyMotion keyboardEvent == Pressed && + keysymKeycode (keyboardEventKeysym keyboardEvent) == KeycodeQ + -> return () + UserEvent _ -> do + maybeTimerEvent <- getTimerEvent ev + case maybeTimerEvent of + Just (TimerEvent ts) -> do + t <- show <$> ticks + tid <- show <$> myThreadId + putStrLn $ "Got timer event from queue at " ++ t ++ " ticks." + putStrLn $ "Timestamp: " ++ show ts + putStrLn $ "Threadid: " ++ tid + Nothing -> return () + waitEvent >>= go + _ -> waitEvent >>= go diff --git a/sdl2.cabal b/sdl2.cabal --- a/sdl2.cabal +++ b/sdl2.cabal @@ -1,5 +1,5 @@ name: sdl2 -version: 2.2.0 +version: 2.3.0 synopsis: Both high- and low-level bindings to the SDL library (version 2.0.4+). description: This package contains bindings to the SDL 2 library, in both high- and @@ -65,6 +65,7 @@ SDL.Hint SDL.Init SDL.Input + SDL.Input.GameController SDL.Input.Joystick SDL.Input.Keyboard SDL.Input.Keyboard.Codes @@ -136,6 +137,9 @@ default-language: Haskell2010 + if os(windows) + cpp-options: -D_SDL_main_h + executable lazyfoo-lesson-01 if flag(examples) build-depends: base, sdl2 @@ -414,6 +418,27 @@ default-language: Haskell2010 ghc-options: -main-is AudioExample -threaded +executable eventwatch-example + if flag(examples) + build-depends: base, sdl2 + else + buildable: False + + hs-source-dirs: examples + main-is: EventWatch.hs + default-language: Haskell2010 + ghc-options: -main-is EventWatch + +executable userevent-example + if flag(examples) + build-depends: base, text, sdl2 + else + buildable: False + + hs-source-dirs: examples + main-is: UserEvents.hs + default-language: Haskell2010 + ghc-options: -main-is UserEvents executable opengl-example if flag(opengl-example) diff --git a/src/SDL/Event.hs b/src/SDL/Event.hs --- a/src/SDL/Event.hs +++ b/src/SDL/Event.hs @@ -17,8 +17,20 @@ , pumpEvents , waitEvent , waitEventTimeout + -- * Registering user events + , RegisteredEventType(..) + , RegisteredEventData(..) + , EventPushResult(..) + , emptyRegisteredEvent + , registerEvent + -- * Watching events + , EventWatchCallback + , EventWatch + , addEventWatch + , delEventWatch -- * Event data , Event(..) + , Timestamp , EventPayload(..) -- ** Window events , WindowShownEventData(..) @@ -60,6 +72,7 @@ , UserEventData(..) -- ** Touch events , TouchFingerEventData(..) + , TouchFingerMotionEventData(..) -- ** Gesture events , MultiGestureEventData(..) , DollarGestureEventData(..) @@ -82,6 +95,7 @@ import GHC.Generics (Generic) import SDL.Vect import SDL.Input.Joystick +import SDL.Input.GameController import SDL.Input.Keyboard import SDL.Input.Mouse import SDL.Internal.Exception @@ -97,12 +111,14 @@ -- | A single SDL event. This event occured at 'eventTimestamp' and carries data under 'eventPayload'. data Event = Event - { eventTimestamp :: Word32 + { eventTimestamp :: Timestamp -- ^ The time the event occured. , eventPayload :: EventPayload -- ^ Data pertaining to this event. } deriving (Eq, Ord, Generic, Show, Typeable) +type Timestamp = Word32 + -- | An enumeration of all possible SDL event types. This data type pairs up event types with -- their payload, where possible. data EventPayload @@ -140,6 +156,7 @@ | UserEvent !UserEventData | SysWMEvent !SysWMEventData | TouchFingerEvent !TouchFingerEventData + | TouchFingerMotionEvent !TouchFingerMotionEventData | MultiGestureEvent !MultiGestureEventData | DollarGestureEvent !DollarGestureEventData | DropEvent !DropEventData @@ -148,22 +165,22 @@ deriving (Eq, Ord, Generic, Show, Typeable) -- | A window has been shown. -data WindowShownEventData = - WindowShownEventData {windowShownEventWindow :: !Window +newtype WindowShownEventData = + WindowShownEventData {windowShownEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | A window has been hidden. -data WindowHiddenEventData = - WindowHiddenEventData {windowHiddenEventWindow :: !Window +newtype WindowHiddenEventData = + WindowHiddenEventData {windowHiddenEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | A part of a window has been exposed - where exposure means to become visible (for example, an overlapping window no longer overlaps with the window). -data WindowExposedEventData = - WindowExposedEventData {windowExposedEventWindow :: !Window +newtype WindowExposedEventData = + WindowExposedEventData {windowExposedEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) @@ -187,72 +204,72 @@ deriving (Eq,Ord,Generic,Show,Typeable) -- | The window size has changed, either as a result of an API call or through the system or user changing the window size; this event is followed by 'WindowResizedEvent' if the size was changed by an external event, i.e. the user or the window manager. -data WindowSizeChangedEventData = - WindowSizeChangedEventData {windowSizeChangedEventWindow :: !Window +newtype WindowSizeChangedEventData = + WindowSizeChangedEventData {windowSizeChangedEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window has been minimized. -data WindowMinimizedEventData = - WindowMinimizedEventData {windowMinimizedEventWindow :: !Window +newtype WindowMinimizedEventData = + WindowMinimizedEventData {windowMinimizedEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window has been maximized. -data WindowMaximizedEventData = - WindowMaximizedEventData {windowMaximizedEventWindow :: !Window +newtype WindowMaximizedEventData = + WindowMaximizedEventData {windowMaximizedEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window has been restored to normal size and position. -data WindowRestoredEventData = - WindowRestoredEventData {windowRestoredEventWindow :: !Window +newtype WindowRestoredEventData = + WindowRestoredEventData {windowRestoredEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window has gained mouse focus. -data WindowGainedMouseFocusEventData = - WindowGainedMouseFocusEventData {windowGainedMouseFocusEventWindow :: !Window +newtype WindowGainedMouseFocusEventData = + WindowGainedMouseFocusEventData {windowGainedMouseFocusEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window has lost mouse focus. -data WindowLostMouseFocusEventData = - WindowLostMouseFocusEventData {windowLostMouseFocusEventWindow :: !Window +newtype WindowLostMouseFocusEventData = + WindowLostMouseFocusEventData {windowLostMouseFocusEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window has gained keyboard focus. -data WindowGainedKeyboardFocusEventData = - WindowGainedKeyboardFocusEventData {windowGainedKeyboardFocusEventWindow :: !Window +newtype WindowGainedKeyboardFocusEventData = + WindowGainedKeyboardFocusEventData {windowGainedKeyboardFocusEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window has lost keyboard focus. -data WindowLostKeyboardFocusEventData = - WindowLostKeyboardFocusEventData {windowLostKeyboardFocusEventWindow :: !Window +newtype WindowLostKeyboardFocusEventData = + WindowLostKeyboardFocusEventData {windowLostKeyboardFocusEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | The window manager requests that the window be closed. -data WindowClosedEventData = - WindowClosedEventData {windowClosedEventWindow :: !Window +newtype WindowClosedEventData = + WindowClosedEventData {windowClosedEventWindow :: Window -- ^ The associated 'Window'. } deriving (Eq,Ord,Generic,Show,Typeable) -- | A keyboard key has been pressed or released. data KeyboardEventData = - KeyboardEventData {keyboardEventWindow :: !Window - -- ^ The associated 'Window'. + KeyboardEventData {keyboardEventWindow :: !(Maybe Window) + -- ^ The 'Window' with keyboard focus, if any. ,keyboardEventKeyMotion :: !InputMotion -- ^ Whether the key was pressed or released. ,keyboardEventRepeat :: !Bool @@ -264,8 +281,8 @@ -- | Keyboard text editing event information. data TextEditingEventData = - TextEditingEventData {textEditingEventWindow :: !Window - -- ^ The associated 'Window'. + TextEditingEventData {textEditingEventWindow :: !(Maybe Window) + -- ^ The 'Window' with keyboard focus, if any. ,textEditingEventText :: !Text -- ^ The editing text. ,textEditingEventStart :: !Int32 @@ -277,8 +294,8 @@ -- | Keyboard text input event information. data TextInputEventData = - TextInputEventData {textInputEventWindow :: !Window - -- ^ The associated 'Window'. + TextInputEventData {textInputEventWindow :: !(Maybe Window) + -- ^ The 'Window' with keyboard focus, if any. ,textInputEventText :: !Text -- ^ The input text. } @@ -286,8 +303,8 @@ -- | A mouse or pointer device was moved. data MouseMotionEventData = - MouseMotionEventData {mouseMotionEventWindow :: !Window - -- ^ The associated 'Window'. + MouseMotionEventData {mouseMotionEventWindow :: !(Maybe Window) + -- ^ The 'Window' with mouse focus, if any. ,mouseMotionEventWhich :: !MouseDevice -- ^ The 'MouseDevice' that was moved. ,mouseMotionEventState :: ![MouseButton] @@ -301,8 +318,8 @@ -- | A mouse or pointer device button was pressed or released. data MouseButtonEventData = - MouseButtonEventData {mouseButtonEventWindow :: !Window - -- ^ The associated 'Window'. + MouseButtonEventData {mouseButtonEventWindow :: !(Maybe Window) + -- ^ The 'Window' with mouse focus, if any. ,mouseButtonEventMotion :: !InputMotion -- ^ Whether the button was pressed or released. ,mouseButtonEventWhich :: !MouseDevice @@ -318,8 +335,8 @@ -- | Mouse wheel event information. data MouseWheelEventData = - MouseWheelEventData {mouseWheelEventWindow :: !Window - -- ^ The associated 'Window'. + MouseWheelEventData {mouseWheelEventWindow :: !(Maybe Window) + -- ^ The 'Window' with mouse focus, if any. ,mouseWheelEventWhich :: !MouseDevice -- ^ The 'MouseDevice' whose wheel was scrolled. ,mouseWheelEventPos :: !(V2 Int32) @@ -368,14 +385,16 @@ -- ^ The instance id of the joystick that reported the event. ,joyButtonEventButton :: !Word8 -- ^ The index of the button that changed. - ,joyButtonEventState :: !Word8 + ,joyButtonEventState :: !JoyButtonState -- ^ The state of the button. } deriving (Eq,Ord,Generic,Show,Typeable) -- | Joystick device event information. data JoyDeviceEventData = - JoyDeviceEventData {joyDeviceEventWhich :: !Int32 + JoyDeviceEventData {joyDeviceEventConnection :: !JoyDeviceConnection + -- ^ Was the device added or removed? + ,joyDeviceEventWhich :: !Int32 -- ^ The instance id of the joystick that reported the event. } deriving (Eq,Ord,Generic,Show,Typeable) @@ -395,16 +414,18 @@ data ControllerButtonEventData = ControllerButtonEventData {controllerButtonEventWhich :: !Raw.JoystickID -- ^ The joystick instance ID that reported the event. - ,controllerButtonEventButton :: !Word8 + ,controllerButtonEventButton :: !ControllerButton -- ^ The controller button. - ,controllerButtonEventState :: !Word8 + ,controllerButtonEventState :: !ControllerButtonState -- ^ The state of the button. } deriving (Eq,Ord,Generic,Show,Typeable) -- | Controller device event information data ControllerDeviceEventData = - ControllerDeviceEventData {controllerDeviceEventWhich :: !Int32 + ControllerDeviceEventData {controllerDeviceEventConnection :: !ControllerDeviceConnection + -- ^ Was the device added, removed, or remapped? + ,controllerDeviceEventWhich :: !Int32 -- ^ The joystick instance ID that reported the event. } deriving (Eq,Ord,Generic,Show,Typeable) @@ -421,7 +442,9 @@ -- | Event data for application-defined events. data UserEventData = - UserEventData {userEventWindow :: !Window + UserEventData {userEventType :: !Word32 + -- ^ User defined event type. + ,userEventWindow :: !(Maybe Window) -- ^ The associated 'Window'. ,userEventCode :: !Int32 -- ^ User defined event code. @@ -433,8 +456,8 @@ deriving (Eq,Ord,Generic,Show,Typeable) -- | A video driver dependent system event -data SysWMEventData = - SysWMEventData {sysWMEventMsg :: !Raw.SysWMmsg} +newtype SysWMEventData = + SysWMEventData {sysWMEventMsg :: Raw.SysWMmsg} deriving (Eq,Ord,Generic,Show,Typeable) -- | Finger touch event information. @@ -443,15 +466,30 @@ -- ^ The touch device index. ,touchFingerEventFingerID :: !Raw.FingerID -- ^ The finger index. + ,touchFingerEventMotion :: !InputMotion + -- ^ Whether the finger was pressed or released. ,touchFingerEventPos :: !(Point V2 CFloat) -- ^ The location of the touch event, normalized between 0 and 1. - ,touchFingerEventRelMotion :: !(V2 CFloat) - -- ^ The distance moved, normalized between -1 and 1. ,touchFingerEventPressure :: !CFloat -- ^ The quantity of the pressure applied, normalized between 0 and 1. } deriving (Eq,Ord,Generic,Show,Typeable) +-- | Finger motion event information. +data TouchFingerMotionEventData = + TouchFingerMotionEventData {touchFingerMotionEventTouchID :: !Raw.TouchID + -- ^ The touch device index. + ,touchFingerMotionEventFingerID :: !Raw.FingerID + -- ^ The finger index. + ,touchFingerMotionEventPos :: !(Point V2 CFloat) + -- ^ The location of the touch event, normalized between 0 and 1. + ,touchFingerMotionEventRelMotion :: !(V2 CFloat) + -- ^ The distance moved, normalized between -1 and 1. + ,touchFingerMotionEventPressure :: !CFloat + -- ^ The quantity of the pressure applied, normalized between 0 and 1. + } + deriving (Eq,Ord,Generic,Show,Typeable) + -- | Multiple finger gesture event information data MultiGestureEventData = MultiGestureEventData {multiGestureEventTouchID :: !Raw.TouchID @@ -483,15 +521,15 @@ deriving (Eq,Ord,Generic,Show,Typeable) -- | An event used to request a file open by the system -data DropEventData = - DropEventData {dropEventFile :: !CString +newtype DropEventData = + DropEventData {dropEventFile :: CString -- ^ The file name. } deriving (Eq,Ord,Generic,Show,Typeable) -- | SDL reported an unknown event type. -data UnknownEventData = - UnknownEventData {unknownEventType :: !Word32 +newtype UnknownEventData = + UnknownEventData {unknownEventType :: Word32 -- ^ The unknown event code. } deriving (Eq,Ord,Generic,Show,Typeable) @@ -511,78 +549,78 @@ convertRaw :: Raw.Event -> IO Event convertRaw (Raw.WindowEvent t ts a b c d) = - do w' <- fmap Window (Raw.getWindowFromID a) + do w <- fmap Window (Raw.getWindowFromID a) return (Event ts (case b of Raw.SDL_WINDOWEVENT_SHOWN -> - WindowShownEvent (WindowShownEventData w') + WindowShownEvent (WindowShownEventData w) Raw.SDL_WINDOWEVENT_HIDDEN -> - WindowHiddenEvent (WindowHiddenEventData w') + WindowHiddenEvent (WindowHiddenEventData w) Raw.SDL_WINDOWEVENT_EXPOSED -> - WindowExposedEvent (WindowExposedEventData w') + WindowExposedEvent (WindowExposedEventData w) Raw.SDL_WINDOWEVENT_MOVED -> WindowMovedEvent - (WindowMovedEventData w' + (WindowMovedEventData w (P (V2 c d))) Raw.SDL_WINDOWEVENT_RESIZED -> WindowResizedEvent - (WindowResizedEventData w' + (WindowResizedEventData w (V2 c d)) Raw.SDL_WINDOWEVENT_SIZE_CHANGED -> - WindowSizeChangedEvent (WindowSizeChangedEventData w') + WindowSizeChangedEvent (WindowSizeChangedEventData w) Raw.SDL_WINDOWEVENT_MINIMIZED -> - WindowMinimizedEvent (WindowMinimizedEventData w') + WindowMinimizedEvent (WindowMinimizedEventData w) Raw.SDL_WINDOWEVENT_MAXIMIZED -> - WindowMaximizedEvent (WindowMaximizedEventData w') + WindowMaximizedEvent (WindowMaximizedEventData w) Raw.SDL_WINDOWEVENT_RESTORED -> - WindowRestoredEvent (WindowRestoredEventData w') + WindowRestoredEvent (WindowRestoredEventData w) Raw.SDL_WINDOWEVENT_ENTER -> - WindowGainedMouseFocusEvent (WindowGainedMouseFocusEventData w') + WindowGainedMouseFocusEvent (WindowGainedMouseFocusEventData w) Raw.SDL_WINDOWEVENT_LEAVE -> - WindowLostMouseFocusEvent (WindowLostMouseFocusEventData w') + WindowLostMouseFocusEvent (WindowLostMouseFocusEventData w) Raw.SDL_WINDOWEVENT_FOCUS_GAINED -> - WindowGainedKeyboardFocusEvent (WindowGainedKeyboardFocusEventData w') + WindowGainedKeyboardFocusEvent (WindowGainedKeyboardFocusEventData w) Raw.SDL_WINDOWEVENT_FOCUS_LOST -> - WindowLostKeyboardFocusEvent (WindowLostKeyboardFocusEventData w') + WindowLostKeyboardFocusEvent (WindowLostKeyboardFocusEventData w) Raw.SDL_WINDOWEVENT_CLOSE -> - WindowClosedEvent (WindowClosedEventData w') + WindowClosedEvent (WindowClosedEventData w) _ -> UnknownEvent (UnknownEventData t))) convertRaw (Raw.KeyboardEvent Raw.SDL_KEYDOWN ts a _ c d) = - do w' <- fmap Window (Raw.getWindowFromID a) + do w <- getWindowFromID a return (Event ts (KeyboardEvent - (KeyboardEventData w' + (KeyboardEventData w Pressed (c /= 0) (fromRawKeysym d)))) convertRaw (Raw.KeyboardEvent Raw.SDL_KEYUP ts a _ c d) = - do w' <- fmap Window (Raw.getWindowFromID a) + do w <- getWindowFromID a return (Event ts (KeyboardEvent - (KeyboardEventData w' + (KeyboardEventData w Released (c /= 0) (fromRawKeysym d)))) -convertRaw (Raw.KeyboardEvent _ _ _ _ _ _) = error "convertRaw: Unknown keyboard motion" +convertRaw Raw.KeyboardEvent{} = error "convertRaw: Unknown keyboard motion" convertRaw (Raw.TextEditingEvent _ ts a b c d) = - do w' <- fmap Window (Raw.getWindowFromID a) + do w <- getWindowFromID a return (Event ts (TextEditingEvent - (TextEditingEventData w' + (TextEditingEventData w (ccharStringToText b) c d))) convertRaw (Raw.TextInputEvent _ ts a b) = - do w' <- fmap Window (Raw.getWindowFromID a) + do w <- getWindowFromID a return (Event ts (TextInputEvent - (TextInputEventData w' + (TextInputEventData w (ccharStringToText b)))) convertRaw (Raw.KeymapChangedEvent _ ts) = return (Event ts KeymapChangedEvent) convertRaw (Raw.MouseMotionEvent _ ts a b c d e f g) = - do w' <- fmap Window (Raw.getWindowFromID a) + do w <- getWindowFromID a let buttons = catMaybes [(Raw.SDL_BUTTON_LMASK `test` c) ButtonLeft ,(Raw.SDL_BUTTON_RMASK `test` c) ButtonRight @@ -591,7 +629,7 @@ ,(Raw.SDL_BUTTON_X2MASK `test` c) ButtonX2] return (Event ts (MouseMotionEvent - (MouseMotionEventData w' + (MouseMotionEventData w (fromNumber b) buttons (P (V2 d e)) @@ -601,31 +639,24 @@ then Just else const Nothing convertRaw (Raw.MouseButtonEvent t ts a b c _ e f g) = - do w' <- fmap Window (Raw.getWindowFromID a) + do w <- getWindowFromID a let motion | t == Raw.SDL_MOUSEBUTTONUP = Released | t == Raw.SDL_MOUSEBUTTONDOWN = Pressed | otherwise = error "convertRaw: Unexpected mouse button motion" - button - | c == Raw.SDL_BUTTON_LEFT = ButtonLeft - | c == Raw.SDL_BUTTON_MIDDLE = ButtonMiddle - | c == Raw.SDL_BUTTON_RIGHT = ButtonRight - | c == Raw.SDL_BUTTON_X1 = ButtonX1 - | c == Raw.SDL_BUTTON_X2 = ButtonX2 - | otherwise = ButtonExtra $ fromIntegral c return (Event ts (MouseButtonEvent - (MouseButtonEventData w' + (MouseButtonEventData w motion (fromNumber b) - button + (fromNumber c) e (P (V2 f g))))) convertRaw (Raw.MouseWheelEvent _ ts a b c d e) = - do w' <- fmap Window (Raw.getWindowFromID a) + do w <- getWindowFromID a return (Event ts (MouseWheelEvent - (MouseWheelEventData w' + (MouseWheelEventData w (fromNumber b) (V2 c d) (fromNumber e)))) @@ -644,36 +675,50 @@ b (fromNumber c)))) convertRaw (Raw.JoyButtonEvent _ ts a b c) = - return (Event ts (JoyButtonEvent (JoyButtonEventData a b c))) -convertRaw (Raw.JoyDeviceEvent _ ts a) = - return (Event ts (JoyDeviceEvent (JoyDeviceEventData a))) + return (Event ts (JoyButtonEvent (JoyButtonEventData a b (fromNumber c)))) +convertRaw (Raw.JoyDeviceEvent t ts a) = + return (Event ts (JoyDeviceEvent (JoyDeviceEventData (fromNumber t) a))) convertRaw (Raw.ControllerAxisEvent _ ts a b c) = return (Event ts (ControllerAxisEvent (ControllerAxisEventData a b c))) convertRaw (Raw.ControllerButtonEvent _ ts a b c) = - return (Event ts (ControllerButtonEvent (ControllerButtonEventData a b c))) -convertRaw (Raw.ControllerDeviceEvent _ ts a) = - return (Event ts (ControllerDeviceEvent (ControllerDeviceEventData a))) + return (Event ts + (ControllerButtonEvent + (ControllerButtonEventData a + (fromNumber $ fromIntegral b) + (fromNumber c)))) +convertRaw (Raw.ControllerDeviceEvent t ts a) = + return (Event ts (ControllerDeviceEvent (ControllerDeviceEventData (fromNumber t) a))) convertRaw (Raw.AudioDeviceEvent Raw.SDL_AUDIODEVICEADDED ts a b) = return (Event ts (AudioDeviceEvent (AudioDeviceEventData True a (b /= 0)))) convertRaw (Raw.AudioDeviceEvent Raw.SDL_AUDIODEVICEREMOVED ts a b) = return (Event ts (AudioDeviceEvent (AudioDeviceEventData False a (b /= 0)))) -convertRaw (Raw.AudioDeviceEvent _ _ _ _) = +convertRaw Raw.AudioDeviceEvent{} = error "convertRaw: Unknown audio device motion" convertRaw (Raw.QuitEvent _ ts) = return (Event ts QuitEvent) -convertRaw (Raw.UserEvent _ ts a b c d) = - do w' <- fmap Window (Raw.getWindowFromID a) - return (Event ts (UserEvent (UserEventData w' b c d))) +convertRaw (Raw.UserEvent t ts a b c d) = + do w <- getWindowFromID a + return (Event ts (UserEvent (UserEventData t w b c d))) convertRaw (Raw.SysWMEvent _ ts a) = return (Event ts (SysWMEvent (SysWMEventData a))) -convertRaw (Raw.TouchFingerEvent _ ts a b c d e f g) = - return (Event ts - (TouchFingerEvent - (TouchFingerEventData a - b - (P (V2 c d)) - (V2 e f) - g))) +convertRaw (Raw.TouchFingerEvent t ts a b c d e f g) = + do let touchFingerEvent motion = TouchFingerEvent + (TouchFingerEventData a + b + motion + (P (V2 c d)) + g) + let touchFingerMotionEvent = TouchFingerMotionEvent + (TouchFingerMotionEventData a + b + (P (V2 c d)) + (V2 e f) + g) + case t of + Raw.SDL_FINGERDOWN -> return (Event ts (touchFingerEvent Pressed)) + Raw.SDL_FINGERUP -> return (Event ts (touchFingerEvent Released)) + Raw.SDL_FINGERMOTION -> return (Event ts touchFingerMotionEvent) + _ -> error "convertRaw: Unexpected touch finger event" convertRaw (Raw.MultiGestureEvent _ ts a b c d e f) = return (Event ts (MultiGestureEvent @@ -740,6 +785,76 @@ then return Nothing else fmap Just (peek e >>= convertRaw) +-- | A user defined event structure that has been registered with SDL. +-- +-- Use 'registerEvent', below, to obtain an instance. +data RegisteredEventType a = + RegisteredEventType {pushRegisteredEvent :: a -> IO EventPushResult + ,getRegisteredEvent :: Event -> IO (Maybe a) + } + +-- | A record used to convert between SDL Events and user-defined data structures. +-- +-- Used for 'registerEvent', below. +data RegisteredEventData = + RegisteredEventData {registeredEventWindow :: !(Maybe Window) + -- ^ The associated 'Window'. + ,registeredEventCode :: !Int32 + -- ^ User defined event code. + ,registeredEventData1 :: !(Ptr ()) + -- ^ User defined data pointer. + ,registeredEventData2 :: !(Ptr ()) + -- ^ User defined data pointer. + } + deriving (Eq,Ord,Generic,Show,Typeable) + +-- | A registered event with no associated data. +-- +-- This is a resonable baseline to modify for converting to +-- 'RegisteredEventData'. +emptyRegisteredEvent :: RegisteredEventData +emptyRegisteredEvent = RegisteredEventData Nothing 0 nullPtr nullPtr + +-- | Possible results of an attempted push of an event to the queue. +data EventPushResult = EventPushSuccess | EventPushFiltered | EventPushFailure Text + deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) + +-- | Register a new event type with SDL. +-- +-- Provide functions that convert between 'UserEventData' and your structure. +-- You can then use 'pushRegisteredEvent' to add a custom event of the +-- registered type to the queue, and 'getRegisteredEvent' to test for such +-- events in the main loop. +registerEvent :: MonadIO m + => (RegisteredEventData -> Timestamp -> IO (Maybe a)) + -> (a -> IO RegisteredEventData) + -> m (Maybe (RegisteredEventType a)) +registerEvent registeredEventDataToEvent eventToRegisteredEventData = do + typ <- Raw.registerEvents 1 + if typ == maxBound + then return Nothing + else + let pushEv ev = do + RegisteredEventData mWin code d1 d2 <- eventToRegisteredEventData ev + windowID <- case mWin of + Just (Window w) -> Raw.getWindowID w + Nothing -> return 0 + -- timestamp will be filled in by SDL + let rawEvent = Raw.UserEvent typ 0 windowID code d1 d2 + liftIO . alloca $ \eventPtr -> do + poke eventPtr rawEvent + pushResult <- Raw.pushEvent eventPtr + case pushResult of + 1 -> return $ EventPushSuccess + 0 -> return $ EventPushFiltered + _ -> EventPushFailure <$> getError + + getEv (Event ts (UserEvent (UserEventData typ mWin code d1 d2))) = + registeredEventDataToEvent (RegisteredEventData mWin code d1 d2) ts + getEv _ = return Nothing + + in return . Just $ RegisteredEventType pushEv getEv + -- | Pump the event loop, gathering events from the input devices. -- -- This function updates the event queue and internal input device state. @@ -751,3 +866,38 @@ -- See @@ for C documentation. pumpEvents :: MonadIO m => m () pumpEvents = Raw.pumpEvents + +-- | An 'EventWatchCallback' can process and respond to an event +-- when it is added to the event queue. +type EventWatchCallback = Event -> IO () +newtype EventWatch = EventWatch {runEventWatchRemoval :: IO ()} + +-- | Trigger an 'EventWatchCallback' when an event is added to the SDL +-- event queue. +-- +-- See @@ for C documentation. +addEventWatch :: MonadIO m => EventWatchCallback -> m EventWatch +addEventWatch callback = liftIO $ do + rawFilter <- Raw.mkEventFilter wrappedCb + Raw.addEventWatch rawFilter nullPtr + return (EventWatch $ auxRemove rawFilter) + where + wrappedCb :: Ptr () -> Ptr Raw.Event -> IO CInt + wrappedCb _ evPtr = 0 <$ (callback =<< convertRaw =<< peek evPtr) + + auxRemove :: Raw.EventFilter -> IO () + auxRemove rawFilter = do + Raw.delEventWatch rawFilter nullPtr + freeHaskellFunPtr rawFilter + +-- | Remove an 'EventWatch'. +-- +-- See @@ for C documentation. +delEventWatch :: MonadIO m => EventWatch -> m () +delEventWatch = liftIO . runEventWatchRemoval + +-- | Checks raw Windows for null references. +getWindowFromID :: MonadIO m => Word32 -> m (Maybe Window) +getWindowFromID id = do + rawWindow <- Raw.getWindowFromID id + return $ if rawWindow == nullPtr then Nothing else Just $ Window rawWindow diff --git a/src/SDL/Input/GameController.hs b/src/SDL/Input/GameController.hs new file mode 100644 --- /dev/null +++ b/src/SDL/Input/GameController.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} + +module SDL.Input.GameController + ( ControllerButton(..) + , ControllerButtonState(..) + , ControllerDeviceConnection(..) + ) where + +import Data.Data (Data) +import Data.Typeable +import Data.Word +import GHC.Generics (Generic) +import GHC.Int (Int32) +import SDL.Internal.Numbered +import qualified SDL.Raw as Raw + +-- | Identifies a gamepad button. +data ControllerButton + = ControllerButtonInvalid + | ControllerButtonA + | ControllerButtonB + | ControllerButtonX + | ControllerButtonY + | ControllerButtonBack + | ControllerButtonGuide + | ControllerButtonStart + | ControllerButtonLeftStick + | ControllerButtonRightStick + | ControllerButtonLeftShoulder + | ControllerButtonRightShoulder + | ControllerButtonDpadUp + | ControllerButtonDpadDown + | ControllerButtonDpadLeft + | ControllerButtonDpadRight + deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) + +instance FromNumber ControllerButton Int32 where + fromNumber n = case n of + Raw.SDL_CONTROLLER_BUTTON_A -> ControllerButtonA + Raw.SDL_CONTROLLER_BUTTON_B -> ControllerButtonB + Raw.SDL_CONTROLLER_BUTTON_X -> ControllerButtonX + Raw.SDL_CONTROLLER_BUTTON_Y -> ControllerButtonY + Raw.SDL_CONTROLLER_BUTTON_BACK -> ControllerButtonBack + Raw.SDL_CONTROLLER_BUTTON_GUIDE -> ControllerButtonGuide + Raw.SDL_CONTROLLER_BUTTON_START -> ControllerButtonStart + Raw.SDL_CONTROLLER_BUTTON_LEFTSTICK -> ControllerButtonLeftStick + Raw.SDL_CONTROLLER_BUTTON_RIGHTSTICK -> ControllerButtonRightStick + Raw.SDL_CONTROLLER_BUTTON_LEFTSHOULDER -> ControllerButtonLeftShoulder + Raw.SDL_CONTROLLER_BUTTON_RIGHTSHOULDER -> ControllerButtonRightShoulder + Raw.SDL_CONTROLLER_BUTTON_DPAD_UP -> ControllerButtonDpadUp + Raw.SDL_CONTROLLER_BUTTON_DPAD_DOWN -> ControllerButtonDpadDown + Raw.SDL_CONTROLLER_BUTTON_DPAD_LEFT -> ControllerButtonDpadLeft + Raw.SDL_CONTROLLER_BUTTON_DPAD_RIGHT -> ControllerButtonDpadRight + _ -> ControllerButtonInvalid + +-- | Identifies the state of a controller button. +data ControllerButtonState = ControllerButtonPressed | ControllerButtonReleased + deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) + +instance FromNumber ControllerButtonState Word8 where + fromNumber n = case n of + Raw.SDL_PRESSED -> ControllerButtonPressed + Raw.SDL_RELEASED -> ControllerButtonReleased + _ -> ControllerButtonPressed + +-- | Identified whether the game controller was added, removed, or remapped. +data ControllerDeviceConnection + = ControllerDeviceAdded + | ControllerDeviceRemoved + | ControllerDeviceRemapped + deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) + +instance FromNumber ControllerDeviceConnection Word32 where + fromNumber n = case n of + Raw.SDL_CONTROLLERDEVICEADDED -> ControllerDeviceAdded + Raw.SDL_CONTROLLERDEVICEREMOVED -> ControllerDeviceRemoved + _ -> ControllerDeviceRemapped diff --git a/src/SDL/Input/Joystick.hs b/src/SDL/Input/Joystick.hs --- a/src/SDL/Input/Joystick.hs +++ b/src/SDL/Input/Joystick.hs @@ -15,6 +15,7 @@ , getJoystickID , Joystick + , JoyButtonState(..) , buttonPressed , ballDelta , axisPosition @@ -24,6 +25,7 @@ , JoyHatPosition(..) , getHat , numHats + , JoyDeviceConnection(..) ) where import Control.Monad.IO.Class (MonadIO, liftIO) @@ -57,6 +59,16 @@ , joystickDeviceId :: CInt } deriving (Eq, Generic, Read, Ord, Show, Typeable) +-- | Identifies the state of a joystick button. +data JoyButtonState = JoyButtonPressed | JoyButtonReleased + deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) + +instance FromNumber JoyButtonState Word8 where + fromNumber n = case n of + Raw.SDL_PRESSED -> JoyButtonPressed + Raw.SDL_RELEASED -> JoyButtonReleased + _ -> JoyButtonReleased + -- | Count the number of joysticks attached to the system. -- -- See @@ for C documentation. @@ -195,3 +207,13 @@ -- See @@ for C documentation. numHats :: (MonadIO m) => Joystick -> m CInt numHats (Joystick j) = liftIO $ throwIfNeg "SDL.Input.Joystick.numHats" "SDL_JoystickNumHats" (Raw.joystickNumHats j) + +-- | Identifies whether a joystick has been connected or disconnected. +data JoyDeviceConnection = JoyDeviceAdded | JoyDeviceRemoved + deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) + +instance FromNumber JoyDeviceConnection Word32 where + fromNumber n = case n of + Raw.SDL_JOYDEVICEADDED -> JoyDeviceAdded + Raw.SDL_JOYDEVICEREMOVED -> JoyDeviceRemoved + _ -> JoyDeviceAdded diff --git a/src/SDL/Input/Mouse.hs b/src/SDL/Input/Mouse.hs --- a/src/SDL/Input/Mouse.hs +++ b/src/SDL/Input/Mouse.hs @@ -23,7 +23,7 @@ , getMouseButtons -- * Warping the Mouse - , WarpMouseOrigin + , WarpMouseOrigin(..) , warpMouse -- * Cursor Visibility @@ -99,6 +99,22 @@ | ButtonExtra !Int -- ^ An unknown mouse button. deriving (Data, Eq, Generic, Ord, Read, Show, Typeable) +instance FromNumber MouseButton Word8 where + fromNumber Raw.SDL_BUTTON_LEFT = ButtonLeft + fromNumber Raw.SDL_BUTTON_MIDDLE = ButtonMiddle + fromNumber Raw.SDL_BUTTON_RIGHT = ButtonRight + fromNumber Raw.SDL_BUTTON_X1 = ButtonX1 + fromNumber Raw.SDL_BUTTON_X2 = ButtonX2 + fromNumber buttonCode = ButtonExtra $ fromIntegral buttonCode + +instance ToNumber MouseButton Word8 where + toNumber ButtonLeft = Raw.SDL_BUTTON_LEFT + toNumber ButtonMiddle = Raw.SDL_BUTTON_MIDDLE + toNumber ButtonRight = Raw.SDL_BUTTON_RIGHT + toNumber ButtonX1 = Raw.SDL_BUTTON_X1 + toNumber ButtonX2 = Raw.SDL_BUTTON_X2 + toNumber (ButtonExtra i) = fromIntegral i + -- | Identifies what kind of mouse-like device this is. data MouseDevice = Mouse !Int -- ^ An actual mouse. The number identifies which mouse. @@ -127,13 +143,16 @@ -- ^ Move the mouse pointer within a given 'Window'. | WarpCurrentFocus -- ^ Move the mouse pointer within whichever 'Window' currently has focus. - -- WarpGlobal -- Needs 2.0.4 + | WarpGlobal + -- ^ Move the mouse pointer in global screen space. deriving (Data, Eq, Generic, Ord, Show, Typeable) -- | Move the current location of a mouse pointer. The 'WarpMouseOrigin' specifies the origin for the given warp coordinates. warpMouse :: MonadIO m => WarpMouseOrigin -> Point V2 CInt -> m () warpMouse (WarpInWindow (Window w)) (P (V2 x y)) = Raw.warpMouseInWindow w x y warpMouse WarpCurrentFocus (P (V2 x y)) = Raw.warpMouseInWindow nullPtr x y +warpMouse WarpGlobal (P (V2 x y)) = throwIfNeg_ "SDL.Mouse.warpMouse" "SDL_WarpMouseGlobal" $ + Raw.warpMouseGlobal x y -- | Get or set whether the cursor is currently visible. -- @@ -173,15 +192,7 @@ getMouseButtons = liftIO $ convert <$> Raw.getMouseState nullPtr nullPtr where - convert w b = w `testBit` index - where - index = case b of - ButtonLeft -> 0 - ButtonMiddle -> 1 - ButtonRight -> 2 - ButtonX1 -> 3 - ButtonX2 -> 4 - ButtonExtra i -> i + convert w b = w `testBit` fromIntegral (toNumber b) newtype Cursor = Cursor { unwrapCursor :: Raw.Cursor } deriving (Eq, Typeable) diff --git a/src/SDL/Video.hs b/src/SDL/Video.hs --- a/src/SDL/Video.hs +++ b/src/SDL/Video.hs @@ -122,6 +122,7 @@ , toNumber $ windowMode config , if isJust $ windowOpenGL config then Raw.SDL_WINDOW_OPENGL else 0 , if windowResizable config then Raw.SDL_WINDOW_RESIZABLE else 0 + , if windowVisible config then 0 else Raw.SDL_WINDOW_HIDDEN ] setGLAttributes (OpenGLConfig (V4 r g b a) d s ms p) = do let (msk, v0, v1, flg) = case p of @@ -159,6 +160,7 @@ -- , 'windowPosition' = 'Wherever' -- , 'windowResizable' = False -- , 'windowInitialSize' = V2 800 600 +-- , 'windowVisible' = True -- } -- @ defaultWindow :: WindowConfig @@ -171,6 +173,7 @@ , windowPosition = Wherever , windowResizable = False , windowInitialSize = V2 800 600 + , windowVisible = True } data WindowConfig = WindowConfig @@ -182,6 +185,7 @@ , windowPosition :: WindowPosition -- ^ Defaults to 'Wherever'. , windowResizable :: Bool -- ^ Defaults to 'False'. Whether the window can be resized by the user. It is still possible to programatically change the size with 'setWindowSize'. , windowInitialSize :: V2 CInt -- ^ Defaults to @(800, 600)@. + , windowVisible :: Bool -- ^ Defaults to 'True'. } deriving (Eq, Generic, Ord, Read, Show, Typeable) data WindowMode @@ -352,6 +356,7 @@ , windowPosition = Absolute (P wPos) , windowResizable = wFlags .&. Raw.SDL_WINDOW_RESIZABLE > 0 , windowInitialSize = wSize + , windowVisible = wFlags .&. Raw.SDL_WINDOW_SHOWN > 0 } -- | Get the pixel format that is used for the given window. diff --git a/src/SDL/Video/Renderer.hs b/src/SDL/Video/Renderer.hs --- a/src/SDL/Video/Renderer.hs +++ b/src/SDL/Video/Renderer.hs @@ -73,6 +73,9 @@ -- * 'Palette's and pixel formats , Palette + , paletteNColors + , paletteColors + , paletteColor , PixelFormat(..) , SurfacePixelFormat , formatPalette @@ -159,8 +162,8 @@ surfaceBlit (Surface src _) srcRect (Surface dst _) dstLoc = liftIO $ maybeWith with srcRect $ \srcPtr -> maybeWith with (fmap (flip Rectangle 0) dstLoc) $ \dstPtr -> do - throwIfNeg "SDL.Video.blitSurface" "SDL_BlitSurface" $ - Raw.blitSurface src (castPtr srcPtr) dst (castPtr dstPtr) + _ <- throwIfNeg "SDL.Video.blitSurface" "SDL_BlitSurface" $ + Raw.blitSurface src (castPtr srcPtr) dst (castPtr dstPtr) maybe (pure Nothing) (\_ -> Just <$> peek dstPtr) dstLoc -- | Create a texture for a rendering context. @@ -433,6 +436,27 @@ where wrap p | p == nullPtr = Nothing | otherwise = Just (Palette p) + +paletteNColors :: MonadIO m => Palette -> m CInt +paletteNColors (Palette p) = liftIO $ Raw.paletteNColors <$> peek p + +paletteColors :: MonadIO m => Palette -> m (Maybe (SV.Vector (V4 Word8))) +paletteColors q@(Palette p) = do + n <- liftIO $ fromIntegral <$> paletteNColors q + let wrap p' | p' == nullPtr = Nothing + | otherwise = return p' + mv <- liftIO $ wrap . castPtr . Raw.paletteColors <$> peek p + mColor <- liftIO $ traverse newForeignPtr_ mv + return $ flip SV.unsafeFromForeignPtr0 n <$> mColor + +paletteColor :: MonadIO m => Palette -> CInt -> m (Maybe (V4 Word8)) +paletteColor q@(Palette p) i = do + rp <- liftIO $ peek p + m <- paletteNColors q + if m > i && i >= 0 then + liftIO $ fmap return . flip peekElemOff (fromIntegral i) . castPtr . Raw.paletteColors $ rp + else + return Nothing -- | Set a range of colors in a palette. --