{-|
Module      : Monomer.Main.Platform
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Helper functions for SDL platform related operations.
-}
{-# LANGUAGE Strict #-}

module Monomer.Main.Platform (
  defaultWindowSize,
  initSDLWindow,
  detroySDLWindow,
  getCurrentMousePos,
  getDrawableSize,
  getWindowSize,
  getViewportSize,
  getPlatform,
  getDisplayDPI
) where

import Control.Exception (finally)
import Control.Monad (void)
import Control.Monad.Extra (whenJust)
import Control.Monad.State
import Data.Maybe
import Data.Text (Text)
import Data.Word
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

-- | Default window size if not is specified.
defaultWindowSize :: (Int, Int)
defaultWindowSize :: (Int, Int)
defaultWindowSize = (Int
800, Int
600)

-- | Creates and initializes a window using the provided configuration.
initSDLWindow :: AppConfig e -> IO (SDL.Window, Double, Double, SDL.GLContext)
initSDLWindow :: forall e. AppConfig e -> IO (Window, Double, Double, GLContext)
initSDLWindow AppConfig e
config = do
  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 forall (m :: * -> *). MonadIO m => m ()
Raw.disableScreenSaver
    else forall (m :: * -> *). MonadIO m => m ()
Raw.enableScreenSaver

  Hint RenderScaleQuality
SDL.HintRenderScaleQuality forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= RenderScaleQuality
SDL.ScaleLinear
  RenderScaleQuality
renderQuality <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
SDL.get Hint RenderScaleQuality
SDL.HintRenderScaleQuality

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RenderScaleQuality
renderQuality forall a. Eq a => a -> a -> Bool
/= RenderScaleQuality
SDL.ScaleLinear) 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Double
1 -- macOS

  let factor :: Double
factor
        | Bool
disableAutoScale = Double
1
        | Bool
otherwise = Double
baseFactor
  let (Double
winW, Double
winH) = (Double
factor forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
baseW, Double
factor forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
baseH)

  Window
window <-
    forall (m :: * -> *). MonadIO m => Text -> WindowConfig -> m Window
SDL.createWindow
      Text
"Monomer application"
      WindowConfig
SDL.defaultWindow {
        windowInitialSize :: V2 CInt
SDL.windowInitialSize = forall a. a -> a -> V2 a
SDL.V2 (forall a b. (RealFrac a, Integral b) => a -> b
round Double
winW) (forall a b. (RealFrac a, Integral b) => a -> b
round Double
winH),
        windowHighDPI :: Bool
SDL.windowHighDPI = Bool
True,
        windowResizable :: Bool
SDL.windowResizable = Bool
windowResizable,
        windowBorder :: Bool
SDL.windowBorder = Bool
windowBorder,
        windowGraphicsContext :: WindowGraphicsContext
SDL.windowGraphicsContext = OpenGLConfig -> WindowGraphicsContext
SDL.OpenGLContext OpenGLConfig
customOpenGL
      }

  -- Get device pixel rate
  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 forall a. Num a => a -> a -> a
* Double
userScaleFactor
  let contentRatio :: Double
contentRatio = Double
dw forall a. Fractional a => a -> a -> a
/ Double
ww
  let (Double
dpr, Double
epr)
        | Text
platform forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"Windows", Text
"Linux"] = (Double
scaleFactor, Double
1 forall a. Fractional a => a -> a -> a
/ Double
scaleFactor)
        | Bool
otherwise = (Double
scaleFactor forall a. Num a => a -> a -> a
* Double
contentRatio, Double
1 forall a. Fractional a => a -> a -> a
/ Double
scaleFactor) -- macOS

  forall e. Window -> AppConfig e -> IO ()
setWindowIcon Window
window AppConfig e
config

  forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (forall e. AppConfig e -> Maybe Text
_apcWindowTitle AppConfig e
config) forall a b. (a -> b) -> a -> b
$ \Text
title ->
    Window -> StateVar Text
SDL.windowTitle Window
window forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Text
title

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
windowFullscreen forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *). MonadIO m => Window -> WindowMode -> m ()
SDL.setWindowMode Window
window WindowMode
SDL.FullscreenDesktop

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
windowMaximized forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *). MonadIO m => Window -> WindowMode -> m ()
SDL.setWindowMode Window
window WindowMode
SDL.Maximized

  CString
err <- forall (m :: * -> *). MonadIO m => m CString
SRE.getError
  String
err <- CString -> IO String
STR.peekCString CString
err
  String -> IO ()
putStrLnErr String
err

  GLContext
ctxRender <- forall (m :: * -> *).
(Functor m, MonadIO m) =>
Window -> m GLContext
SDL.glCreateContext Window
window

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
platform forall a. Eq a => a -> a -> Bool
== Text
"Windows") forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(Functor m, MonadIO m) =>
Window -> m GLContext
SDL.glCreateContext Window
window

  CInt
