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 $cp1Ord :: Eq GLFWError 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 :: 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 :: 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 :: 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 :: 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 :: 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 <- Ptr Any -> Window -> Ptr Any -> Ptr Word64 -> IO Int32 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_ :: (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 :: (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)