module Game.GoreAndAsh.SDL.API(
MonadSDL(..)
, WindowConfig(..)
, RendererConfig(..)
, RendererType(..)
, module ReExport
, keyScancode
, keyPress
, keyRelease
, keyPressing
, mouseScroll
, mouseScrollX
, mouseScrollY
, mouseClick
, windowClosed
) where
import Control.Lens ((^.))
import Control.Monad.Catch
import Control.Monad.State.Strict
import Control.Wire
import Control.Wire.Unsafe.Event
import Data.Int
import Data.Sequence (Seq)
import Data.Text (Text)
import Data.Word
import Foreign
import GHC.Generics
import Linear
import Linear.Affine
import Prelude hiding (id, (.))
import qualified Data.HashMap.Strict as H
import qualified Data.Sequence as S
import SDL as ReExport hiding (get, Event)
import SDL.Internal.Types
import qualified SDL.Raw as SDLRaw
import Game.GoreAndAsh
import Game.GoreAndAsh.SDL.Module
import Game.GoreAndAsh.SDL.State
data SDL'ModuleException =
SDL'ConflictingWindows !Text
deriving (Generic, Show)
instance Exception SDL'ModuleException
class (MonadIO m, MonadThrow m) => MonadSDL m where
sdlCreateWindowM ::
Text
-> Text
-> WindowConfig
-> RendererConfig
-> m (Window, Renderer)
sdlGetWindowM ::
Text
-> m (Maybe (Window, Renderer))
sdlDestroyWindowM ::
Text
-> m ()
sdlSetBackColor ::
Text
-> V4 Word8
-> m ()
sdlWindowShownEventsM :: m (Seq WindowShownEventData)
sdlWindowHiddenEventsM :: m (Seq WindowHiddenEventData)
sdlWindowExposedEventsM :: m (Seq WindowExposedEventData)
sdlWindowMovedEventsM :: m (Seq WindowMovedEventData)
sdlWindowResizedEventsM :: m (Seq WindowResizedEventData)
sdlWindowSizeChangedEventsM :: m (Seq WindowSizeChangedEventData)
sdlWindowMinimizedEventsM :: m (Seq WindowMinimizedEventData)
sdlWindowMaximizedEventsM :: m (Seq WindowMaximizedEventData)
sdlWindowRestoredEventsM :: m (Seq WindowRestoredEventData)
sdlWindowGainedMouseFocusEventsM :: m (Seq WindowGainedMouseFocusEventData)
sdlWindowLostMouseFocusEventsM :: m (Seq WindowLostMouseFocusEventData)
sdlWindowGainedKeyboardFocusEventsM :: m (Seq WindowGainedKeyboardFocusEventData)
sdlWindowLostKeyboardFocusEventsM :: m (Seq WindowLostKeyboardFocusEventData)
sdlWindowClosedEventsM :: m (Seq WindowClosedEventData)
sdlKeyboardEventsM :: m (Seq KeyboardEventData)
sdlTextEditingEventsM :: m (Seq TextEditingEventData)
sdlTextInputEventsM :: m (Seq TextInputEventData)
sdlMouseMotionEventsM :: m (Seq MouseMotionEventData)
sdlMouseButtonEventsM :: m (Seq MouseButtonEventData)
sdlMouseWheelEventsM :: m (Seq MouseWheelEventData)
sdlJoyAxisEventsM :: m (Seq JoyAxisEventData)
sdlJoyBallEventsM :: m (Seq JoyBallEventData)
sdlJoyHatEventsM :: m (Seq JoyHatEventData)
sdlJoyButtonEventsM :: m (Seq JoyButtonEventData)
sdlJoyDeviceEventsM :: m (Seq JoyDeviceEventData)
sdlControllerAxisEventsM :: m (Seq ControllerAxisEventData)
sdlControllerButtonEventsM :: m (Seq ControllerButtonEventData)
sdlControllerDeviceEventsM :: m (Seq ControllerDeviceEventData)
sdlQuitEventM :: m Bool
sdlUserEventsM :: m (Seq UserEventData)
sdlSysWMEventsM :: m (Seq SysWMEventData)
sdlTouchFingerEventsM :: m (Seq TouchFingerEventData)
sdlMultiGestureEventsM :: m (Seq MultiGestureEventData)
sdlDollarGestureEventsM :: m (Seq DollarGestureEventData)
sdlDropEventsM :: m (Seq DropEventData)
sdlClipboardUpdateEventsM :: m (Seq ClipboardUpdateEventData)
instance (MonadIO m, MonadThrow m) => MonadSDL (SDLT s m) where
sdlCreateWindowM n t wc rc = do
w <- createWindow t wc
r <- createRenderer w (1) rc
s <- SDLT get
case H.lookup n . sdlWindows $! s of
Just _ -> throwM . SDL'ConflictingWindows $! n
Nothing -> do
SDLT . put $! s {
sdlWindows = H.insert n (w, r, defColor) . sdlWindows $! s
}
return (w, r)
where
defColor = V4 0 0 0 255
sdlGetWindowM n = do
s <- SDLT get
return . fmap (\(w, r, _) -> (w, r)) . H.lookup n . sdlWindows $! s
sdlDestroyWindowM n = do
s <- SDLT get
case H.lookup n . sdlWindows $! s of
Just (w, r, _) -> do
destroyRenderer r
destroyWindow w
SDLT . put $! s {
sdlWindows = H.delete n . sdlWindows $! s
}
Nothing -> return ()
sdlSetBackColor n c = do
s <- SDLT get
case H.lookup n . sdlWindows $! s of
Just (w, r, _) -> SDLT . put $! s {
sdlWindows = H.insert n (w, r, c) . sdlWindows $! s
}
Nothing -> return ()
sdlWindowShownEventsM = sdlWindowShownEvents <$> get
sdlWindowHiddenEventsM = sdlWindowHiddenEvents <$> get
sdlWindowExposedEventsM = sdlWindowExposedEvents <$> get
sdlWindowMovedEventsM = sdlWindowMovedEvents <$> get
sdlWindowResizedEventsM = sdlWindowResizedEvents <$> get
sdlWindowSizeChangedEventsM = sdlWindowSizeChangedEvents <$> get
sdlWindowMinimizedEventsM = sdlWindowMinimizedEvents <$> get
sdlWindowMaximizedEventsM = sdlWindowMaximizedEvents <$> get
sdlWindowRestoredEventsM = sdlWindowRestoredEvents <$> get
sdlWindowGainedMouseFocusEventsM = sdlWindowGainedMouseFocusEvents <$> get
sdlWindowLostMouseFocusEventsM = sdlWindowLostMouseFocusEvents <$> get
sdlWindowGainedKeyboardFocusEventsM = sdlWindowGainedKeyboardFocusEvents <$> get
sdlWindowLostKeyboardFocusEventsM = sdlWindowLostKeyboardFocusEvents <$> get
sdlWindowClosedEventsM = sdlWindowClosedEvents <$> get
sdlKeyboardEventsM = sdlKeyboardEvents <$> get
sdlTextEditingEventsM = sdlTextEditingEvents <$> get
sdlTextInputEventsM = sdlTextInputEvents <$> get
sdlMouseMotionEventsM = sdlMouseMotionEvents <$> get
sdlMouseButtonEventsM = sdlMouseButtonEvents <$> get
sdlMouseWheelEventsM = sdlMouseWheelEvents <$> get
sdlJoyAxisEventsM = sdlJoyAxisEvents <$> get
sdlJoyBallEventsM = sdlJoyBallEvents <$> get
sdlJoyHatEventsM = sdlJoyHatEvents <$> get
sdlJoyButtonEventsM = sdlJoyButtonEvents <$> get
sdlJoyDeviceEventsM = sdlJoyDeviceEvents <$> get
sdlControllerAxisEventsM = sdlControllerAxisEvents <$> get
sdlControllerButtonEventsM = sdlControllerButtonEvents <$> get
sdlControllerDeviceEventsM = sdlControllerDeviceEvents <$> get
sdlQuitEventM = sdlQuitEvent <$> get
sdlUserEventsM = sdlUserEvents <$> get
sdlSysWMEventsM = sdlSysWMEvents <$> get
sdlTouchFingerEventsM = sdlTouchFingerEvents <$> get
sdlMultiGestureEventsM = sdlMultiGestureEvents <$> get
sdlDollarGestureEventsM = sdlDollarGestureEvents <$> get
sdlDropEventsM = sdlDropEvents <$> get
sdlClipboardUpdateEventsM = sdlClipboardUpdateEvents <$> get
instance (MonadIO (mt m), MonadThrow (mt m), MonadSDL m, MonadTrans mt) => MonadSDL (mt m) where
sdlCreateWindowM n t wc rc = lift $ sdlCreateWindowM n t wc rc
sdlGetWindowM = lift . sdlGetWindowM
sdlDestroyWindowM = lift . sdlDestroyWindowM
sdlSetBackColor a b = lift $ sdlSetBackColor a b
sdlWindowShownEventsM = lift sdlWindowShownEventsM
sdlWindowHiddenEventsM = lift sdlWindowHiddenEventsM
sdlWindowExposedEventsM = lift sdlWindowExposedEventsM
sdlWindowMovedEventsM = lift sdlWindowMovedEventsM
sdlWindowResizedEventsM = lift sdlWindowResizedEventsM
sdlWindowSizeChangedEventsM = lift sdlWindowSizeChangedEventsM
sdlWindowMinimizedEventsM = lift sdlWindowMinimizedEventsM
sdlWindowMaximizedEventsM = lift sdlWindowMaximizedEventsM
sdlWindowRestoredEventsM = lift sdlWindowRestoredEventsM
sdlWindowGainedMouseFocusEventsM = lift sdlWindowGainedMouseFocusEventsM
sdlWindowLostMouseFocusEventsM = lift sdlWindowLostMouseFocusEventsM
sdlWindowGainedKeyboardFocusEventsM = lift sdlWindowGainedKeyboardFocusEventsM
sdlWindowLostKeyboardFocusEventsM = lift sdlWindowLostKeyboardFocusEventsM
sdlWindowClosedEventsM = lift sdlWindowClosedEventsM
sdlKeyboardEventsM = lift sdlKeyboardEventsM
sdlTextEditingEventsM = lift sdlTextEditingEventsM
sdlTextInputEventsM = lift sdlTextInputEventsM
sdlMouseMotionEventsM = lift sdlMouseMotionEventsM
sdlMouseButtonEventsM = lift sdlMouseButtonEventsM
sdlMouseWheelEventsM = lift sdlMouseWheelEventsM
sdlJoyAxisEventsM = lift sdlJoyAxisEventsM
sdlJoyBallEventsM = lift sdlJoyBallEventsM
sdlJoyHatEventsM = lift sdlJoyHatEventsM
sdlJoyButtonEventsM = lift sdlJoyButtonEventsM
sdlJoyDeviceEventsM = lift sdlJoyDeviceEventsM
sdlControllerAxisEventsM = lift sdlControllerAxisEventsM
sdlControllerButtonEventsM = lift sdlControllerButtonEventsM
sdlControllerDeviceEventsM = lift sdlControllerDeviceEventsM
sdlQuitEventM = lift sdlQuitEventM
sdlUserEventsM = lift sdlUserEventsM
sdlSysWMEventsM = lift sdlSysWMEventsM
sdlTouchFingerEventsM = lift sdlTouchFingerEventsM
sdlMultiGestureEventsM = lift sdlMultiGestureEventsM
sdlDollarGestureEventsM = lift sdlDollarGestureEventsM
sdlDropEventsM = lift sdlDropEventsM
sdlClipboardUpdateEventsM = lift sdlClipboardUpdateEventsM
keyScancode :: MonadSDL m => Scancode -> InputMotion -> GameWire m a (Event (Seq KeyboardEventData))
keyScancode sc im = liftGameMonad $ do
es <- S.filter isNeeded <$> sdlKeyboardEventsM
return $! if S.null es
then NoEvent
else Event es
where
isNeeded KeyboardEventData{..} = keyboardEventKeyMotion == im
&& sc == keysymScancode keyboardEventKeysym
keyPress :: MonadSDL m => Scancode -> GameWire m a (Event (Seq KeyboardEventData))
keyPress sc = keyScancode sc Pressed
keyRelease :: MonadSDL m => Scancode -> GameWire m a (Event (Seq KeyboardEventData))
keyRelease sc = keyScancode sc Released
keyPressing :: MonadSDL m => Scancode -> GameWire m a (Event KeyboardEventData)
keyPressing sc = go NoEvent
where
go !e = mkGen $ \_ _ -> do
!mks <- S.viewr . S.filter isNeeded <$> sdlKeyboardEventsM
return $! case mks of
S.EmptyR -> (Right e, go e)
_ S.:> mds@KeyboardEventData{..} -> case keyboardEventKeyMotion of
Pressed -> (Right $! Event mds, go $! Event mds)
Released -> (Right NoEvent, go NoEvent)
isNeeded KeyboardEventData{..} = sc == keysymScancode keyboardEventKeysym
mouseScroll :: MonadSDL m => GameWire m a (Event (V2 Int32))
mouseScroll = liftGameMonad $ do
es <- sdlMouseWheelEventsM
return $! if S.null es
then NoEvent
else Event . sumV . fmap mouseWheelEventPos $! es
mouseScrollX :: MonadSDL m => GameWire m a (Event Int32)
mouseScrollX = mapE (^. _x) . mouseScroll
mouseScrollY :: MonadSDL m => GameWire m a (Event Int32)
mouseScrollY = mapE (^. _y) . mouseScroll
windowClosed :: MonadSDL m => Text -> GameWire m a (Event ())
windowClosed n = go Nothing
where
go Nothing = mkGen $ \_ _ -> do
mr <- sdlGetWindowM n
return $! case mr of
Nothing -> (Right NoEvent, go Nothing)
Just (w, _) -> (Right NoEvent, go $ Just w)
go (Just w) = liftGameMonad $ do
es <- S.filter isNeeded <$> sdlWindowClosedEventsM
return $! if S.null es
then NoEvent
else Event ()
where
isNeeded WindowClosedEventData{..} = windowClosedEventWindow == w
mouseClick :: MonadSDL m => MouseButton -> GameWire m a (Event (V2 Double))
mouseClick mb = liftGameMonad $ do
es <- S.filter isNeeded <$> sdlMouseButtonEventsM
case S.viewr es of
S.EmptyR -> return NoEvent
_ S.:> MouseButtonEventData{..} -> do
(size :: V2 Int) <- getWindowSize mouseButtonEventWindow
return . Event $! transformCoords size mouseButtonEventPos
where
isNeeded MouseButtonEventData{..} = mouseButtonEventButton == mb && mouseButtonEventMotion == Pressed
transformCoords (V2 w h) (P (V2 xi yi)) =
inv33 (viewportTransform2D 0 (V2 (fromIntegral w) (fromIntegral h)))
`applyTransform2D`
V2 (fromIntegral xi) (fromIntegral yi)
getWindowSize :: (MonadIO m, Integral a) => Window -> m (V2 a)
getWindowSize (Window wptr) = liftIO $ with 0 $ \xptr -> with 0 $ \yptr -> do
SDLRaw.getWindowSize wptr xptr yptr
x <- peek xptr
y <- peek yptr
return $! V2 (fromIntegral x) (fromIntegral y)