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
(GLFWError -> GLFWError -> Bool)
-> (GLFWError -> GLFWError -> Bool) -> Eq GLFWError
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
Eq GLFWError
-> (GLFWError -> GLFWError -> Ordering)
-> (GLFWError -> GLFWError -> Bool)
-> (GLFWError -> GLFWError -> Bool)
-> (GLFWError -> GLFWError -> Bool)
-> (GLFWError -> GLFWError -> Bool)
-> (GLFWError -> GLFWError -> GLFWError)
-> (GLFWError -> GLFWError -> GLFWError)
-> Ord 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
(Int -> GLFWError -> ShowS)
-> (GLFWError -> String)
-> ([GLFWError] -> ShowS)
-> Show GLFWError
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
  -> Natural
  -> SizePicker
  -> Text
  -> m ([InstanceRequirement], GLFW.Window)
allocate :: forall (m :: * -> *) env.
(MonadUnliftIO m, MonadReader env m, HasLogFunc env,
 MonadResource m) =>
Bool
-> Natural
-> SizePicker
-> Text
-> m ([InstanceRequirement], Window)
allocate Bool
fullscreen Natural
displayNum SizePicker
sizePicker Text
title = do
  UnliftIO forall a. m a -> IO a
unliftIO <- m (UnliftIO m)
forall (m :: * -> *). MonadUnliftIO m => m (UnliftIO m)
askUnliftIO

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

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

  ((ReleaseKey, ([InstanceRequirement], Window))
 -> ([InstanceRequirement], Window))
-> m (ReleaseKey, ([InstanceRequirement], Window))
-> m ([InstanceRequirement], Window)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ReleaseKey, ([InstanceRequirement], Window))
-> ([InstanceRequirement], Window)
forall a b. (a, b) -> b
snd (m (ReleaseKey, ([InstanceRequirement], Window))
 -> m ([InstanceRequirement], Window))
-> m (ReleaseKey, ([InstanceRequirement], Window))
-> m ([InstanceRequirement], Window)
forall a b. (a -> b) -> a -> b
$ IO ([InstanceRequirement], Window)
-> (([InstanceRequirement], Window) -> IO ())
-> m (ReleaseKey, ([InstanceRequirement], Window))
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
  -> Natural
  -> SizePicker
  -> Text
  -> m ([InstanceRequirement], GLFW.Window)
createWindow :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env) =>
Bool
-> Natural
-> SizePicker
-> Text
-> m ([InstanceRequirement], Window)
createWindow Bool
fullScreen Natural
displayNum SizePicker
sizePicker Text
title = do
  (Error -> String -> GLFWError) -> IO Bool -> m ()
forall (io :: * -> *).
MonadIO io =>
(Error -> String -> GLFWError) -> IO Bool -> io ()
runGlfwIO_ Error -> String -> GLFWError
InitError IO Bool
GLFW.init
  (Error -> String -> GLFWError) -> IO Bool -> m ()
forall (io :: * -> *).
MonadIO io =>
(Error -> String -> GLFWError) -> IO Bool -> io ()
runGlfwIO_ Error -> String -> GLFWError
VulkanError IO Bool
GLFW.vulkanSupported

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

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

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

  (Monitor
monitor, VideoMode
mode) <-
    case [Maybe (Monitor, VideoMode)] -> [(Monitor, VideoMode)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Monitor, VideoMode)]
modes of
      [] ->
        IO (Monitor, VideoMode) -> m (Monitor, VideoMode)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Monitor, VideoMode) -> m (Monitor, VideoMode))
-> (GLFWError -> IO (Monitor, VideoMode))
-> GLFWError
-> m (Monitor, VideoMode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GLFWError -> IO (Monitor, VideoMode)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (GLFWError -> m (Monitor, VideoMode))
-> GLFWError -> m (Monitor, VideoMode)
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 ->
        (Monitor, VideoMode) -> m (Monitor, VideoMode)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Monitor, VideoMode) -> m (Monitor, VideoMode))
-> (Monitor, VideoMode) -> m (Monitor, VideoMode)
forall a b. (a -> b) -> a -> b
$ SizePicker
sizePicker ((Monitor, VideoMode)
so (Monitor, VideoMode)
-> [(Monitor, VideoMode)] -> NonEmpty (Monitor, VideoMode)
forall a. a -> [a] -> NonEmpty a
:| [(Monitor, VideoMode)]
me)

  let
    GLFW.VideoMode{videoModeWidth :: VideoMode -> Int
videoModeWidth=Int
width, videoModeHeight :: VideoMode -> Int
videoModeHeight=Int
height} = VideoMode
mode
    fsMonitor :: Maybe Monitor
fsMonitor =
      if Bool
fullScreen then
        Monitor -> Maybe Monitor
forall a. a -> Maybe a
Just Monitor
monitor
      else
        Maybe Monitor
forall a. Maybe a
Nothing

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

  Window
