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)