{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module SDL.Video
( module SDL.Video.OpenGL
, module SDL.Video.Renderer
, Window
, createWindow
, defaultWindow
, WindowConfig(..)
, WindowMode(..)
, WindowPosition(..)
, destroyWindow
, hideWindow
, raiseWindow
, showWindow
, windowMinimumSize
, windowMaximumSize
, windowSize
, windowBordered
, windowBrightness
, windowGammaRamp
, windowGrab
, setWindowMode
, getWindowAbsolutePosition
, setWindowPosition
, windowTitle
, windowData
, getWindowConfig
, getWindowPixelFormat
, PixelFormat(..)
, createRenderer
, createSoftwareRenderer
, destroyRenderer
, getClipboardText
, hasClipboardText
, setClipboardText
, getDisplays
, Display(..)
, DisplayMode(..)
, VideoDriver(..)
, screenSaverEnabled
, showSimpleMessageBox
, MessageKind(..)
) where
import Prelude hiding (all, foldl, foldr, mapM_)
import Data.StateVar
import Control.Applicative
import Control.Exception
import Control.Monad (forM, unless, void)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Bits
import Data.Data (Data)
import Data.Foldable
import Data.Maybe (isJust, fromMaybe)
import Data.Monoid (First(..))
import Data.Text (Text)
import Data.Typeable
import Foreign hiding (void, throwIfNull, throwIfNeg, throwIfNeg_)
import Foreign.C
import GHC.Generics (Generic)
import SDL.Vect
import SDL.Internal.Exception
import SDL.Internal.Numbered
import SDL.Internal.Types
import SDL.Video.OpenGL
import SDL.Video.Renderer
import qualified Data.ByteString as BS
import qualified Data.Text.Encoding as Text
import qualified Data.Vector.Storable as SV
import qualified SDL.Raw as Raw
createWindow :: MonadIO m => Text -> WindowConfig -> m Window
createWindow title config = liftIO $ do
case windowOpenGL config of
Just glcfg -> setGLAttributes glcfg
Nothing -> return ()
BS.useAsCString (Text.encodeUtf8 title) $ \title' -> do
let create = Raw.createWindow title'
let create' (V2 w h) = case windowPosition config of
Centered -> let u = Raw.SDL_WINDOWPOS_CENTERED in create u u w h
Wherever -> let u = Raw.SDL_WINDOWPOS_UNDEFINED in create u u w h
Absolute (P (V2 x y)) -> create x y w h
create' (windowInitialSize config) flags >>= return . Window
where
flags = foldr (.|.) 0
[ if windowBorder config then 0 else Raw.SDL_WINDOW_BORDERLESS
, if windowHighDPI config then Raw.SDL_WINDOW_ALLOW_HIGHDPI else 0
, if windowInputGrabbed config then Raw.SDL_WINDOW_INPUT_GRABBED else 0
, 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
Core Debug v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_CORE, v0', v1', Raw.SDL_GL_CONTEXT_DEBUG_FLAG)
Core Normal v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_CORE, v0', v1', 0)
Compatibility Debug v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_COMPATIBILITY, v0', v1', Raw.SDL_GL_CONTEXT_DEBUG_FLAG)
Compatibility Normal v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_COMPATIBILITY, v0', v1', 0)
ES Debug v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_ES, v0', v1', Raw.SDL_GL_CONTEXT_DEBUG_FLAG)
ES Normal v0' v1' -> (Raw.SDL_GL_CONTEXT_PROFILE_ES, v0', v1', 0)
mapM_ (throwIfNeg_ "SDL.Video.createWindow" "SDL_GL_SetAttribute" . uncurry Raw.glSetAttribute) $
[ (Raw.SDL_GL_RED_SIZE, r)
, (Raw.SDL_GL_GREEN_SIZE, g)
, (Raw.SDL_GL_BLUE_SIZE, b)
, (Raw.SDL_GL_ALPHA_SIZE, a)
, (Raw.SDL_GL_DEPTH_SIZE, d)
, (Raw.SDL_GL_STENCIL_SIZE, s)
, (Raw.SDL_GL_MULTISAMPLEBUFFERS, if ms > 1 then 1 else 0)
, (Raw.SDL_GL_MULTISAMPLESAMPLES, if ms > 1 then ms else 0)
, (Raw.SDL_GL_CONTEXT_PROFILE_MASK, msk)
, (Raw.SDL_GL_CONTEXT_MAJOR_VERSION, v0)
, (Raw.SDL_GL_CONTEXT_MINOR_VERSION, v1)
, (Raw.SDL_GL_CONTEXT_FLAGS, flg)
]
defaultWindow :: WindowConfig
defaultWindow = WindowConfig
{ windowBorder = True
, windowHighDPI = False
, windowInputGrabbed = False
, windowMode = Windowed
, windowOpenGL = Nothing
, windowPosition = Wherever
, windowResizable = False
, windowInitialSize = V2 800 600
, windowVisible = True
}
data WindowConfig = WindowConfig
{ windowBorder :: Bool
, windowHighDPI :: Bool
, windowInputGrabbed :: Bool
, windowMode :: WindowMode
, windowOpenGL :: Maybe OpenGLConfig
, windowPosition :: WindowPosition
, windowResizable :: Bool
, windowInitialSize :: V2 CInt
, windowVisible :: Bool
} deriving (Eq, Generic, Ord, Read, Show, Typeable)
data WindowMode
= Fullscreen
| FullscreenDesktop
| Maximized
| Minimized
| Windowed
deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)
instance ToNumber WindowMode Word32 where
toNumber Fullscreen = Raw.SDL_WINDOW_FULLSCREEN
toNumber FullscreenDesktop = Raw.SDL_WINDOW_FULLSCREEN_DESKTOP
toNumber Maximized = Raw.SDL_WINDOW_MAXIMIZED
toNumber Minimized = Raw.SDL_WINDOW_MINIMIZED
toNumber Windowed = 0
instance FromNumber WindowMode Word32 where
fromNumber n = fromMaybe Windowed . getFirst $
foldMap First [
sdlWindowFullscreen
, sdlWindowFullscreenDesktop
, sdlWindowMaximized
, sdlWindowMinimized
]
where
maybeBit val msk = if n .&. msk > 0 then Just val else Nothing
sdlWindowFullscreen = maybeBit Fullscreen Raw.SDL_WINDOW_FULLSCREEN
sdlWindowFullscreenDesktop = maybeBit FullscreenDesktop Raw.SDL_WINDOW_FULLSCREEN_DESKTOP
sdlWindowMaximized = maybeBit Maximized Raw.SDL_WINDOW_MAXIMIZED
sdlWindowMinimized = maybeBit Minimized Raw.SDL_WINDOW_MINIMIZED
data WindowPosition
= Centered
| Wherever
| Absolute (Point V2 CInt)
deriving (Eq, Generic, Ord, Read, Show, Typeable)
destroyWindow :: MonadIO m => Window -> m ()
destroyWindow (Window w) = Raw.destroyWindow w
windowBordered :: Window -> StateVar Bool
windowBordered (Window w) = makeStateVar getWindowBordered setWindowBordered
where
getWindowBordered = fmap ((== 0) . (.&. Raw.SDL_WINDOW_BORDERLESS)) (Raw.getWindowFlags w)
setWindowBordered = Raw.setWindowBordered w
windowBrightness :: Window -> StateVar Float
windowBrightness (Window w) = makeStateVar getWindowBrightness setWindowBrightness
where
setWindowBrightness brightness = do
throwIfNot0_ "SDL.Video.setWindowBrightness" "SDL_SetWindowBrightness" $
Raw.setWindowBrightness w $ realToFrac brightness
getWindowBrightness =
return . realToFrac =<< Raw.getWindowBrightness w
windowGrab :: Window -> StateVar Bool
windowGrab (Window w) = makeStateVar getWindowGrab setWindowGrab
where
setWindowGrab = Raw.setWindowGrab w
getWindowGrab = Raw.getWindowGrab w
setWindowMode :: MonadIO m => Window -> WindowMode -> m ()
setWindowMode (Window w) mode =
liftIO . throwIfNot0_ "SDL.Video.setWindowMode" "SDL_SetWindowFullscreen" $
case mode of
Fullscreen -> Raw.setWindowFullscreen w Raw.SDL_WINDOW_FULLSCREEN <* Raw.raiseWindow w
FullscreenDesktop -> Raw.setWindowFullscreen w Raw.SDL_WINDOW_FULLSCREEN_DESKTOP <* Raw.raiseWindow w
Maximized -> Raw.setWindowFullscreen w 0 <* Raw.maximizeWindow w
Minimized -> Raw.minimizeWindow w >> return 0
Windowed -> Raw.setWindowFullscreen w 0 <* Raw.restoreWindow w
setWindowPosition :: MonadIO m => Window -> WindowPosition -> m ()
setWindowPosition (Window w) pos = case pos of
Centered -> let u = Raw.SDL_WINDOWPOS_CENTERED in Raw.setWindowPosition w u u
Wherever -> let u = Raw.SDL_WINDOWPOS_UNDEFINED in Raw.setWindowPosition w u u
Absolute (P (V2 x y)) -> Raw.setWindowPosition w x y
getWindowAbsolutePosition :: MonadIO m => Window -> m (V2 CInt)
getWindowAbsolutePosition (Window w) =
liftIO $
alloca $ \wPtr ->
alloca $ \hPtr -> do
Raw.getWindowPosition w wPtr hPtr
V2 <$> peek wPtr <*> peek hPtr
windowSize :: Window -> StateVar (V2 CInt)
windowSize (Window win) = makeStateVar getWindowSize setWindowSize
where
setWindowSize (V2 w h) = Raw.setWindowSize win w h
getWindowSize =
liftIO $
alloca $ \wptr ->
alloca $ \hptr -> do
Raw.getWindowSize win wptr hptr
V2 <$> peek wptr <*> peek hptr
windowTitle :: Window -> StateVar Text
windowTitle (Window w) = makeStateVar getWindowTitle setWindowTitle
where
setWindowTitle title =
liftIO . BS.useAsCString (Text.encodeUtf8 title) $
Raw.setWindowTitle w
getWindowTitle = liftIO $ do
cstr <- Raw.getWindowTitle w
Text.decodeUtf8 <$> BS.packCString cstr
windowData :: Window -> CString -> StateVar (Ptr ())
windowData (Window w) key = makeStateVar getWindowData setWindowData
where
setWindowData = void . Raw.setWindowData w key
getWindowData = Raw.getWindowData w key
getWindowConfig :: MonadIO m => Window -> m WindowConfig
getWindowConfig (Window w) = do
wFlags <- Raw.getWindowFlags w
wSize <- get (windowSize (Window w))
wPos <- getWindowAbsolutePosition (Window w)
return WindowConfig {
windowBorder = wFlags .&. Raw.SDL_WINDOW_BORDERLESS == 0
, windowHighDPI = wFlags .&. Raw.SDL_WINDOW_ALLOW_HIGHDPI > 0
, windowInputGrabbed = wFlags .&. Raw.SDL_WINDOW_INPUT_GRABBED > 0
, windowMode = fromNumber wFlags
, windowOpenGL = Nothing
, windowPosition = Absolute (P wPos)
, windowResizable = wFlags .&. Raw.SDL_WINDOW_RESIZABLE > 0
, windowInitialSize = wSize
, windowVisible = wFlags .&. Raw.SDL_WINDOW_SHOWN > 0
}
getWindowPixelFormat :: MonadIO m => Window -> m PixelFormat
getWindowPixelFormat (Window w) = return . fromNumber =<< Raw.getWindowPixelFormat w
getClipboardText :: MonadIO m => m Text
getClipboardText = liftIO . mask_ $ do
cstr <- throwIfNull "SDL.Video.getClipboardText" "SDL_GetClipboardText"
Raw.getClipboardText
finally (Text.decodeUtf8 <$> BS.packCString cstr) (free cstr)
hasClipboardText :: MonadIO m => m Bool
hasClipboardText = Raw.hasClipboardText
setClipboardText :: MonadIO m => Text -> m ()
setClipboardText str = liftIO $ do
throwIfNot0_ "SDL.Video.setClipboardText" "SDL_SetClipboardText" $
BS.useAsCString (Text.encodeUtf8 str) Raw.setClipboardText
hideWindow :: MonadIO m => Window -> m ()
hideWindow (Window w) = Raw.hideWindow w
raiseWindow :: MonadIO m => Window -> m ()
raiseWindow (Window w) = Raw.raiseWindow w
screenSaverEnabled :: StateVar Bool
screenSaverEnabled = makeStateVar (isScreenSaverEnabled) (setScreenSaverEnabled)
where
isScreenSaverEnabled = Raw.isScreenSaverEnabled
setScreenSaverEnabled True = Raw.enableScreenSaver
setScreenSaverEnabled False = Raw.disableScreenSaver
showWindow :: MonadIO m => Window -> m ()
showWindow (Window w) = Raw.showWindow w
windowGammaRamp :: Window -> StateVar (V3 (SV.Vector Word16))
windowGammaRamp (Window w) = makeStateVar getWindowGammaRamp setWindowGammaRamp
where
getWindowGammaRamp =
allocaArray 256 $ \rPtr ->
allocaArray 256 $ \gPtr ->
allocaArray 256 $ \bPtr -> do
throwIfNeg_ "SDL.Video.getWindowGammaRamp" "SDL_GetWindowGammaRamp"
(Raw.getWindowGammaRamp w rPtr gPtr bPtr)
liftA3 V3 (fmap SV.fromList (peekArray 256 rPtr))
(fmap SV.fromList (peekArray 256 gPtr))
(fmap SV.fromList (peekArray 256 bPtr))
setWindowGammaRamp (V3 r g b) = liftIO $ do
unless (all ((== 256) . SV.length) [r,g,b]) $
error "setWindowGammaRamp requires 256 element in each colour channel"
SV.unsafeWith r $ \rPtr ->
SV.unsafeWith b $ \bPtr ->
SV.unsafeWith g $ \gPtr ->
throwIfNeg_ "SDL.Video.setWindowGammaRamp" "SDL_SetWindowGammaRamp" $
Raw.setWindowGammaRamp w rPtr gPtr bPtr
data Display = Display {
displayName :: String
, displayBoundsPosition :: Point V2 CInt
, displayBoundsSize :: V2 CInt
, displayModes :: [DisplayMode]
}
deriving (Eq, Generic, Ord, Read, Show, Typeable)
data DisplayMode = DisplayMode {
displayModeFormat :: PixelFormat
, displayModeSize :: V2 CInt
, displayModeRefreshRate :: CInt
}
deriving (Eq, Generic, Ord, Read, Show, Typeable)
data VideoDriver = VideoDriver {
videoDriverName :: String
}
deriving (Data, Eq, Generic, Ord, Read, Show, Typeable)
getDisplays :: MonadIO m => m [Display]
getDisplays = liftIO $ do
numDisplays <- throwIfNeg "SDL.Video.getDisplays" "SDL_GetNumVideoDisplays"
Raw.getNumVideoDisplays
forM [0..numDisplays - 1] $ \displayId -> do
name <- throwIfNull "SDL.Video.getDisplays" "SDL_GetDisplayName" $
Raw.getDisplayName displayId
name' <- peekCString name
Raw.Rect x y w h <- alloca $ \rect -> do
throwIfNot0_ "SDL.Video.getDisplays" "SDL_GetDisplayBounds" $
Raw.getDisplayBounds displayId rect
peek rect
numModes <- throwIfNeg "SDL.Video.getDisplays" "SDL_GetNumDisplayModes" $
Raw.getNumDisplayModes displayId
modes <- forM [0..numModes - 1] $ \modeId -> do
Raw.DisplayMode format w' h' refreshRate _ <- alloca $ \mode -> do
throwIfNot0_ "SDL.Video.getDisplays" "SDL_GetDisplayMode" $
Raw.getDisplayMode displayId modeId mode
peek mode
return $ DisplayMode {
displayModeFormat = fromNumber format
, displayModeSize = V2 w' h'
, displayModeRefreshRate = refreshRate
}
return $ Display {
displayName = name'
, displayBoundsPosition = P (V2 x y)
, displayBoundsSize = V2 w h
, displayModes = modes
}
showSimpleMessageBox :: MonadIO m => Maybe Window -> MessageKind -> Text -> Text -> m ()
showSimpleMessageBox window kind title message =
liftIO . throwIfNot0_ "SDL.Video.showSimpleMessageBox" "SDL_ShowSimpleMessageBox" $ do
BS.useAsCString (Text.encodeUtf8 title) $ \title' ->
BS.useAsCString (Text.encodeUtf8 message) $ \message' ->
Raw.showSimpleMessageBox (toNumber kind) title' message' $
windowId window
where
windowId (Just (Window w)) = w
windowId Nothing = nullPtr
data MessageKind
= Error
| Warning
| Information
deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)
instance ToNumber MessageKind Word32 where
toNumber Error = Raw.SDL_MESSAGEBOX_ERROR
toNumber Warning = Raw.SDL_MESSAGEBOX_WARNING
toNumber Information = Raw.SDL_MESSAGEBOX_INFORMATION
windowMaximumSize :: Window -> StateVar (V2 CInt)
windowMaximumSize (Window win) = makeStateVar getWindowMaximumSize setWindowMaximumSize
where
setWindowMaximumSize (V2 w h) = Raw.setWindowMaximumSize win w h
getWindowMaximumSize =
liftIO $
alloca $ \wptr ->
alloca $ \hptr -> do
Raw.getWindowMaximumSize win wptr hptr
V2 <$> peek wptr <*> peek hptr
windowMinimumSize :: Window -> StateVar (V2 CInt)
windowMinimumSize (Window win) = makeStateVar getWindowMinimumSize setWindowMinimumSize
where
setWindowMinimumSize (V2 w h) = Raw.setWindowMinimumSize win w h
getWindowMinimumSize =
liftIO $
alloca $ \wptr ->
alloca $ \hptr -> do
Raw.getWindowMinimumSize win wptr hptr
V2 <$> peek wptr <*> peek hptr
createRenderer :: MonadIO m => Window -> CInt -> RendererConfig -> m Renderer
createRenderer (Window w) driver config =
liftIO . fmap Renderer $
throwIfNull "SDL.Video.createRenderer" "SDL_CreateRenderer" $
Raw.createRenderer w driver (toNumber config)
createSoftwareRenderer :: MonadIO m => Surface -> m Renderer
createSoftwareRenderer (Surface ptr _) =
liftIO . fmap Renderer $
throwIfNull "SDL.Video.createSoftwareRenderer" "SDL_CreateSoftwareRenderer" $
Raw.createSoftwareRenderer ptr
destroyRenderer :: MonadIO m => Renderer -> m ()
destroyRenderer (Renderer r) = Raw.destroyRenderer r