Implemenet GLFW window system

seangine.cabal

@@ -45,6 +45,7 @@ library
         Graphics.Seangine,
         Graphics.Seangine.Types,
         Graphics.Seangine.Types.Config,
+        Graphics.Seangine.Types.Errors,
         Graphics.Seangine.Types.R,
         Graphics.Seangine.Window,
         Graphics.Seangine.Window.Sdl,
@@ -58,6 +59,8 @@ library
       unliftio-core,
       vector,
       vulkan
+    extra-libraries:
+      glfw
     hs-source-dirs:   src
     default-language: GHC2021
 

src/Graphics/Seangine/Types.hs

@@ -1,7 +1,9 @@
 module Graphics.Seangine.Types
   ( module Graphics.Seangine.Types.Config,
+    module Graphics.Seangine.Types.Errors,
     module Graphics.Seangine.Types.R,
   ) where
 
 import Graphics.Seangine.Types.Config
+import Graphics.Seangine.Types.Errors
 import Graphics.Seangine.Types.R

src/Graphics/Seangine/Window/Glfw.hs

@@ -2,12 +2,18 @@ module Graphics.Seangine.Window.Glfw
   ( GlfwWindowSystem (),
   ) where
 
+import Graphics.Seangine.Types (Errors (..))
 import Graphics.Seangine.Window.Types (Event (..), Window (), WindowSystem (..))
 
+import Control.Exception (throwIO)
+import Data.ByteString (packCString)
 import Data.Vector (Vector)
+import Data.Vector qualified as Vector
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
 import Graphics.UI.GLFW qualified as GLFW
-import Linear (V2)
-import Vulkan.Core10 (Instance)
+import Linear (V2 (..))
+import Vulkan.Core10 (Instance, instanceHandle)
 import Vulkan.Extensions.VK_KHR_surface
 
 data GlfwWindowSystem = GlfwWindowSystem
@@ -16,7 +22,7 @@ newtype instance Window GlfwWindowSystem = GlfwWindow {unWindow :: GLFW.Window}
 
 instance WindowSystem GlfwWindowSystem where
   initWindowSystem _ = initGlfw
-  destroyWindowSystem _ = pass
+  destroyWindowSystem _ = destroyGlfw
   createWindow _ = createGlfwWindow
   destroyWindow = destroyGlfwWindow
   getWindowSurface = getGlfwWindowSurface
@@ -25,22 +31,52 @@ instance WindowSystem GlfwWindowSystem where
   pollWindowEvents _ = pollGlfwWindowEvents
 
 initGlfw :: MonadIO io => io GlfwWindowSystem
-initGlfw = pure GlfwWindowSystem
+initGlfw = liftIO $ GLFW.init >>= bool (throwIO WindowSystemFailure) setWindowHints
+  where
+    setWindowHints = GLFW.windowHint (GLFW.WindowHint'Resizable False) >> pure GlfwWindowSystem
+
+destroyGlfw :: MonadIO io => io ()
+destroyGlfw = liftIO GLFW.terminate
 
 createGlfwWindow :: MonadIO io => Text -> Int -> Int -> io (Window GlfwWindowSystem)
-createGlfwWindow _ _ _ = undefined
+createGlfwWindow title width height =
+  liftIO $ maybe (throwIO WindowSystemFailure) (pure . GlfwWindow) =<< createWindow'
+  where
+    createWindow' = GLFW.createWindow width height title' Nothing Nothing
+    title' = toString title
 
 destroyGlfwWindow :: MonadIO io => Window GlfwWindowSystem -> io ()
-destroyGlfwWindow = undefined
+destroyGlfwWindow = liftIO . GLFW.destroyWindow . unWindow
 
 getGlfwWindowSurface :: MonadIO io => Window GlfwWindowSystem -> Instance -> io SurfaceKHR
-getGlfwWindowSurface _ _ = undefined
+getGlfwWindowSurface (GlfwWindow window) inst =
+  liftIO $ alloca @SurfaceKHR createWindowSurface'
+  where
+    allocPtr = nullPtr
+    instPtr = castPtr $ instanceHandle inst
+
+    createWindowSurface' surfacePtr = do
+      res <- GLFW.createWindowSurface @Int instPtr window allocPtr surfacePtr
+      if res == 0
+        then pure $ ptrToSurfaceKhr surfacePtr
+        else throwIO WindowSystemFailure
+
+    ptrToSurfaceKhr ptr = case ptrToWordPtr ptr of
+      WordPtr handle -> SurfaceKHR $ fromIntegral handle
 
 getGlfwDrawableSize :: MonadIO io => Window GlfwWindowSystem -> io (V2 Int)
-getGlfwDrawableSize _ = undefined
+getGlfwDrawableSize = liftIO . getWindowSize' . unWindow
+  where
+    getWindowSize' win = uncurry V2 <$> GLFW.getWindowSize win
 
 getGlfwWindowExtensions :: MonadIO io => Window GlfwWindowSystem -> io (Vector ByteString)
-getGlfwWindowExtensions _ = undefined
+getGlfwWindowExtensions _ =
+  liftIO $ GLFW.getRequiredInstanceExtensions >>= toByteStringVector
+  where
+    toByteStringVector = mapM packCString . Vector.fromList
 
-pollGlfwWindowEvents :: MonadIO io => io [Event]
-pollGlfwWindowEvents = undefined
+pollGlfwWindowEvents :: MonadIO io => Window GlfwWindowSystem -> io [Event]
+pollGlfwWindowEvents (GlfwWindow window) = liftIO $ do
+  GLFW.pollEvents
+  shouldClose <- GLFW.windowShouldClose window
+  pure [QuitEvent | shouldClose]

src/Graphics/Seangine/Window/Sdl.hs

@@ -27,7 +27,7 @@ instance WindowSystem SdlWindowSystem where
   getWindowSurface = getSdlWindowSurface
   getDrawableSize = getSdlDrawableSize
   getWindowExtensions = getSdlWindowExtensions
-  pollWindowEvents _ = pollSdlWindowEvents
+  pollWindowEvents _ _ = pollSdlWindowEvents
 
 initSdl :: MonadIO io => io SdlWindowSystem
 initSdl = SDL.initialize initFlags $> SdlWindowSystem

src/Graphics/Seangine/Window/Types.hs

@@ -51,4 +51,4 @@ class WindowSystem system where
     => Window system
     -> io (Vector ByteString)
 
-  pollWindowEvents :: MonadIO io => system -> io [Event]
+  pollWindowEvents :: MonadIO io => system -> Window system -> io [Event]