_ <- IO CInt
glewInit

  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 = 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,
      --SDL.glProfile = SDL.Core SDL.Debug 3 2,
      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 = forall e. AppConfig e -> Maybe Bool
_apcDisableCompositing AppConfig e
config forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True
    disableScreensaverFlag :: Bool
disableScreensaverFlag = forall e. AppConfig e -> Maybe Bool
_apcDisableScreensaver AppConfig e
config forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True
    disableAutoScale :: Bool
disableAutoScale = forall e. AppConfig e -> Maybe Bool
_apcDisableAutoScale AppConfig e
config forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True
    userScaleFactor :: Double
userScaleFactor = forall a. a -> Maybe a -> a
fromMaybe Double
1 (forall e. AppConfig e -> Maybe Double
_apcScaleFactor AppConfig e
config)

    (Int
baseW, Int
baseH) = case forall e. AppConfig e -> Maybe MainWindowState
_apcWindowState AppConfig e
config of
      Just (MainWindowNormal (Int, Int)
size) -> (Int, Int)
size
      Maybe MainWindowState
_ -> (Int, Int)
defaultWindowSize
    windowResizable :: Bool
windowResizable = forall a. a -> Maybe a -> a
fromMaybe Bool
True (forall e. AppConfig e -> Maybe Bool
_apcWindowResizable AppConfig e
config)
    windowBorder :: Bool
windowBorder = forall a. a -> Maybe a -> a
fromMaybe Bool
True (forall e. AppConfig e -> Maybe Bool
_apcWindowBorder AppConfig e
config)
    windowFullscreen :: Bool
windowFullscreen = case forall e. AppConfig e -> Maybe MainWindowState
_apcWindowState AppConfig e
config of
      Just MainWindowState
MainWindowFullScreen -> Bool
True
      Maybe MainWindowState
_ -> Bool
False
    windowMaximized :: Bool
windowMaximized = case forall e. AppConfig e -> Maybe MainWindowState
_apcWindowState AppConfig e
config of
      Just MainWindowState
MainWindowMaximized -> Bool
True
      Maybe MainWindowState
_ -> Bool
False

setWindowIcon :: SDL.Window -> AppConfig e -> IO ()
setWindowIcon :: forall e. Window -> AppConfig e -> IO ()
setWindowIcon (SIT.Window Window
winPtr) AppConfig e
config =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall e. AppConfig e -> Maybe Text
_apcWindowIcon AppConfig e
config) forall a b. (a -> b) -> a -> b
$ \Text
iconPath ->
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. IO a -> (SomeException -> IO a) -> IO a
catchAny forall {a}. Show a => a -> IO ()
handleException 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
      forall a b. IO a -> IO b -> IO a
finally
        -- Note: this can use the high-level setWindowIcon once it is available (https://github.com/haskell-game/sdl2/pull/243)
        (forall (m :: * -> *). MonadIO m => Window -> Ptr Surface -> m ()
Raw.setWindowIcon Window
winPtr Ptr Surface
iconSurfacePtr)
        (forall (m :: * -> *). MonadIO m => Surface -> m ()
SVR.freeSurface Surface
iconSurface)
  where
    handleException :: a -> IO ()
handleException a
err = String -> IO ()
putStrLnErr forall a b. (a -> b) -> a -> b
$
      String
"Failed to set window icon. Does the file exist?\n\t" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
err forall a. [a] -> [a] -> [a]
++ String
"\n"

-- | Destroys the provided window, shutdowns the video subsystem and SDL.
detroySDLWindow :: SDL.Window -> IO ()
detroySDLWindow :: Window -> IO ()
detroySDLWindow Window
window = do
  forall (m :: * -> *). MonadIO m => Window -> m ()
SDL.destroyWindow Window
window
  forall (m :: * -> *). MonadIO m => InitFlag -> m ()
Raw.quitSubSystem InitFlag
Raw.SDL_INIT_VIDEO
  forall (m :: * -> *). MonadIO m => m ()
SDL.quit

-- | Returns the current mouse position.
getCurrentMousePos :: Double -> IO Point
getCurrentMousePos :: Double -> IO Point
getCurrentMousePos Double
epr = do
  SDL.P (SDL.V2 CInt
x CInt
y) <- forall (m :: * -> *). MonadIO m => m (Point V2 CInt)
Mouse.getAbsoluteMouseLocation
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Double -> Double -> Point
Point (Double
epr forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
x) (Double
epr forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
y)

-- | Returns the drawable size of the provided window. May differ from window
--   size if HDPI is enabled.
getDrawableSize :: SDL.Window -> IO Size
getDrawableSize :: Window -> IO Size
getDrawableSize Window
window = do
  SDL.V2 CInt
fbWidth CInt
fbHeight <- forall (m :: * -> *). MonadIO m => Window -> m (V2 CInt)
SDL.glGetDrawableSize Window
window
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Double -> Double -> Size
Size (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
fbWidth) (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
fbHeight)

-- | Returns the size of the provided window.
getWindowSize :: SDL.Window -> IO Size
getWindowSize :: Window -> IO Size
getWindowSize Window
window = do
  SDL.V2 CInt
rw CInt
rh <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
SDL.get (Window -> StateVar (V2 CInt)
SDL.windowSize Window
window)

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Double -> Double -> Size
Size (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
rw) (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
rh)

{-|
Returns the viewport size. This is the size of the viewport the application will
render to and, depending on the platform, may match window size or not. For
example, on Windows and Linux Wayland this size may be smaller than the window
size because of dpr scaling.
-}
getViewportSize :: SDL.Window -> Double -> IO Size
getViewportSize :: Window -> Double -> IO Size
getViewportSize Window
window Double
dpr = do
  SDL.V2 CInt
fw CInt
fh <- forall (m :: * -> *). MonadIO m => Window -> m (V2 CInt)
SDL.glGetDrawableSize Window
window

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Double -> Double -> Size
Size (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
fw forall a. Fractional a => a -> a -> a
/ Double
dpr) (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
fh forall a. Fractional a => a -> a -> a
/ Double
dpr)

-- | Returns the name of the host OS.
getPlatform :: IO Text
getPlatform :: IO Text
getPlatform = do
  String
platform <- CString -> IO String
peekCString forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadIO m => m CString
Raw.getPlatform

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
platform

-- | Returns the diagonal, horizontal and vertical DPI of the main display.
getDisplayDPI :: IO (Double, Double, Double)
getDisplayDPI :: IO (Double, Double, Double)
getDisplayDPI =
  forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr CFloat
pddpi ->
    forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr CFloat
phdpi ->
      forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr CFloat
pvdpi -> do
        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 <- forall a. Storable a => Ptr a -> IO a
peek Ptr CFloat
pddpi
        CFloat
hdpi <- forall a. Storable a => Ptr a -> IO a
peek Ptr CFloat
phdpi
        CFloat
vdpi <- forall a. Storable a => Ptr a -> IO a
peek Ptr CFloat
pvdpi
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Real a, Fractional b) => a -> b
realToFrac CFloat
ddpi, forall a b. (Real a, Fractional b) => a -> b
realToFrac CFloat
hdpi, forall a b. (Real a, Fractional b) => a -> b
realToFrac CFloat
vdpi)

