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 (GLFWError -> GLFWError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GLFWError -> GLFWError -> Bool
$c/= :: GLFWError -> GLFWError -> Bool
== :: GLFWError -> GLFWError -> Bool
$c== :: GLFWError -> GLFWError -> Bool
Eq, Eq GLFWError
GLFWError -> GLFWError -> Bool
GLFWError -> GLFWError -> Ordering
GLFWError -> GLFWError -> GLFWError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: GLFWError -> GLFWError -> GLFWError
$cmin :: GLFWError -> GLFWError -> GLFWError
max :: GLFWError -> GLFWError -> GLFWError
$cmax :: GLFWError -> GLFWError -> GLFWError
>= :: GLFWError -> GLFWError -> Bool
$c>= :: GLFWError -> GLFWError -> Bool
> :: GLFWError -> GLFWError -> Bool
$c> :: GLFWError -> GLFWError -> Bool
<= :: GLFWError -> GLFWError -> Bool
$c<= :: GLFWError -> GLFWError -> Bool
< :: GLFWError -> GLFWError -> Bool
$c< :: GLFWError -> GLFWError -> Bool
compare :: GLFWError -> GLFWError -> Ordering
$ccompare :: GLFWError -> GLFWError -> Ordering
Ord, Int -> GLFWError -> ShowS
[GLFWError] -> ShowS
GLFWError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GLFWError] -> ShowS
$cshowList :: [GLFWError] -> ShowS
show :: GLFWError -> String
$cshow :: GLFWError -> String
showsPrec :: Int -> GLFWError -> ShowS
$cshowsPrec :: Int -> GLFWError -> ShowS
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
  -> Maybe (Int, Int)
  -> Natural
  -> SizePicker
  -> Text
  -> m ([InstanceRequirement], GLFW.Window)
allocate :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasLogFunc env,
 MonadResource m) =>
Bool
-> Maybe (Int, Int)
-> Natural
-> SizePicker
-> Text
-> m ([InstanceRequirement], Window)
allocate Bool
fullscreen Maybe (Int, Int)
size Natural
displayNum SizePicker
sizePicker Text
title = do
  UnliftIO forall a. m a -> IO a
unliftIO <- forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO

  let
    create :: IO ([InstanceRequirement], Window)
create = forall a. m a -> IO a
unliftIO forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
Bool
-> Maybe (Int, Int)
-> Natural
-> SizePicker
-> Text
-> m ([InstanceRequirement], Window)
createWindow Bool
fullscreen Maybe (Int, Int)
size Natural
displayNum SizePicker
sizePicker Text
title

    destroy :: ([InstanceRequirement], Window) -> IO ()
destroy ([InstanceRequirement]
_exts, Window
window) = forall a. m a -> IO a
unliftIO forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
Window -> m ()
destroyWindow Window
window

  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate IO ([InstanceRequirement], Window)
create ([InstanceRequirement], Window) -> IO ()
destroy

createWindow
  :: (MonadIO m, MonadReader env m, HasLogFunc env)
  => Bool
  -> Maybe (Int, Int)
  -> Natural
  -> SizePicker
  -> Text
  -> m ([InstanceRequirement], GLFW.Window)
createWindow :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
Bool
-> Maybe (Int, Int)
-> Natural
-> SizePicker
-> Text
-> m ([InstanceRequirement], Window)
createWindow Bool
fullScreen Maybe (Int, Int)
size Natural
displayNum SizePicker
sizePicker Text
title = do
  forall (io :: * -> *).
MonadIO io =>
(Error -> String -> GLFWError) -> IO Bool -> io ()
runGlfwIO_ Error -> String -> GLFWError
InitError IO Bool
GLFW.init
  forall (io :: * -> *).
MonadIO io =>
(Error -> String -> GLFWError) -> IO Bool -> io ()
runGlfwIO_ Error -> String -> GLFWError
VulkanError IO Bool
GLFW.vulkanSupported

  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowHint -> IO ()
GLFW.windowHint forall a b. (a -> b) -> a -> b
$ ClientAPI -> WindowHint
GLFW.WindowHint'ClientAPI ClientAPI
GLFW.ClientAPI'NoAPI

  [Monitor]
