Display.hs

{-# LANGUAGE OverloadedRecordDot #-}

module NanoUI.Sdl.Display
  ( defaultFontSize
  , queryWindowPixelDensity
  , queryWindowRefreshHz
  , queryWindowLogicalSize
  , queryMouseWindowPos
  , zoomWindow
  , installResizeWatch
  , refreshEventType
  , initRefreshEvent
  , pushRefreshEvent
  ) where

import Control.Monad (unless, void)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Foreign.C.Types (CInt (..))
import Foreign.Marshal.Alloc (alloca, callocBytes)
import Foreign.Ptr (FunPtr, Ptr, freeHaskellFunPtr)
import Foreign.Storable (peek, poke, sizeOf)
import Data.Word (Word32)
import NanoUI (Size (..), V2 (..))
import SDL3.Sys.Bindgen.Events (SDL_Event)
import SDL3.Sys.Bindgen.Stdinc (Uint32 (..))
import SDL3.Sys.Bindgen.Video (SDL_Window)
import SDL3.Sys.Events (pushEvent, registerEvents)
import SDL3.Sys.Mouse (getMouseState)
import SDL3.Sys.Bindgen.Rect (SDL_Rect (..))
import SDL3.Sys.Video (getDisplayForWindow, getDisplayUsableBounds, getWindowPixelDensity, getWindowSize, setWindowPosition, setWindowSize)
import System.IO.Unsafe (unsafePerformIO)

defaultFontSize :: Float
defaultFontSize = 16

-- | Backbuffer pixels per window coordinate: the factor the retained
-- framebuffer, glyph rasterization and snapping need. This is not
-- 'SDL_GetWindowDisplayScale', which also folds in the desktop's content
-- scale. On Windows window coordinates are already pixels, so at 125%
-- scaling the display scale is 1.25 while the density is 1; sizing the
-- framebuffer by the display scale rendered 1.56x the window's pixels and
-- squeezed them back down on every present.
queryWindowPixelDensity :: Ptr SDL_Window -> IO Float
queryWindowPixelDensity win = do
  s <- getWindowPixelDensity win
  pure (if s > 0 then s else 1)

-- | Vertical refresh rate of the window's current display mode, in Hz
-- (0 when unavailable).
queryWindowRefreshHz :: Ptr SDL_Window -> IO Int
queryWindowRefreshHz win = do
  hz <- windowRefreshRateC win
  pure (max 0 (fromIntegral hz))

-- | Window size in window (logical) coordinates; 0x0 when SDL cannot say.
-- SDL_GetWindowSize already returns the window-coordinate size, not pixels.
-- Dividing by the display scale would shrink the logical size on DPI-scaled
-- displays, making the retained framebuffer too small.
queryWindowLogicalSize :: Ptr SDL_Window -> IO Size
queryWindowLogicalSize win =
  alloca $ \wp ->
    alloca $ \hp -> do
      ok <- getWindowSize win wp hp
      if ok
        then do
          w <- peek wp
          h <- peek hp
          pure (Size (fromIntegral w) (fromIntegral h))
        else pure (Size 0 0)

-- | Pointer position relative to the window with mouse focus, in window
-- coordinates. Uses 'SDL_GetMouseState' rather than the global pointer +
-- window position: the latter is unreliable on Wayland (window position is not
-- exposed) and breaks hover/wheel targeting.
queryMouseWindowPos :: IO V2
queryMouseWindowPos =
  alloca $ \xp ->
    alloca $ \yp -> do
      void (getMouseState xp yp)
      x <- peek xp
      y <- peek yp
      pure (V2 (realToFrac x) (realToFrac y))

-- Windows runs a modal loop while the user drags the border, so the app
-- event watch does not run. SDL still delivers resize events to this watch.
installResizeWatch :: IO () -> IO (IO ())
installResizeWatch act = do
  fp <- mkResizeCb act
  ok <- installResizeWatchC fp
  unless ok $ fail "SDL_AddEventWatch failed"
  pure $ do
    removeResizeWatchC
    freeHaskellFunPtr fp

-- | The user event type that wakes the event loop, registered once per
-- process by 'initRefreshEvent'; 0 until then.
{-# NOINLINE refreshEventType #-}
refreshEventType :: IORef Word32
refreshEventType = unsafePerformIO (newIORef 0)

-- | The event 'pushRefreshEvent' sends, filled in once by 'initRefreshEvent'.
-- The core wakes the loop on every 'markDirty', so a push must not allocate.
{-# NOINLINE refreshEvent #-}
refreshEvent :: Ptr SDL_Event
refreshEvent = unsafePerformIO (callocBytes (sizeOf (undefined :: SDL_Event)))

initRefreshEvent :: IO Bool
initRefreshEvent = do
  registered <- readIORef refreshEventType
  if registered /= 0
    then pure True
    else do
      ty <- registerEvents 1
      poke refreshEvent.type' (Uint32 ty)
      writeIORef refreshEventType ty
      pure (ty /= 0)

pushRefreshEvent :: IO ()
pushRefreshEvent = do
  ty <- readIORef refreshEventType
  unless (ty == 0) $ void (pushEvent refreshEvent)

foreign import ccall unsafe "nano_ui_window_refresh_rate"
  windowRefreshRateC :: Ptr SDL_Window -> IO CInt

foreign import ccall "wrapper"
  mkResizeCb :: IO () -> IO (FunPtr (IO ()))

foreign import ccall safe "nano_ui_install_resize_watch"
  installResizeWatchC :: FunPtr (IO ()) -> IO Bool

foreign import ccall safe "nano_ui_remove_resize_watch"
  removeResizeWatchC :: IO ()

-- | Grow a window just opened at a logical size by the UI zoom, as far as
-- the usable area of its display allows, and centre it again.
zoomWindow :: Ptr SDL_Window -> Size -> Float -> IO ()
zoomWindow win (Size w h) zoom = do
  display <- getDisplayForWindow win
  usable <- alloca $ \rp -> do
    ok <- getDisplayUsableBounds display rp
    if ok then Just <$> peek rp else pure Nothing
  let fit want avail = case avail of
        Just a | a > 0 -> min want (fromIntegral a)
        _ -> want
      zw = fit (w * zoom) ((.w) <$> usable)
      zh = fit (h * zoom) ((.h) <$> usable)
      centred = 0x2FFF0000 -- SDL_WINDOWPOS_CENTERED
  void $ setWindowSize win (round zw) (round zh)
  void $ setWindowPosition win centred centred