Platform.hs

{-|
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,
  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

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

-- | Creates and initializes a window using the provided configuration.
initSDLWindow :: AppConfig s e -> IO (SDL.Window, Double, Double, SDL.GLContext)
initSDLWindow config = do
  SDL.initialize [SDL.InitVideo]

  setDisableCompositorHint disableCompositingFlag

  if disableScreensaverFlag
    then Raw.disableScreenSaver
    else Raw.enableScreenSaver

  SDL.HintRenderScaleQuality $= SDL.ScaleLinear
  renderQuality <- SDL.get SDL.HintRenderScaleQuality

  when (renderQuality /= SDL.ScaleLinear) $
    putStrLnErr "Warning: Linear texture filtering not enabled!"

  platform <- getPlatform
  initDpiAwareness

  baseFactor <- case platform of
    "Windows" -> getWindowsFactor
    "Linux" -> getLinuxFactor
    _ -> return 1 -- macOS

  let factor
        | disableAutoScale = 1
        | otherwise = baseFactor
  let (winW, winH) = (factor * fromIntegral baseW, factor * fromIntegral baseH)

  window <-
    SDL.createWindow
      "Monomer application"
      SDL.defaultWindow {
        SDL.windowInitialSize = SDL.V2 (round winW) (round winH),
        SDL.windowHighDPI = True,
        SDL.windowResizable = windowResizable,
        SDL.windowBorder = windowBorder,
        SDL.windowGraphicsContext = SDL.OpenGLContext customOpenGL
      }

  -- Get device pixel rate
  Size dw _ <- getDrawableSize window
  Size ww _ <- getWindowSize window
  let scaleFactor = factor * userScaleFactor
  let contentRatio = dw / ww
  let (dpr, epr)
        | platform `elem` ["Windows", "Linux"] = (scaleFactor, 1 / scaleFactor)
        | otherwise = (scaleFactor * contentRatio, 1 / scaleFactor) -- macOS

  setWindowIcon window config

  whenJust (_apcWindowTitle config) $ \title ->
    SDL.windowTitle window $= title

  when windowFullscreen $
    SDL.setWindowMode window SDL.FullscreenDesktop

  when windowMaximized $
    SDL.setWindowMode window SDL.Maximized

  err <- SRE.getError
  err <- STR.peekCString err
  putStrLnErr err

  ctxRender <- SDL.glCreateContext window

  when (platform == "Windows") $
    void $ SDL.glCreateContext window

  _ <- glewInit

  return (window, dpr, epr, ctxRender)
  where
    customOpenGL = SDL.OpenGLConfig {
      SDL.glColorPrecision = SDL.V4 8 8 8 0,
      SDL.glDepthPrecision = 24,
      SDL.glStencilPrecision = 8,
      --SDL.glProfile = SDL.Core SDL.Debug 3 2,
      SDL.glProfile = SDL.Core SDL.Normal 3 2,
      SDL.glMultisampleSamples = 1
    }

    disableCompositingFlag = _apcDisableCompositing config == Just True
    disableScreensaverFlag = _apcDisableScreensaver config == Just True
    disableAutoScale = _apcDisableAutoScale config == Just True
    userScaleFactor = fromMaybe 1 (_apcScaleFactor config)

    (baseW, baseH) = case _apcWindowState config of
      Just (MainWindowNormal size) -> size
      _ -> defaultWindowSize
    windowResizable = fromMaybe True (_apcWindowResizable config)
    windowBorder = fromMaybe True (_apcWindowBorder config)
    windowFullscreen = case _apcWindowState config of
      Just MainWindowFullScreen -> True
      _ -> False
    windowMaximized = case _apcWindowState config of
      Just MainWindowMaximized -> True
      _ -> False

setWindowIcon :: SDL.Window -> AppConfig s e -> IO ()
setWindowIcon (SIT.Window winPtr) config =
  forM_ (_apcWindowIcon config) $ \iconPath ->
    flip catchAny handleException $ do
      iconSurface <- loadImgToSurface (T.unpack iconPath)
      let SVR.Surface iconSurfacePtr _ = iconSurface
      finally
        -- Note: this can use the high-level setWindowIcon once it is available (https://github.com/haskell-game/sdl2/pull/243)
        (Raw.setWindowIcon winPtr iconSurfacePtr)
        (SVR.freeSurface iconSurface)
  where
    handleException err = putStrLnErr $
      "Failed to set window icon. Does the file exist?\n\t" ++ show err ++ "\n"

-- | Destroys the provided window, shutdowns the video subsystem and SDL.
destroySDLWindow :: SDL.Window -> IO ()
destroySDLWindow window = do
  SDL.destroyWindow window
  Raw.quitSubSystem Raw.SDL_INIT_VIDEO
  SDL.quit

-- | Returns the current mouse position.
getCurrentMousePos :: Double -> IO Point
getCurrentMousePos epr = do
  SDL.P (SDL.V2 x y) <- Mouse.getAbsoluteMouseLocation
  return $ Point (epr * fromIntegral x) (epr * fromIntegral 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 = do
  SDL.V2 fbWidth fbHeight <- SDL.glGetDrawableSize window
  return $ Size (fromIntegral fbWidth) (fromIntegral fbHeight)

-- | Returns the size of the provided window.
getWindowSize :: SDL.Window -> IO Size
getWindowSize window = do
  SDL.V2 rw rh <- SDL.get (SDL.windowSize window)

  return $ Size (fromIntegral rw) (fromIntegral 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 dpr = do
  SDL.V2 fw fh <- SDL.glGetDrawableSize window

  return $ Size (fromIntegral fw / dpr) (fromIntegral fh / dpr)

-- | Returns the name of the host OS.
getPlatform :: IO Text
getPlatform = do
  platform <- peekCString =<< Raw.getPlatform

  return $ T.pack platform

-- | Returns the diagonal, horizontal and vertical DPI of the main display.
getDisplayDPI :: IO (Double, Double, Double)
getDisplayDPI =
  alloca $ \pddpi ->
    alloca $ \phdpi ->
      alloca $ \pvdpi -> do
        Raw.getDisplayDPI 0 pddpi phdpi pvdpi
        ddpi <- peek pddpi
        hdpi <- peek phdpi
        vdpi <- peek pvdpi
        return (realToFrac ddpi, realToFrac hdpi, realToFrac vdpi)

-- | Returns the default resize factor for Windows.
getWindowsFactor :: IO Double
getWindowsFactor = max 1 <$> getDisplayDPIFactor

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

  alloca $ \pmode -> do
    Raw.getCurrentDisplayMode 0 pmode
    mode <- peek pmode

    let width = Raw.displayModeW mode
    let detectedDPI
          | dpiFactor > 0 = dpiFactor
          | width <= 1920 = 1
          | otherwise = 2

    return detectedDPI

-- | Returns DPI scaling factor using SDL_GetDisplayDPI.
getDisplayDPIFactor :: IO Double
getDisplayDPIFactor = do
  (ddpi, hdpi, vdpi) <- getDisplayDPI
  return (hdpi / 96)

setDisableCompositorHint :: Bool -> IO ()
setDisableCompositorHint disable =
  setBooleanHintSDL "SDL_VIDEO_X11_NET_WM_BYPASS_COMPOSITOR" disable

setBooleanHintSDL :: String -> Bool -> IO ()
setBooleanHintSDL flagName value = void $
  withCString flagName $ \cHintNameStr ->
    withCString valueStr $ \cValueStr ->
      Raw.setHint cHintNameStr cValueStr
  where
    valueStr = if value then "1" else "0"

readImageRGBA8 :: FilePath -> IO (P.Image P.PixelRGBA8)
readImageRGBA8 path = P.readImage path
  >>= either fail (return . P.convertRGBA8)

loadImgToSurface :: FilePath -> IO SDL.Surface
loadImgToSurface path = do
  rgba8 <- readImageRGBA8 path
  imgData <- V.thaw (P.imageData rgba8)

  let width = fromIntegral $ P.imageWidth rgba8
      height = fromIntegral $ P.imageHeight rgba8
      imgSize = SDL.V2 width height

  SDL.createRGBSurfaceFrom imgData imgSize (4 * width) SDL.ABGR8888