{-|
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.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 Data.Text as T
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 Monomer.Common
import Monomer.Core.StyleTypes
import Monomer.Main.Types
import Monomer.Event.Types
import Monomer.Widgets.Composite

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 :: AppConfig e -> IO (Window, Double, Double, GLContext)
initSDLWindow AppConfig e
config = do
  [InitFlag] -> IO ()
forall (f :: * -> *) (m :: * -> *).
(Foldable f, Functor m, MonadIO m) =>
f InitFlag -> m ()
SDL.initialize [InitFlag
SDL.InitVideo]
  Hint RenderScaleQuality
SDL.HintRenderScaleQuality Hint RenderScaleQuality -> RenderScaleQuality -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= RenderScaleQuality
SDL.ScaleLinear

  do RenderScaleQuality
renderQuality <- Hint RenderScaleQuality -> IO RenderScaleQuality
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
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 ()
putStrLn String
"Warning: Linear texture filtering not enabled!"

  Text
platform <- IO Text
getPlatform
  IO CInt
initDpiAwareness
  Double
factor <- case Text
platform of
    Text
"Windows" -> IO Double
getWindowsFactor
    Text
"Linux" -> IO Double
getLinuxFactor
    Text
_ -> Double -> IO Double
forall (m :: * -> *) a. Monad m => a -> m a
return Double
1 -- macOS
  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 {
        windowInitialSize :: V2 CInt
SDL.windowInitialSize = CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
SDL.V2 (Double -> CInt
forall a b. (RealFrac a, Integral b) => a -> b
round Double
winW) (Double -> CInt
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 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 (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) -- macOS

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (AppConfig e -> Maybe Text
forall e. AppConfig e -> Maybe Text
_apcWindowTitle AppConfig e
config)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Window -> StateVar Text
SDL.windowTitle Window
window StateVar Text -> Text -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (AppConfig e -> Maybe Text
forall e. AppConfig e -> Maybe Text
_apcWindowTitle AppConfig e
config)

  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 ()
putStrLn 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 (m :: * -> *) a. Monad m => a -> m a
return (Window
window, Double
dpr, Double
epr, GLContext
ctxRender)
  where
    customOpenGL :: OpenGLConfig
customOpenGL = OpenGLConfig :: V4 CInt -> CInt -> CInt -> CInt -> Profile -> OpenGLConfig
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,
      --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
    }
    userScaleFactor :: Double
userScaleFactor = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
1 (AppConfig e -> Maybe Double
forall e. AppConfig e -> Maybe Double
_apcScaleFactor AppConfig e
config)
    (Int
baseW, Int
baseH) = case AppConfig e -> Maybe MainWindowState
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 = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (AppConfig e -> Maybe Bool
forall e. AppConfig e -> Maybe Bool
_apcWindowResizable AppConfig e
config)
    windowBorder :: Bool
windowBorder = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (AppConfig e -> Maybe Bool
forall e. AppConfig e -> Maybe Bool
_apcWindowBorder AppConfig e
config)
    windowFullscreen :: Bool
windowFullscreen = case AppConfig e -> Maybe MainWindowState
forall e. AppConfig e -> Maybe MainWindowState
_apcWindowState AppConfig e
config of
      Just MainWindowState
MainWindowFullScreen -> Bool
True
      Maybe MainWindowState
_ -> Bool
False
    windowMaximized :: Bool
windowMaximized = case AppConfig e -> Maybe MainWindowState
forall e. AppConfig e -> Maybe MainWindowState
_apcWindowState AppConfig e
config of
      Just MainWindowState
MainWindowMaximized -> Bool
True
      Maybe MainWindowState
_ -> Bool
False

-- | Destroys the provided window, shutdowns the video subsystem and SDL.
detroySDLWindow :: SDL.Window -> IO ()
detroySDLWindow :: Window -> IO ()
detroySDLWindow Window
window = do
  String -> IO ()
putStrLn String
"About to destroyWindow"
  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

-- | 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) <- IO (Point V2 CInt)
forall (m :: * -> *). MonadIO m => m (Point V2 CInt)
Mouse.getAbsoluteMouseLocation
  Point -> IO Point
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)

-- | 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 <- Window -> IO (V2 CInt)
forall (m :: * -> *). MonadIO m => Window -> m (V2 CInt)
SDL.glGetDrawableSize Window
window
  Size -> IO Size
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)

-- | 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 <- StateVar (V2 CInt) -> IO (V2 CInt)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
SDL.get (Window -> StateVar (V2 CInt)
SDL.windowSize Window
window)

  Size -> IO Size
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)

{-|
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 <- Window -> IO (V2 CInt)
forall (m :: * -> *). MonadIO m => Window -> m (V2 CInt)
SDL.glGetDrawableSize Window
window

  Size -> IO Size
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)

-- | Returns the name of the host OS.
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 (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

-- | Returns the diagonal, horizontal and vertical DPI of the main display.
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 (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)

-- | Returns the default resize factor for Windows
getWindowsFactor :: IO Double
getWindowsFactor :: IO Double
getWindowsFactor = do
  (Double
ddpi, Double
hdpi, Double
vdpi) <- IO (Double, Double, Double)
getDisplayDPI
  Double -> IO Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
hdpi Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
96)

{-|
Returns a resizing factor to handle HiDPI on Linux. Currently only tested on
Wayland (Ubuntu 21.04).
-}
getLinuxFactor :: IO Double
getLinuxFactor :: IO Double
getLinuxFactor =
  (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
    -- Applies scale in half steps (1, 1.5, 2, etc)
    let baseFactor :: Double
baseFactor = Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* CInt -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
width Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1920

    if CInt
width CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
<= CInt
1920
      then Double -> IO Double
forall (m :: * -> *) a. Monad m => a -> m a
return Double
1
      else Double -> IO Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Double
baseFactor) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2)