{-# LANGUAGE Strict #-}
module Monomer.Main.Platform (
defaultWindowSize,
initSDLWindow,
destroySDLWindow,
getCurrentMousePos,
getDrawableSize,
getWindowSize,
getViewportSize,
getPlatform,
getDisplayDPI
) where
import Control.Exception (finally)
import Control.Monad (when, void, forM_)
import Control.Monad.Extra (whenJust)
import Control.Monad.State
import Data.Maybe
import Data.Text (Text)
import Foreign (alloca, peek)
import Foreign.C (peekCString, withCString)
import Foreign.C.Types
import SDL (($=))
import qualified Codec.Picture as P
import qualified Data.Text as T
import qualified Data.Vector.Storable as V
import qualified Foreign.C.String as STR
import qualified SDL
import qualified SDL.Input.Mouse as Mouse
import qualified SDL.Raw as Raw
import qualified SDL.Raw.Error as SRE
import qualified SDL.Internal.Types as SIT
import qualified SDL.Video.Renderer as SVR
import Monomer.Common
import Monomer.Helper (catchAny, putStrLnErr)
import Monomer.Main.Types
foreign import ccall unsafe "initGlew" glewInit :: IO CInt
foreign import ccall unsafe "initDpiAwareness" initDpiAwareness :: IO CInt
defaultWindowSize :: (Int, Int)
defaultWindowSize :: (Int, Int)
defaultWindowSize = (Int
800, Int
600)
initSDLWindow :: AppConfig s e -> IO (SDL.Window, Double, Double, SDL.GLContext)
initSDLWindow :: forall s e. AppConfig s e -> IO (Window, Double, Double, GLContext)
initSDLWindow AppConfig s e
config = do
[InitFlag] -> IO ()
forall (f :: * -> *) (m :: * -> *).
(Foldable f, Functor m, MonadIO m) =>
f InitFlag -> m ()
SDL.initialize [InitFlag
SDL.InitVideo]
Bool -> IO ()
setDisableCompositorHint Bool
disableCompositingFlag
if Bool
disableScreensaverFlag
then IO ()
forall (m :: * -> *). MonadIO m => m ()
Raw.disableScreenSaver
else IO ()
forall (m :: * -> *). MonadIO m => m ()
Raw.enableScreenSaver
Hint RenderScaleQuality
SDL.HintRenderScaleQuality Hint RenderScaleQuality -> RenderScaleQuality -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
Hint RenderScaleQuality -> RenderScaleQuality -> m ()
$= RenderScaleQuality
SDL.ScaleLinear
RenderScaleQuality
renderQuality <- Hint RenderScaleQuality -> IO RenderScaleQuality
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *).
MonadIO m =>
Hint RenderScaleQuality -> m RenderScaleQuality
SDL.get Hint RenderScaleQuality
SDL.HintRenderScaleQuality
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RenderScaleQuality
renderQuality RenderScaleQuality -> RenderScaleQuality -> Bool
forall a. Eq a => a -> a -> Bool
/= RenderScaleQuality
SDL.ScaleLinear) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
putStrLnErr String
"Warning: Linear texture filtering not enabled!"
Text
platform <- IO Text
getPlatform
IO CInt
initDpiAwareness
Double
baseFactor <- case Text
platform of
Text
"Windows" -> IO Double
getWindowsFactor
Text
"Linux" -> IO Double
getLinuxFactor
Text
_ -> Double -> IO Double
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Double
1
let factor :: Double
factor
| Bool
disableAutoScale = Double
1
| Bool
otherwise = Double
baseFactor
let (Double
winW, Double
winH) = (Double
factor Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
baseW, Double
factor Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
baseH)
Window
window <-
Text -> WindowConfig -> IO Window
forall (m :: * -> *). MonadIO m => Text -> WindowConfig -> m Window
SDL.createWindow
Text
"Monomer application"
WindowConfig
SDL.defaultWindow {
SDL.windowInitialSize = SDL.V2 (round winW) (round winH),
SDL.windowHighDPI = True,
SDL.windowResizable = windowResizable,
SDL.windowBorder = windowBorder,
SDL.windowGraphicsContext = SDL.OpenGLContext customOpenGL
}
Size Double
dw Double
_ <- Window -> IO Size
getDrawableSize Window
window
Size Double
ww Double
_ <- Window -> IO Size
getWindowSize Window
window
let scaleFactor :: Double
scaleFactor = Double
factor Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
userScaleFactor
let contentRatio :: Double
contentRatio = Double
dw Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
ww
let (Double
dpr, Double
epr)
| Text
platform Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"Windows", Text
"Linux"] = (Double
scaleFactor, Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
scaleFactor)
| Bool
otherwise = (Double
scaleFactor Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
contentRatio, Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
scaleFactor)
Window -> AppConfig s e -> IO ()
forall s e. Window -> AppConfig s e -> IO ()
setWindowIcon Window
window AppConfig s e
config
Maybe Text -> (Text -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (AppConfig s e -> Maybe Text
forall s e. AppConfig s e -> Maybe Text
_apcWindowTitle AppConfig s e
config) ((Text -> IO ()) -> IO ()) -> (Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
title ->
Window -> StateVar Text
SDL.windowTitle Window
window StateVar Text -> Text -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *). MonadIO m => StateVar Text -> Text -> m ()
$= Text
title
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
windowFullscreen (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Window -> WindowMode -> IO ()
forall (m :: * -> *). MonadIO m => Window -> WindowMode -> m ()
SDL.setWindowMode Window
window WindowMode
SDL.FullscreenDesktop
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
windowMaximized (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Window -> WindowMode -> IO ()
forall (m :: * -> *). MonadIO m => Window -> WindowMode -> m ()
SDL.setWindowMode Window
window WindowMode
SDL.Maximized
CString
err <- IO CString
forall (m :: * -> *). MonadIO m => m CString
SRE.getError
String
err <- CString -> IO String
STR.peekCString CString
err
String -> IO ()
putStrLnErr String
err
GLContext
ctxRender <- Window -> IO GLContext
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Window -> m GLContext
SDL.glCreateContext Window
window
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
platform Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Windows") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IO GLContext -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO GLContext -> IO ()) -> IO GLContext -> IO ()
forall a b. (a -> b) -> a -> b
$ Window -> IO GLContext
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Window -> m GLContext
SDL.glCreateContext Window
window
CInt
_ <- IO CInt
glewInit
(Window, Double, Double, GLContext)
-> IO (Window, Double, Double, GLContext)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Window
window, Double
dpr, Double
epr, GLContext
ctxRender)
where
customOpenGL :: OpenGLConfig
customOpenGL = SDL.OpenGLConfig {
glColorPrecision :: V4 CInt
SDL.glColorPrecision = CInt -> CInt -> CInt -> CInt -> V4 CInt
forall a. a -> a -> a -> a -> V4 a
SDL.V4 CInt
8 CInt
8 CInt
8 CInt
0,
glDepthPrecision :: CInt
SDL.glDepthPrecision = CInt
24,
glStencilPrecision :: CInt
SDL.glStencilPrecision = CInt
8,
glProfile :: Profile
SDL.glProfile = Mode -> CInt -> CInt -> Profile
SDL.Core Mode
SDL.Normal CInt
3 CInt
2,
glMultisampleSamples :: CInt
SDL.glMultisampleSamples = CInt
1
}
disableCompositingFlag :: Bool
disableCompositingFlag = AppConfig s e -> Maybe Bool
forall s e. AppConfig s e -> Maybe Bool
_apcDisableCompositing AppConfig s e
config Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
disableScreensaverFlag :: Bool
disableScreensaverFlag = AppConfig s e -> Maybe Bool
forall s e. AppConfig s e -> Maybe Bool
_apcDisableScreensaver AppConfig s e
config Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
disableAutoScale :: Bool
disableAutoScale = AppConfig s e -> Maybe Bool
forall s e. AppConfig s e -> Maybe Bool
_apcDisableAutoScale AppConfig s e
config Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
userScaleFactor :: Double
userScaleFactor = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
1 (AppConfig s e -> Maybe Double
forall s e. AppConfig s e -> Maybe Double
_apcScaleFactor AppConfig s e
config)
(Int
baseW, Int
baseH) = case AppConfig s e -> Maybe MainWindowState
forall s e. AppConfig s e -> Maybe MainWindowState
_apcWindowState AppConfig s e
config of
Just (MainWindowNormal (Int, Int)
size) -> (Int, Int)
size
Maybe MainWindowState
_ -> (Int, Int)
defaultWindowSize
windowResizable :: Bool
windowResizable = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (AppConfig s e -> Maybe Bool
forall s e. AppConfig s e -> Maybe Bool
_apcWindowResizable AppConfig s e
config)
windowBorder :: Bool
windowBorder = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (AppConfig s e -> Maybe Bool
forall s e. AppConfig s e -> Maybe Bool
_apcWindowBorder AppConfig s e
config)
windowFullscreen :: Bool
windowFullscreen = case AppConfig s e -> Maybe MainWindowState
forall s e. AppConfig s e -> Maybe MainWindowState
_apcWindowState AppConfig s e
config of
Just MainWindowState
MainWindowFullScreen -> Bool
True
Maybe MainWindowState
_ -> Bool
False
windowMaximized :: Bool
windowMaximized = case AppConfig s e -> Maybe MainWindowState
forall s e. AppConfig s e -> Maybe MainWindowState
_apcWindowState AppConfig s e
config of
Just MainWindowState
MainWindowMaximized -> Bool
True
Maybe MainWindowState
_ -> Bool
False
setWindowIcon :: SDL.Window -> AppConfig s e -> IO ()
setWindowIcon :: forall s e. Window -> AppConfig s e -> IO ()
setWindowIcon (SIT.Window Window
winPtr) AppConfig s e
config =
Maybe Text -> (Text -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (AppConfig s e -> Maybe Text
forall s e. AppConfig s e -> Maybe Text
_apcWindowIcon AppConfig s e
config) ((Text -> IO ()) -> IO ()) -> (Text -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
iconPath ->
(IO () -> (SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
catchAny SomeException -> IO ()
forall {a}. Show a => a -> IO ()
handleException (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Surface
iconSurface <- String -> IO Surface
loadImgToSurface (Text -> String
T.unpack Text
iconPath)
let SVR.Surface Ptr Surface
iconSurfacePtr Maybe (IOVector Word8)
_ = Surface
iconSurface
IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally
(Window -> Ptr Surface -> IO ()
forall (m :: * -> *). MonadIO m => Window -> Ptr Surface -> m ()
Raw.setWindowIcon Window
winPtr Ptr Surface
iconSurfacePtr)
(Surface -> IO ()
forall (m :: * -> *). MonadIO m => Surface -> m ()
SVR.freeSurface Surface
iconSurface)
where
handleException :: a -> IO ()
handleException a
err = String -> IO ()
putStrLnErr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"Failed to set window icon. Does the file exist?\n\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
destroySDLWindow :: SDL.Window -> IO ()
destroySDLWindow :: Window -> IO ()
destroySDLWindow Window
window = do
Window -> IO ()
forall (m :: * -> *). MonadIO m => Window -> m ()
SDL.destroyWindow Window
window
InitFlag -> IO ()
forall (m :: * -> *). MonadIO m => InitFlag -> m ()
Raw.quitSubSystem InitFlag
Raw.SDL_INIT_VIDEO
IO ()
forall (m :: * -> *). MonadIO m => m ()
SDL.quit
getCurrentMousePos :: Double -> IO Point
getCurrentMousePos :: Double -> IO Point
getCurrentMousePos Double
epr = do
SDL.P (SDL.V2 CInt
x CInt
y) <- IO (Point V2 CInt)
forall (m :: * -> *). MonadIO m => m (Point V2 CInt)
Mouse.getAbsoluteMouseLocation
Point -> IO Point
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Point -> IO Point) -> Point -> IO Point
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Point
Point (Double
epr Double -> Double -> Double
forall a. Num a => a -> a -> a
* CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
x) (Double
epr Double -> Double -> Double
forall a. Num a => a -> a -> a
* CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
y)
getDrawableSize :: SDL.Window -> IO Size
getDrawableSize :: Window -> IO Size
getDrawableSize Window
window = do
SDL.V2 CInt
fbWidth CInt
fbHeight <- Window -> IO (V2 CInt)
forall (m :: * -> *). MonadIO m => Window -> m (V2 CInt)
SDL.glGetDrawableSize Window
window
Size -> IO Size
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Size -> IO Size) -> Size -> IO Size
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Size
Size (CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
fbWidth) (CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
fbHeight)
getWindowSize :: SDL.Window -> IO Size
getWindowSize :: Window -> IO Size
getWindowSize Window
window = do
SDL.V2 CInt
rw CInt
rh <- StateVar (V2 CInt) -> IO (V2 CInt)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *).
MonadIO m =>
StateVar (V2 CInt) -> m (V2 CInt)
SDL.get (Window -> StateVar (V2 CInt)
SDL.windowSize Window
window)
Size -> IO Size
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Size -> IO Size) -> Size -> IO Size
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Size
Size (CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
rw) (CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
rh)
getViewportSize :: SDL.Window -> Double -> IO Size
getViewportSize :: Window -> Double -> IO Size
getViewportSize Window
window Double
dpr = do
SDL.V2 CInt
fw CInt
fh <- Window -> IO (V2 CInt)
forall (m :: * -> *). MonadIO m => Window -> m (V2 CInt)
SDL.glGetDrawableSize Window
window
Size -> IO Size
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Size -> IO Size) -> Size -> IO Size
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Size
Size (CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
fw Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
dpr) (CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
fh Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
dpr)
getPlatform :: IO Text
getPlatform :: IO Text
getPlatform = do
String
platform <- CString -> IO String
peekCString (CString -> IO String) -> IO CString -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO CString
forall (m :: * -> *). MonadIO m => m CString
Raw.getPlatform
Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
platform
getDisplayDPI :: IO (Double, Double, Double)
getDisplayDPI :: IO (Double, Double, Double)
getDisplayDPI =
(Ptr CFloat -> IO (Double, Double, Double))
-> IO (Double, Double, Double)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CFloat -> IO (Double, Double, Double))
-> IO (Double, Double, Double))
-> (Ptr CFloat -> IO (Double, Double, Double))
-> IO (Double, Double, Double)
forall a b. (a -> b) -> a -> b
$ \Ptr CFloat
pddpi ->
(Ptr CFloat -> IO (Double, Double, Double))
-> IO (Double, Double, Double)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CFloat -> IO (Double, Double, Double))
-> IO (Double, Double, Double))
-> (Ptr CFloat -> IO (Double, Double, Double))
-> IO (Double, Double, Double)
forall a b. (a -> b) -> a -> b
$ \Ptr CFloat
phdpi ->
(Ptr CFloat -> IO (Double, Double, Double))
-> IO (Double, Double, Double)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CFloat -> IO (Double, Double, Double))
-> IO (Double, Double, Double))
-> (Ptr CFloat -> IO (Double, Double, Double))
-> IO (Double, Double, Double)
forall a b. (a -> b) -> a -> b
$ \Ptr CFloat
pvdpi -> do
CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> IO CInt
forall (m :: * -> *).
MonadIO m =>
CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> m CInt
Raw.getDisplayDPI CInt
0 Ptr CFloat
pddpi Ptr CFloat
phdpi Ptr CFloat
pvdpi
CFloat
ddpi <- Ptr CFloat -> IO CFloat
forall a. Storable a => Ptr a -> IO a
peek Ptr CFloat
pddpi
CFloat
hdpi <- Ptr CFloat -> IO CFloat
forall a. Storable a => Ptr a -> IO a
peek Ptr CFloat
phdpi
CFloat
vdpi <- Ptr CFloat -> IO CFloat
forall a. Storable a => Ptr a -> IO a
peek Ptr CFloat
pvdpi
(Double, Double, Double) -> IO (Double, Double, Double)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CFloat -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac CFloat
ddpi, CFloat -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac CFloat
hdpi, CFloat -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac CFloat
vdpi)
getWindowsFactor :: IO Double
getWindowsFactor :: IO Double
getWindowsFactor = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
1 (Double -> Double) -> IO Double -> IO Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Double
getDisplayDPIFactor
getLinuxFactor :: IO Double
getLinuxFactor :: IO Double
getLinuxFactor = do
Double
dpiFactor <- IO Double
getDisplayDPIFactor
(Ptr DisplayMode -> IO Double) -> IO Double
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr DisplayMode -> IO Double) -> IO Double)
-> (Ptr DisplayMode -> IO Double) -> IO Double
forall a b. (a -> b) -> a -> b
$ \Ptr DisplayMode
pmode -> do
CInt -> Ptr DisplayMode -> IO CInt
forall (m :: * -> *).
MonadIO m =>
CInt -> Ptr DisplayMode -> m CInt
Raw.getCurrentDisplayMode CInt
0 Ptr DisplayMode
pmode
DisplayMode
mode <- Ptr DisplayMode -> IO DisplayMode
forall a. Storable a => Ptr a -> IO a
peek Ptr DisplayMode
pmode
let width :: CInt
width = DisplayMode -> CInt
Raw.displayModeW DisplayMode
mode
let detectedDPI :: Double
detectedDPI
| Double
dpiFactor Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 = Double
dpiFactor
| CInt
width CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
<= CInt
1920 = Double
1
| Bool
otherwise = Double
2
Double -> IO Double
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Double
detectedDPI
getDisplayDPIFactor :: IO Double
getDisplayDPIFactor :: IO Double
getDisplayDPIFactor = do
(Double
ddpi, Double
hdpi, Double
vdpi) <- IO (Double, Double, Double)
getDisplayDPI
Double -> IO Double
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
hdpi Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
96)
setDisableCompositorHint :: Bool -> IO ()
setDisableCompositorHint :: Bool -> IO ()
setDisableCompositorHint Bool
disable =
String -> Bool -> IO ()
setBooleanHintSDL String
"SDL_VIDEO_X11_NET_WM_BYPASS_COMPOSITOR" Bool
disable
setBooleanHintSDL :: String -> Bool -> IO ()
setBooleanHintSDL :: String -> Bool -> IO ()
setBooleanHintSDL String
flagName Bool
value = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> (CString -> IO Bool) -> IO Bool
forall a. String -> (CString -> IO a) -> IO a
withCString String
flagName ((CString -> IO Bool) -> IO Bool)
-> (CString -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \CString
cHintNameStr ->
String -> (CString -> IO Bool) -> IO Bool
forall a. String -> (CString -> IO a) -> IO a
withCString String
valueStr ((CString -> IO Bool) -> IO Bool)
-> (CString -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \CString
cValueStr ->
CString -> CString -> IO Bool
forall (m :: * -> *). MonadIO m => CString -> CString -> m Bool
Raw.setHint CString
cHintNameStr CString
cValueStr
where
valueStr :: String
valueStr = if Bool
value then String
"1" else String
"0"
readImageRGBA8 :: FilePath -> IO (P.Image P.PixelRGBA8)
readImageRGBA8 :: String -> IO (Image PixelRGBA8)
readImageRGBA8 String
path = String -> IO (Either String DynamicImage)
P.readImage String
path
IO (Either String DynamicImage)
-> (Either String DynamicImage -> IO (Image PixelRGBA8))
-> IO (Image PixelRGBA8)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO (Image PixelRGBA8))
-> (DynamicImage -> IO (Image PixelRGBA8))
-> Either String DynamicImage
-> IO (Image PixelRGBA8)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO (Image PixelRGBA8)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (Image PixelRGBA8 -> IO (Image PixelRGBA8)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Image PixelRGBA8 -> IO (Image PixelRGBA8))
-> (DynamicImage -> Image PixelRGBA8)
-> DynamicImage
-> IO (Image PixelRGBA8)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynamicImage -> Image PixelRGBA8
P.convertRGBA8)
loadImgToSurface :: FilePath -> IO SDL.Surface
loadImgToSurface :: String -> IO Surface
loadImgToSurface String
path = do
Image PixelRGBA8
rgba8 <- String -> IO (Image PixelRGBA8)
readImageRGBA8 String
path
IOVector Word8
imgData <- Vector Word8 -> IO (MVector (PrimState IO) Word8)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
V.thaw (Image PixelRGBA8 -> Vector (PixelBaseComponent PixelRGBA8)
forall a. Image a -> Vector (PixelBaseComponent a)
P.imageData Image PixelRGBA8
rgba8)
let width :: CInt
width = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ Image PixelRGBA8 -> Int
forall a. Image a -> Int
P.imageWidth Image PixelRGBA8
rgba8
height :: CInt
height = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ Image PixelRGBA8 -> Int
forall a. Image a -> Int
P.imageHeight Image PixelRGBA8
rgba8
imgSize :: V2 CInt
imgSize = CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
SDL.V2 CInt
width CInt
height
IOVector Word8 -> V2 CInt -> CInt -> PixelFormat -> IO Surface
forall (m :: * -> *).
(Functor m, MonadIO m) =>
IOVector Word8 -> V2 CInt -> CInt -> PixelFormat -> m Surface
SDL.createRGBSurfaceFrom IOVector Word8
imgData V2 CInt
imgSize (CInt
4 CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
* CInt
width) PixelFormat
SDL.ABGR8888