Add SDL+GLFW support

seangine.cabal

@@ -30,10 +30,13 @@ common common-options
         relude
     build-depends:
         base ^>= 4.16.0.0,
-        relude
+        relude,
+        linear
     default-extensions:
-        DerivingStrategies
-        RecordWildCards
+        DerivingStrategies,
+        OverloadedStrings,
+        RecordWildCards,
+        TypeFamilies
     default-language: GHC2021
 
 library
@@ -42,10 +45,16 @@ library
         Graphics.Seangine,
         Graphics.Seangine.Types,
         Graphics.Seangine.Types.Config,
-        Graphics.Seangine.Types.R
+        Graphics.Seangine.Types.R,
+        Graphics.Seangine.Window,
+        Graphics.Seangine.Window.Sdl,
+        Graphics.Seangine.Window.Glfw,
+        Graphics.Seangine.Window.Types
     build-depends:
+      GLFW-b,
       VulkanMemoryAllocator,
       resourcet,
+      sdl2,
       unliftio-core,
       vector,
       vulkan

src/Graphics/Seangine/Window.hs

@@ -0,0 +1,54 @@
+module Graphics.Seangine.Window
+  ( GlfwWindow,
+    SdlWindow,
+    WindowSystem (..),
+    glfw,
+    sdl,
+    withWindowSystem,
+    withWindow,
+    withWindowSurface,
+  ) where
+
+import Graphics.Seangine.Window.Glfw (GlfwWindow)
+import Graphics.Seangine.Window.Sdl (SdlWindow)
+import Graphics.Seangine.Window.Types (Window, WindowSystem (..))
+
+import Control.Monad.Trans.Resource
+import Vulkan.Core10 (Instance ())
+import Vulkan.Extensions.VK_KHR_surface (SurfaceKHR (..), destroySurfaceKHR)
+
+sdl :: Proxy SdlWindow
+sdl = Proxy
+
+glfw :: Proxy GlfwWindow
+glfw = Proxy
+
+withWindowSystem
+  :: (MonadResource m, WindowSystem window)
+  => Proxy window
+  -> m (ReleaseKey, window)
+withWindowSystem win = allocate (initWindowSystem win) destroyWindowSystem
+
+withWindow
+  :: (MonadResource m, WindowSystem window)
+  => window
+  -> Text
+  -> Int
+  -> Int
+  -> m (ReleaseKey, Window window)
+withWindow win title width height = do
+  let create = createWindow win title width height
+      destroy = destroyWindow win
+
+  allocate create destroy
+
+withWindowSurface
+  :: (MonadResource m, WindowSystem window)
+  => window
+  -> Window window
+  -> Instance
+  -> m (ReleaseKey, SurfaceKHR)
+withWindowSurface win handle inst = allocate create destroy
+  where
+    create = getWindowSurface win handle inst
+    destroy = flip (destroySurfaceKHR inst) Nothing

src/Graphics/Seangine/Window/Glfw.hs

@@ -0,0 +1,46 @@
+module Graphics.Seangine.Window.Glfw
+  ( GlfwWindow (),
+  ) where
+
+import Graphics.Seangine.Window.Types (Event (..), Window (), WindowSystem (..))
+
+import Data.Vector (Vector)
+import Graphics.UI.GLFW qualified as GLFW
+import Linear (V2)
+import Vulkan.Core10 (Instance)
+import Vulkan.Extensions.VK_KHR_surface
+
+data GlfwWindow = GlfwWindow
+
+type instance Window GlfwWindow = GLFW.Window
+
+instance WindowSystem GlfwWindow where
+  initWindowSystem _ = initGlfw
+  destroyWindowSystem _ = pass
+  createWindow _ = createGlfwWindow
+  destroyWindow _ = destroyGlfwWindow
+  getWindowSurface _ = getGlfwWindowSurface
+  getDrawableSize _ = getGlfwDrawableSize
+  getWindowExtensions _ = getGlfwWindowExtensions
+  pollWindowEvents _ = pollGlfwWindowEvents
+
+initGlfw :: MonadIO io => io GlfwWindow
+initGlfw = pure GlfwWindow
+
+createGlfwWindow :: MonadIO io => Text -> Int -> Int -> io GLFW.Window
+createGlfwWindow _ _ _ = undefined
+
+destroyGlfwWindow :: MonadIO io => GLFW.Window -> io ()
+destroyGlfwWindow = undefined
+
+getGlfwWindowSurface :: MonadIO io => GLFW.Window -> Instance -> io SurfaceKHR
+getGlfwWindowSurface _ _ = undefined
+
+getGlfwDrawableSize :: MonadIO io => GLFW.Window -> io (V2 Int)
+getGlfwDrawableSize _ = undefined
+
+getGlfwWindowExtensions :: MonadIO io => GLFW.Window -> io (Vector ByteString)
+getGlfwWindowExtensions _ = undefined
+
+pollGlfwWindowEvents :: MonadIO io => io [Event]
+pollGlfwWindowEvents = undefined

