module SDL.Input.Mouse
(
LocationMode(..)
, setMouseLocationMode
, getMouseLocationMode
, setRelativeMouseMode --deprecated
, getRelativeMouseMode --deprecated
, MouseButton(..)
, MouseDevice(..)
, getModalMouseLocation
, getMouseLocation --deprecated
, getAbsoluteMouseLocation
, getRelativeMouseLocation
, getMouseButtons
, WarpMouseOrigin
, warpMouse
, cursorVisible
, Cursor
, activeCursor
, createCursor
, freeCursor
, createColorCursor
) where
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Bits
import Data.Bool
import Data.Data (Data)
import Data.StateVar
import Data.Typeable
import Data.Word
import Foreign.C
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import GHC.Generics (Generic)
import Linear
import Linear.Affine
import SDL.Exception
import SDL.Internal.Numbered
import SDL.Internal.Types (Window(Window))
import SDL.Video.Renderer (Surface(Surface))
import qualified Data.Vector.Storable as V
import qualified SDL.Raw.Enum as Raw
import qualified SDL.Raw.Event as Raw
import qualified SDL.Raw.Types as Raw
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
data LocationMode = AbsoluteLocation | RelativeLocation deriving Eq
setMouseLocationMode :: (Functor m, MonadIO m) => LocationMode -> m LocationMode
setMouseLocationMode mode =
Raw.setRelativeMouseMode (mode == RelativeLocation) >> getMouseLocationMode
getMouseLocationMode :: MonadIO m => m LocationMode
getMouseLocationMode = do
relativeMode <- Raw.getRelativeMouseMode
return $ if relativeMode then RelativeLocation else AbsoluteLocation
getModalMouseLocation :: MonadIO m => m (LocationMode, Point V2 CInt)
getModalMouseLocation = do
mode <- getMouseLocationMode
location <- case mode of
RelativeLocation -> getRelativeMouseLocation
_ -> getAbsoluteMouseLocation
return (mode, location)
setRelativeMouseMode :: (Functor m, MonadIO m) => Bool -> m ()
setRelativeMouseMode enable =
throwIfNeg_ "SDL.Input.Mouse" "SDL_SetRelativeMouseMode" $
Raw.setRelativeMouseMode enable
--deprecated
getRelativeMouseMode :: MonadIO m => m Bool
getRelativeMouseMode = Raw.getRelativeMouseMode
--deprecated
getMouseLocation :: MonadIO m => m (Point V2 CInt)
getMouseLocation = getAbsoluteMouseLocation
data MouseButton
= ButtonLeft
| ButtonMiddle
| ButtonRight
| ButtonX1
| ButtonX2
| ButtonExtra !Int
deriving (Data, Eq, Generic, Ord, Read, Show, Typeable)
data MouseDevice
= Mouse !Int
| Touch
deriving (Data, Eq, Generic, Ord, Read, Show, Typeable)
instance FromNumber MouseDevice Word32 where
fromNumber n' = case n' of
Raw.SDL_TOUCH_MOUSEID -> Touch
n -> Mouse $ fromIntegral n
data WarpMouseOrigin
= WarpInWindow Window
| WarpCurrentFocus
deriving (Data, Eq, Generic, Ord, Show, Typeable)
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
cursorVisible :: StateVar Bool
cursorVisible = makeStateVar getCursorVisible setCursorVisible
where
setCursorVisible :: (Functor m, MonadIO m) => Bool -> m ()
setCursorVisible True = void $ Raw.showCursor 1
setCursorVisible False = void $ Raw.showCursor 0
getCursorVisible :: (Functor m, MonadIO m) => m Bool
getCursorVisible = (== 1) <$> Raw.showCursor (1)
getAbsoluteMouseLocation :: MonadIO m => m (Point V2 CInt)
getAbsoluteMouseLocation = liftIO $
alloca $ \x ->
alloca $ \y -> do
_ <- Raw.getMouseState x y
P <$> (V2 <$> peek x <*> peek y)
getRelativeMouseLocation :: MonadIO m => m (Point V2 CInt)
getRelativeMouseLocation = liftIO $
alloca $ \x ->
alloca $ \y -> do
_ <- Raw.getRelativeMouseState x y
P <$> (V2 <$> peek x <*> peek y)
getMouseButtons :: MonadIO m => m (MouseButton -> Bool)
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
newtype Cursor = Cursor { unwrapCursor :: Raw.Cursor }
deriving (Eq, Typeable)
activeCursor :: StateVar Cursor
activeCursor = makeStateVar getCursor setCursor
where
getCursor :: MonadIO m => m Cursor
getCursor = liftIO . fmap Cursor $
throwIfNull "SDL.Input.Mouse.getCursor" "SDL_getCursor"
Raw.getCursor
setCursor :: MonadIO m => Cursor -> m ()
setCursor = Raw.setCursor . unwrapCursor
createCursor :: MonadIO m
=> V.Vector Bool
-> V.Vector Bool
-> V2 CInt
-> Point V2 CInt
-> m Cursor
createCursor dta msk (V2 w h) (P (V2 hx hy)) =
liftIO . fmap Cursor $
throwIfNull "SDL.Input.Mouse.createCursor" "SDL_createCursor" $
V.unsafeWith (V.map (bool 0 1) dta) $ \unsafeDta ->
V.unsafeWith (V.map (bool 0 1) msk) $ \unsafeMsk ->
Raw.createCursor unsafeDta unsafeMsk w h hx hy
freeCursor :: MonadIO m => Cursor -> m ()
freeCursor = Raw.freeCursor . unwrapCursor
createColorCursor :: MonadIO m
=> Surface
-> Point V2 CInt
-> m Cursor
createColorCursor (Surface surfPtr _) (P (V2 hx hy)) =
liftIO . fmap Cursor $
throwIfNull "SDL.Input.Mouse.createColorCursor" "SDL_createColorCursor" $
Raw.createColorCursor surfPtr hx hy