Window.hs

module Engine.Setup.Window
  ( GLFW.Window
  , allocate
  , createWindow
  , destroyWindow

  , SizePicker
  , pickLargest

  , Khr.SurfaceKHR
  , allocateSurface
  , createSurface

  , getExtent2D

  , GLFWError
  , GLFW.Error
  ) where

import RIO hiding (some)

import Data.List.NonEmpty qualified as NonEmpty
import Foreign qualified
import Graphics.UI.GLFW qualified as GLFW
import RIO.ByteString qualified as BS
import RIO.Text qualified as Text
import UnliftIO.Resource (MonadResource)
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk
import Vulkan.Extensions.VK_KHR_surface qualified as Khr
import Vulkan.Requirement (InstanceRequirement(..))

data GLFWError
  = InitError      GLFW.Error String
  | VulkanError    GLFW.Error String
  | MonitorError   GLFW.Error String
  | VideoModeError GLFW.Error String
  | WindowError    GLFW.Error String
  | SurfaceError   Vk.Result
  deriving (Eq, Ord, Show)

instance Exception GLFWError

type SizePicker = NonEmpty (GLFW.Monitor, GLFW.VideoMode) -> (GLFW.Monitor, GLFW.VideoMode)

allocate
  :: ( MonadUnliftIO m
     , MonadReader env m, HasLogFunc env
     , MonadResource m
     )
  => Bool
  -> SizePicker
  -> Text
  -> m ([InstanceRequirement], GLFW.Window)
allocate fullscreen sizePicker title = do
  UnliftIO unliftIO <- askUnliftIO

  let
    create = unliftIO $
      createWindow fullscreen sizePicker title

    destroy (_exts, window) = unliftIO $
      destroyWindow window

  fmap snd $ Resource.allocate create destroy

createWindow
  :: (MonadIO m, MonadReader env m, HasLogFunc env)
  => Bool -> SizePicker -> Text -> m ([InstanceRequirement], GLFW.Window)
createWindow fullScreen sizePicker title = do
  runGlfwIO_ InitError GLFW.init
  runGlfwIO_ VulkanError GLFW.vulkanSupported

  liftIO . GLFW.windowHint $ GLFW.WindowHint'ClientAPI GLFW.ClientAPI'NoAPI

  sizes <- runGlfwIO MonitorError GLFW.getMonitors >>= \case
    [] ->
      liftIO . throwIO $ MonitorError GLFW.Error'PlatformError "No monitors returned"
    some ->
      fmap NonEmpty.fromList $
        for some \monitor -> do
          mode <- runGlfwIO VideoModeError $ GLFW.getVideoMode monitor
          pure (monitor, mode)

  let
    (monitor, mode) = sizePicker sizes
    GLFW.VideoMode{videoModeWidth=width, videoModeHeight=height} = mode
    fsMonitor =
      if fullScreen then
        Just monitor
      else
        Nothing

  logDebug $ "Display mode picked: " <> displayShow mode

  window <- runGlfwIO WindowError $
    GLFW.createWindow width height (Text.unpack title) fsMonitor Nothing

  extNamesC <- liftIO $ GLFW.getRequiredInstanceExtensions
  extNames <- liftIO $ traverse BS.packCString extNamesC

  when fullScreen $
    liftIO $ GLFW.setFullscreen window monitor mode

  let
    instanceReqs = do
      name <- extNames
      pure $ RequireInstanceExtension Nothing name minBound

  pure (instanceReqs, window)

destroyWindow
  :: (MonadIO m, MonadReader env m, HasLogFunc env)
  => GLFW.Window -> m ()
destroyWindow window = do
  logDebug "Destroying GLFW window"
  liftIO do
    GLFW.destroyWindow window
    GLFW.terminate

allocateSurface
  :: MonadResource m
  => GLFW.Window
  -> Vk.Instance
  -> m (Resource.ReleaseKey, Khr.SurfaceKHR)
allocateSurface window instance_ =
  Resource.allocate
    (createSurface window instance_)
    (\surf -> Khr.destroySurfaceKHR instance_ surf Nothing)

createSurface :: MonadIO m => GLFW.Window -> Vk.Instance -> m Khr.SurfaceKHR
createSurface window instance_ =
  liftIO $ Foreign.alloca \dst -> do
    vkResult <- GLFW.createWindowSurface @Foreign.Int32 inst window Foreign.nullPtr dst
    if vkResult == 0 then
      fmap Khr.SurfaceKHR $ Foreign.peek dst
    else
      throwIO . SurfaceError $ Vk.Result vkResult
  where
    inst = Foreign.castPtr $ Vk.instanceHandle instance_

runGlfwIO_ :: MonadIO io => (GLFW.Error -> String -> GLFWError) -> IO Bool -> io ()
runGlfwIO_ cons action =
  runGlfwIO cons $ action >>= \case
    True ->
      pure $ Just ()
    False ->
      pure Nothing

runGlfwIO :: MonadIO io => (GLFW.Error -> String -> GLFWError) -> IO (Maybe a) -> io a
runGlfwIO cons action =
  liftIO $ action >>= \case
    Just res ->
      pure res
    Nothing ->
      GLFW.getError >>= \case
        Just (err, msg) ->
          throwIO $ cons err msg
        Nothing ->
          throwIO $ cons GLFW.Error'PlatformError "Unknown error"

pickLargest :: SizePicker
pickLargest monitors = NonEmpty.head $ NonEmpty.sortBy (flip compare `on` getArea) monitors
  where
    getArea (_mon, GLFW.VideoMode{videoModeWidth=w, videoModeHeight=h}) =
      w * h

getExtent2D :: GLFW.Window -> IO Vk.Extent2D
getExtent2D window = do
  (width, height) <- GLFW.getFramebufferSize window
  pure $ Vk.Extent2D (fromIntegral width) (fromIntegral height)