window <- (Error -> String -> GLFWError) -> IO (Maybe Window) -> m Window
forall (io :: * -> *) a.
MonadIO io =>
(Error -> String -> GLFWError) -> IO (Maybe a) -> io a
runGlfwIO Error -> String -> GLFWError
WindowError (IO (Maybe Window) -> m Window) -> IO (Maybe Window) -> m Window
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 Maybe Window
forall a. Maybe a
Nothing

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

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fullScreen (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
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 Maybe ByteString
forall a. Maybe a
Nothing ByteString
name Word32
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
  Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Destroying GLFW window"
  IO () -> m ()
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_ =
  IO SurfaceKHR
-> (SurfaceKHR -> IO ()) -> m (ReleaseKey, SurfaceKHR)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate
    (Window -> Instance -> IO SurfaceKHR
forall (m :: * -> *).
MonadIO m =>
Window -> Instance -> m SurfaceKHR
createSurface Window
window Instance
instance_)
    (\SurfaceKHR
surf -> Instance
-> SurfaceKHR
-> ("allocator" ::: Maybe AllocationCallbacks)
-> IO ()
forall (io :: * -> *).
MonadIO io =>
Instance
-> SurfaceKHR
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ()
Khr.destroySurfaceKHR Instance
instance_ SurfaceKHR
surf "allocator" ::: Maybe AllocationCallbacks
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_ =
  IO SurfaceKHR -> m SurfaceKHR
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SurfaceKHR -> m SurfaceKHR) -> IO SurfaceKHR -> m SurfaceKHR
forall a b. (a -> b) -> a -> b
$ (Ptr Word64 -> IO SurfaceKHR) -> IO SurfaceKHR
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 Ptr Any
forall a. Ptr a
Foreign.nullPtr Ptr Word64
dst
    if Int32
vkResult Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
0 then
      (Word64 -> SurfaceKHR) -> IO Word64 -> IO SurfaceKHR
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> SurfaceKHR
Khr.SurfaceKHR (IO Word64 -> IO SurfaceKHR) -> IO Word64 -> IO SurfaceKHR
forall a b. (a -> b) -> a -> b
$ Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
Foreign.peek Ptr Word64
dst
    else
      GLFWError -> IO SurfaceKHR
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (GLFWError -> IO SurfaceKHR)
-> (Result -> GLFWError) -> Result -> IO SurfaceKHR
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> GLFWError
SurfaceError (Result -> IO SurfaceKHR) -> Result -> IO SurfaceKHR
forall a b. (a -> b) -> a -> b
$ Int32 -> Result
Vk.Result Int32
vkResult
  where
    inst :: Ptr Any
inst = Ptr Instance_T -> Ptr Any
forall a b. Ptr a -> Ptr b
Foreign.castPtr (Ptr Instance_T -> Ptr Any) -> Ptr Instance_T -> Ptr Any
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 =
  (Error -> String -> GLFWError) -> IO (Maybe ()) -> io ()
forall (io :: * -> *) a.
MonadIO io =>
(Error -> String -> GLFWError) -> IO (Maybe a) -> io a
runGlfwIO Error -> String -> GLFWError
cons (IO (Maybe ()) -> io ()) -> IO (Maybe ()) -> io ()
forall a b. (a -> b) -> a -> b
$ IO Bool
action IO Bool -> (Bool -> IO (Maybe ())) -> IO (Maybe ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True ->
      Maybe () -> IO (Maybe ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe () -> IO (Maybe ())) -> Maybe () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ () -> Maybe ()
forall a. a -> Maybe a
Just ()
    Bool
False ->
      Maybe () -> IO (Maybe ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ()
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 =
  IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> io a) -> IO a -> io a
forall a b. (a -> b) -> a -> b
$ IO (Maybe a)
action IO (Maybe a) -> (Maybe a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just a
res ->
      a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
    Maybe a
Nothing ->
      IO (Maybe (Error, String))
GLFW.getError IO (Maybe (Error, String))
-> (Maybe (Error, String) -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (Error
err, String
msg) ->
          GLFWError -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (GLFWError -> IO a) -> GLFWError -> IO a
forall a b. (a -> b) -> a -> b
$ Error -> String -> GLFWError
cons Error
err String
msg
        Maybe (Error, String)
Nothing ->
          GLFWError -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (GLFWError -> IO a) -> GLFWError -> IO a
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 = SizePicker
forall a. NonEmpty a -> a
NonEmpty.head SizePicker -> SizePicker
forall a b. (a -> b) -> a -> b
$ ((Monitor, VideoMode) -> (Monitor, VideoMode) -> Ordering)
-> NonEmpty (Monitor, VideoMode) -> NonEmpty (Monitor, VideoMode)
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NonEmpty.sortBy ((Int -> Int -> Ordering) -> Int -> Int -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((Monitor, VideoMode) -> Int)
-> (Monitor, VideoMode)
-> (Monitor, VideoMode)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Monitor, VideoMode) -> Int
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 Int -> Int -> Int
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
  Extent2D -> IO Extent2D
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Extent2D -> IO Extent2D) -> Extent2D -> IO Extent2D
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> Extent2D
Vk.Extent2D (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width) (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height)