-- | Returns the default resize factor for Windows.
getWindowsFactor :: IO Double
getWindowsFactor :: IO Double
getWindowsFactor = forall a. Ord a => a -> a -> a
max Double
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Double
getDisplayDPIFactor

-- | Returns the default resize factor for Linux.
getLinuxFactor :: IO Double
getLinuxFactor :: IO Double
getLinuxFactor = do
  Double
dpiFactor <- IO Double
getDisplayDPIFactor

  forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr DisplayMode
pmode -> do
    forall (m :: * -> *).
MonadIO m =>
CInt -> Ptr DisplayMode -> m CInt
Raw.getCurrentDisplayMode CInt
0 Ptr DisplayMode
pmode
    DisplayMode
mode <- 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 forall a. Ord a => a -> a -> Bool
> Double
0 = Double
dpiFactor
          | CInt
width forall a. Ord a => a -> a -> Bool
<= CInt
1920 = Double
1
          | Bool
otherwise = Double
2

    forall (m :: * -> *) a. Monad m => a -> m a
return Double
detectedDPI

-- | Returns DPI scaling factor using SDL_GetDisplayDPI.
getDisplayDPIFactor :: IO Double
getDisplayDPIFactor :: IO Double
getDisplayDPIFactor = do
  (Double
ddpi, Double
hdpi, Double
vdpi) <- IO (Double, Double, Double)
getDisplayDPI
  forall (m :: * -> *) a. Monad m => a -> m a
return (Double
hdpi 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
  forall a. String -> (CString -> IO a) -> IO a
withCString String
flagName forall a b. (a -> b) -> a -> b
$ \CString
cHintNameStr ->
    forall a. String -> (CString -> IO a) -> IO a
withCString String
valueStr forall a b. (a -> b) -> a -> b
$ \CString
cValueStr ->
      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
  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
Vector a -> m (MVector (PrimState m) a)
V.thaw (forall a. Image a -> Vector (PixelBaseComponent a)
P.imageData Image PixelRGBA8
rgba8)

  let width :: CInt
width = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Image a -> Int
P.imageWidth Image PixelRGBA8
rgba8
      height :: CInt
height = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Image a -> Int
P.imageHeight Image PixelRGBA8
rgba8
      imgSize :: V2 CInt
imgSize = forall a. a -> a -> V2 a
SDL.V2 CInt
width CInt
height

  forall (m :: * -> *).
(Functor m, MonadIO m) =>
IOVector Word8 -> V2 CInt -> CInt -> PixelFormat -> m Surface
SDL.createRGBSurfaceFrom IOVector Word8
imgData V2 CInt
imgSize (CInt
4 forall a. Num a => a -> a -> a
* CInt
width) PixelFormat
SDL.ABGR8888