src/Graphics/Seangine/Window/Sdl.hs

@@ -0,0 +1,69 @@
+module Graphics.Seangine.Window.Sdl
+  ( SdlWindow (),
+  ) where
+
+import Graphics.Seangine.Window.Types (Event (..), Window (), WindowSystem (..))
+
+import Data.ByteString (packCString)
+import Data.Vector (Vector)
+import Data.Vector qualified as Vector
+import Foreign.Ptr (castPtr)
+import Linear (V2 (..))
+import SDL qualified
+import SDL.Video.Vulkan qualified as SDL
+import Vulkan.Core10 (Instance)
+import Vulkan.Core10.Handles (instanceHandle)
+import Vulkan.Extensions.VK_KHR_surface
+
+data SdlWindow = SdlWindow
+
+type instance Window SdlWindow = SDL.Window
+
+instance WindowSystem SdlWindow where
+  initWindowSystem _ = initSdl
+  destroyWindowSystem _ = SDL.quit
+  createWindow _ = createSdlWindow
+  destroyWindow _ = SDL.destroyWindow
+  getWindowSurface _ = getSdlWindowSurface
+  getDrawableSize _ = getSdlDrawableSize
+  getWindowExtensions _ = getSdlWindowExtensions
+  pollWindowEvents _ = pollSdlWindowEvents
+
+initSdl :: MonadIO io => io SdlWindow
+initSdl = SDL.initialize initFlags $> SdlWindow
+  where
+    initFlags = [SDL.InitVideo, SDL.InitEvents]
+
+createSdlWindow :: MonadIO io => Text -> Int -> Int -> io SDL.Window
+createSdlWindow title width height = SDL.createWindow title window
+  where
+    window =
+      SDL.defaultWindow
+        { SDL.windowInitialSize = SDL.V2 (fromIntegral width) (fromIntegral height),
+          SDL.windowGraphicsContext = SDL.VulkanContext
+        }
+
+getSdlWindowSurface :: MonadIO io => SDL.Window -> Instance -> io SurfaceKHR
+getSdlWindowSurface window inst =
+  SurfaceKHR
+    <$> SDL.vkCreateSurface window (castPtr $ instanceHandle inst)
+
+getSdlDrawableSize :: MonadIO io => SDL.Window -> io (V2 Int)
+getSdlDrawableSize window = do
+  (V2 width height) <- SDL.vkGetDrawableSize window
+  pure $ V2 (fromIntegral width) (fromIntegral height)
+
+getSdlWindowExtensions :: MonadIO io => SDL.Window -> io (Vector ByteString)
+getSdlWindowExtensions window =
+  SDL.vkGetInstanceExtensions window
+    >>= liftIO . mapM packCString . Vector.fromList
+
+pollSdlWindowEvents :: MonadIO io => io [Event]
+pollSdlWindowEvents = map fromSdlEvent <$> SDL.pollEvents
+
+fromSdlEvent :: SDL.Event -> Event
+fromSdlEvent (SDL.Event _ payload) = case payload of
+  SDL.QuitEvent -> QuitEvent
+  (SDL.WindowResizedEvent _) -> WindowResizedEvent
+  (SDL.WindowMovedEvent _) -> WindowMovedEvent
+  _ -> UnknownEvent

src/Graphics/Seangine/Window/Types.hs

@@ -0,0 +1,58 @@
+module Graphics.Seangine.Window.Types
+  ( Event (..),
+    Window (),
+    WindowSystem (..),
+  ) where
+
+import Data.Vector (Vector ())
+import Linear (V2 (..))
+import Vulkan.Core10 (Instance ())
+import Vulkan.Extensions.VK_KHR_surface (SurfaceKHR ())
+
+data Event
+  = QuitEvent
+  | WindowResizedEvent
+  | WindowMovedEvent
+  | UnknownEvent
+  deriving (Enum, Bounded, Eq, Show)
+
+type family Window w
+
+class WindowSystem system where
+  initWindowSystem :: MonadIO io => Proxy system -> io system
+  destroyWindowSystem :: MonadIO io => system -> io ()
+
+  createWindow
+    :: MonadIO io
+    => system
+    -> Text
+    -> Int
+    -> Int
+    -> io (Window system)
+
+  destroyWindow
+    :: MonadIO io
+    => system
+    -> Window system
+    -> io ()
+
+  getWindowSurface
+    :: MonadIO io
+    => system
+    -> Window system
+    -> Instance
+    -> io SurfaceKHR
+
+  getDrawableSize
+    :: MonadIO io
+    => system
+    -> Window system
+    -> io (V2 Int)
+
+  getWindowExtensions
+    :: MonadIO io
+    => system
+    -> Window system
+    -> io (Vector ByteString)
+
+  pollWindowEvents :: MonadIO io => system -> io [Event]