monitors <- forall (io :: * -> *) a.
MonadIO io =>
(Error -> String -> GLFWError) -> IO (Maybe a) -> io a
runGlfwIO Error -> String -> GLFWError
MonitorError IO (Maybe [Monitor])
GLFW.getMonitors
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Monitor]
monitors) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Error -> String -> GLFWError
MonitorError Error
GLFW.Error'PlatformError String
"No monitors returned"

  [Maybe (Monitor, VideoMode)]
modes <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (forall a b. [a] -> [b] -> [(a, b)]
zip [Natural
1..] [Monitor]
monitors) \(Natural
ix, Monitor
monitor) -> do
    VideoMode
mode <- forall (io :: * -> *) a.
MonadIO io =>
(Error -> String -> GLFWError) -> IO (Maybe a) -> io a
runGlfwIO Error -> String -> GLFWError
VideoModeError forall a b. (a -> b) -> a -> b
$ Monitor -> IO (Maybe VideoMode)
GLFW.getVideoMode Monitor
monitor
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
      [ Utf8Builder
"[display ", forall a. Show a => a -> Utf8Builder
displayShow Natural
ix, Utf8Builder
"] "
      , forall a. Show a => a -> Utf8Builder
displayShow VideoMode
mode
      ]
    if Natural
displayNum forall a. Eq a => a -> a -> Bool
/= Natural
0 Bool -> Bool -> Bool
&& Natural
displayNum forall a. Eq a => a -> a -> Bool
/= Natural
ix then
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    else do
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Monitor
monitor, VideoMode
mode)

  (Monitor
monitor, VideoMode
modeBase) <-
    case forall a. [Maybe a] -> [a]
catMaybes [Maybe (Monitor, VideoMode)]
modes of
      [] ->
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Error -> String -> GLFWError
MonitorError Error
GLFW.Error'PlatformError String
"Selected display number not available"
      (Monitor, VideoMode)
so : [(Monitor, VideoMode)]
me ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SizePicker
sizePicker ((Monitor, VideoMode)
so forall a. a -> [a] -> NonEmpty a
:| [(Monitor, VideoMode)]
me)

  let
    (VideoMode
mode, (Int
width, Int
height)) =
      case Maybe (Int, Int)
size of
        Just (Int
w, Int
h) ->
          ( VideoMode
modeBase
              { videoModeWidth :: Int
GLFW.videoModeWidth = Int
w
              , videoModeHeight :: Int
GLFW.videoModeHeight = Int
h
              }
          , (Int
w, Int
h)
          )
        Maybe (Int, Int)
Nothing ->
          let
            GLFW.VideoMode{videoModeWidth :: VideoMode -> Int
videoModeWidth=Int
w, videoModeHeight :: VideoMode -> Int
videoModeHeight=Int
h} = VideoMode
mode
          in
            ( VideoMode
modeBase
            , (Int
w, Int
h)
            )

    fsMonitor :: Maybe Monitor
fsMonitor =
      if Bool
fullScreen then
        forall a. a -> Maybe a
Just Monitor
monitor
      else
        forall a. Maybe a
Nothing

  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Display mode picked: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow VideoMode
mode

  Window
window <- forall (io :: * -> *) a.
MonadIO io =>
(Error -> String -> GLFWError) -> IO (Maybe a) -> io a
runGlfwIO Error -> String -> GLFWError
WindowError forall a b. (a -> b) -> a -> b
$
    Int
-> Int
-> String
-> Maybe Monitor
-> Maybe Window
-> IO (Maybe Window)
GLFW.createWindow Int
width Int
height (Text -> String
Text.unpack Text
title) Maybe Monitor
fsMonitor forall a. Maybe a
Nothing

  [CString]
extNamesC <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO [CString]
GLFW.getRequiredInstanceExtensions
  [ByteString]
extNames <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *). MonadIO m => CString -> m ByteString
BS.packCString [CString]
extNamesC

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fullScreen forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Window -> Monitor -> VideoMode -> IO ()
GLFW.setFullscreen Window
window Monitor
monitor VideoMode
mode

  let
    instanceReqs :: [InstanceRequirement]
instanceReqs = do
      ByteString
name <- [ByteString]
extNames
      pure $ Maybe ByteString -> ByteString -> Word32 -> InstanceRequirement
RequireInstanceExtension forall a. Maybe a
Nothing ByteString
name forall a. Bounded a => a
minBound

  pure ([InstanceRequirement]
instanceReqs, Window
window)

destroyWindow
  :: (MonadIO m, MonadReader env m, HasLogFunc env)
  => GLFW.Window -> m ()
destroyWindow :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
Window -> m ()
destroyWindow Window
window = do
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Destroying GLFW window"
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
    Window -> IO ()
GLFW.destroyWindow Window
window
    IO ()
GLFW.terminate

allocateSurface
  :: MonadResource m
  => GLFW.Window
  -> Vk.Instance
  -> m (Resource.ReleaseKey, Khr.SurfaceKHR)
allocateSurface :: forall (m :: * -> *).
MonadResource m =>
Window -> Instance -> m (ReleaseKey, SurfaceKHR)
allocateSurface Window
window Instance
instance_ =
  forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
    (forall (m :: * -> *).
MonadIO m =>
Window -> Instance -> m SurfaceKHR
createSurface Window
window Instance
instance_)
    (\SurfaceKHR
surf -> forall (io :: * -> *).
MonadIO io =>
Instance
-> SurfaceKHR
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ()
Khr.destroySurfaceKHR Instance
instance_ SurfaceKHR
surf forall a. Maybe a
Nothing)

createSurface :: MonadIO m => GLFW.Window -> Vk.Instance -> m Khr.SurfaceKHR
createSurface :: forall (m :: * -> *).
MonadIO m =>
Window -> Instance -> m SurfaceKHR
createSurface Window
window Instance
instance_ =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => (Ptr a -> IO b) -> IO b
Foreign.alloca \Ptr Word64
dst -> do
    Int32
vkResult <- forall vkResult vkInstance vkAllocationCallbacks vkSurfaceKHR.
Enum vkResult =>
Ptr vkInstance
-> Window
-> Ptr vkAllocationCallbacks
-> Ptr vkSurfaceKHR
-> IO vkResult
GLFW.createWindowSurface @Foreign.Int32 Ptr Any
inst Window
window forall a. Ptr a
Foreign.nullPtr Ptr Word64
dst
    if Int32
vkResult forall a. Eq a => a -> a -> Bool
== Int32
0 then
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> SurfaceKHR
Khr.SurfaceKHR forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Ptr a -> IO a
Foreign.peek Ptr Word64
dst
    else
      forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> GLFWError
SurfaceError forall a b. (a -> b) -> a -> b
$ Int32 -> Result
Vk.Result Int32
vkResult
  where
    inst :: Ptr Any
inst = forall a b. Ptr a -> Ptr b
Foreign.castPtr forall a b. (a -> b) -> a -> b
$ Instance -> Ptr Instance_T
Vk.instanceHandle Instance
instance_

runGlfwIO_ :: MonadIO io => (GLFW.Error -> String -> GLFWError) -> IO Bool -> io ()
runGlfwIO_ :: forall (io :: * -> *).
MonadIO io =>
(Error -> String -> GLFWError) -> IO Bool -> io ()
runGlfwIO_ Error -> String -> GLFWError
cons IO Bool
action =
  forall (io :: * -> *) a.
MonadIO io =>
(Error -> String -> GLFWError) -> IO (Maybe a) -> io a
runGlfwIO Error -> String -> GLFWError
cons forall a b. (a -> b) -> a -> b
$ IO Bool
action forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ()
    Bool
False ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

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

pickLargest :: SizePicker
pickLargest :: SizePicker
pickLargest NonEmpty (Monitor, VideoMode)
monitors = forall a. NonEmpty a -> a
NonEmpty.head forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NonEmpty.sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall {a}. (a, VideoMode) -> Int
getArea) NonEmpty (Monitor, VideoMode)
monitors
  where
    getArea :: (a, VideoMode) -> Int
getArea (a
_mon, GLFW.VideoMode{videoModeWidth :: VideoMode -> Int
videoModeWidth=Int
w, videoModeHeight :: VideoMode -> Int
videoModeHeight=Int
h}) =
      Int
w forall a. Num a => a -> a -> a
* Int
h

getExtent2D :: GLFW.Window -> IO Vk.Extent2D
getExtent2D :: Window -> IO Extent2D
getExtent2D Window
window = do
  (Int
width, Int
height) <- Window -> IO (Int, Int)
GLFW.getFramebufferSize Window
window
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> Extent2D
Vk.Extent2D (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height)