keid-core 0.1.7.2 → 0.1.8.0

raw patch · 51 files changed

+1969/−804 lines, 51 filesdep ~ktx-codecPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ktx-codec

API changes (from Hackage documentation)

Files

• ChangeLog.md +23/−0
• keid-core.cabal +10/−4
• src/Engine/Camera.hs +26/−6
• src/Engine/Camera/Controls.hs +13/−2
• src/Engine/Events.hs +10/−7
• src/Engine/Events/CursorPos.hs +14/−12
• src/Engine/Events/MouseButton.hs +11/−10
• src/Engine/Events/Sink.hs +20/−7
• src/Engine/Frame.hs +10/−1
• src/Engine/Render.hs +3/−2
• src/Engine/Setup.hs +10/−1
• src/Engine/Setup/Device.hs +3/−5
• src/Engine/SpirV/Compile.hs +2/−2
• src/Engine/SpirV/Reflect.hs +6/−4
• src/Engine/Types.hs +36/−6
• src/Engine/Types/Options.hs +73/−3
• src/Engine/Types/RefCounted.hs +8/−1
• src/Engine/UI/Layout.hs +19/−6
• src/Engine/Vulkan/Format.hs +130/−0
• src/Engine/Vulkan/Pipeline.hs +21/−9
• src/Engine/Vulkan/Pipeline/Compute.hs +32/−61
• src/Engine/Vulkan/Pipeline/External.hs +15/−11
• src/Engine/Vulkan/Pipeline/Graphics.hs +62/−74
• src/Engine/Vulkan/Shader.hs +15/−10
• src/Engine/Vulkan/Swapchain.hs +55/−31
• src/Engine/Vulkan/Types.hs +6/−3
• src/Engine/Window/CursorPos.hs +8/−4
• src/Engine/Window/Drop.hs +5/−4
• src/Engine/Window/Key.hs +5/−4
• src/Engine/Window/MouseButton.hs +9/−5
• src/Engine/Window/Scroll.hs +8/−4
• src/Engine/Worker.hs +34/−64
• src/Render/Code.hs +7/−3
• src/Render/Draw.hs +9/−9
• src/Render/Pass/Offscreen.hs +57/−58
• src/Render/Samplers.hs +51/−42
• src/Resource/Buffer.hs +128/−56
• src/Resource/CommandBuffer.hs +4/−2
• src/Resource/DescriptorSet.hs +0/−37
• src/Resource/Image.hs +223/−95
• src/Resource/Mesh/Codec.hs +10/−6
• src/Resource/Model.hs +133/−37
• src/Resource/Model/Observer.hs +211/−0
• src/Resource/Model/Observer/Example.hs +44/−0
• src/Resource/Source.hs +8/−1
• src/Resource/Texture.hs +33/−32
• src/Resource/Texture/Ktx1.hs +17/−63
• src/Resource/Texture/Ktx2.hs +183/−0
• src/Resource/Vulkan/DescriptorLayout.hs +47/−0
• src/Resource/Vulkan/DescriptorPool.hs +64/−0
• src/Resource/Vulkan/Named.hs +38/−0

@@ -1,5 +1,28 @@ # Changelog for keid-core +## 0.1.8.0++Massive ~~breakage~~ fixing around allocate/create/destroy patterns and naming things.++- Deleted `Resource.DescriptorSets`.+- Added `Resource.Vulkan.DescriptorPool`.+- Renamed `Engine.Vulkan.Types.DsBindings` to `DsLayoutBindings`.+- Added `allocate_` for `Engine.Vulkan.Pipeline.Graphics` and `Compute`.+- Added `size`, `withSize` and experimental `HasField` instance for `Resource.Texture`.+- Fixed SPIR-V signatures compatibility by hiding builtin interface vars.+- `Engine.Worker.spawn*` and `Engine.Events.*` handlers and now self-registereing.+- Due to `RunState`/`Sink RunState` loop callbacks now use a `MonadSink rs m` instead of `StageRIO rs`.+- Added `Resource.Texture.Ktx2`.+  * It lacks the BC7 hack to force sRGB for compressed textures as it is possible to set the correct format directly.+- Moved Base textures to KTX2 containers. KTX1 is soft-deprecated.+- Graphics pipelines now able to fill the config automatically with `Graphics.vertexInput` helper. Using:+  * `HasVertexInputBindings` class that provides attribute bindings.+  * `HasVkFormat` class to generate bindings parameters automatically (with generics) or explicitly.+  * `vertexFormat`, `instanceFormat` helpers for using `HasVkFormat` to provide `HasVertexInputBindings` instances.+- Added `Resource.Model.Observer` that wraps coherent buffers and is able to observe multi-buffered resources.+- Changed `Swapchain.setDynamicFullscreen` to accept a frame directly.+- Added `MonadReader` and `MonadState` instances for `Bound` to allow fetching models at draw call site.+ ## 0.1.7.2  - Added `--size` option to set the initial window size.

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.0.+-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack  name:           keid-core-version:        0.1.7.2+version:        0.1.8.0 synopsis:       Core parts of Keid engine. category:       Game Engine homepage:       https://keid.haskell-game.dev@@ -52,6 +52,7 @@       Engine.UI.Layout       Engine.UI.Layout.Linear       Engine.Vulkan.DescSets+      Engine.Vulkan.Format       Engine.Vulkan.Pipeline       Engine.Vulkan.Pipeline.Compute       Engine.Vulkan.Pipeline.External@@ -79,18 +80,23 @@       Resource.Combined.Textures       Resource.CommandBuffer       Resource.Compressed.Zstd-      Resource.DescriptorSet       Resource.Image       Resource.Image.Atlas       Resource.Mesh.Codec       Resource.Mesh.Types       Resource.Mesh.Utils       Resource.Model+      Resource.Model.Observer+      Resource.Model.Observer.Example       Resource.Region       Resource.Source       Resource.Static       Resource.Texture       Resource.Texture.Ktx1+      Resource.Texture.Ktx2+      Resource.Vulkan.DescriptorLayout+      Resource.Vulkan.DescriptorPool+      Resource.Vulkan.Named   other-modules:       Paths_keid_core   hs-source-dirs:@@ -167,7 +173,7 @@     , file-embed     , foldl     , geomancy-    , ktx-codec+    , ktx-codec >=0.0.2.0     , neat-interpolation     , optparse-applicative     , optparse-simple

@@ -32,6 +32,8 @@ import Geomancy.Vec3 qualified as Vec3 import Geomancy.Vulkan.Projection qualified as Projection import Geomancy.Vulkan.View qualified as View+import RIO.App (App)+import UnliftIO.Resource (MonadResource) import Vulkan.Core10 qualified as Vk import Vulkan.NamedType ((:::)) @@ -67,9 +69,13 @@   ProjectionParams 'Orthographic = ()  spawnProjection-  :: (Vk.Extent2D -> ProjectionInput pk -> Transform)+  :: ( MonadReader (App Engine.GlobalHandles st) m+     , MonadResource m+     , MonadUnliftIO m+     )+  => (Vk.Extent2D -> ProjectionInput pk -> Transform)   -> ProjectionParams pk-  -> Engine.StageRIO env (ProjectionProcess pk)+  -> m (ProjectionProcess pk) spawnProjection mkTransform params =   spawnProjectionWith mkTransform ProjectionInput     { projectionNear    = PROJECTION_NEAR@@ -84,9 +90,13 @@ pattern PROJECTION_FAR = 16384  spawnProjectionWith-  :: (Vk.Extent2D -> ProjectionInput pk -> Transform)+  :: ( MonadReader (App Engine.GlobalHandles st) m+     , MonadResource m+     , MonadUnliftIO m+     )+  => (Vk.Extent2D -> ProjectionInput pk -> Transform)   -> ProjectionInput pk-  -> Engine.StageRIO env (ProjectionProcess pk)+  -> m (ProjectionProcess pk) spawnProjectionWith mkTransform projectionInput = do   screen <- Engine.askScreenVar   input <- Worker.newVar projectionInput@@ -104,7 +114,12 @@       screen       input -spawnPerspective :: Engine.StageRIO env (ProjectionProcess 'Perspective)+spawnPerspective+  :: ( MonadReader (App Engine.GlobalHandles st) m+     , MonadResource m+     , MonadUnliftIO m+     )+  => m (ProjectionProcess 'Perspective) spawnPerspective = spawnProjection mkTransformPerspective (τ / 4)  mkTransformPerspective :: Vk.Extent2D -> ProjectionInput 'Perspective -> Transform@@ -116,7 +131,12 @@     width     height -spawnOrthoPixelsCentered :: Engine.StageRIO env (ProjectionProcess 'Orthographic)+spawnOrthoPixelsCentered+  :: ( MonadReader (App Engine.GlobalHandles st) m+     , MonadResource m+     , MonadUnliftIO m+     )+  => m (ProjectionProcess 'Orthographic) spawnOrthoPixelsCentered = spawnProjectionWith mkTransformOrthoPixelsCentered ProjectionInput   { projectionNear   = 0   , projectionFar    = 1

@@ -16,8 +16,14 @@ import Engine.Worker qualified as Worker import Geomancy (Vec3, vec3) import Geomancy.Quaternion qualified as Quaternion+import UnliftIO.Resource (MonadResource) -spawnViewOrbital :: Camera.ViewOrbitalInput -> RIO env Camera.ViewProcess+spawnViewOrbital+  :: ( MonadResource m+     , MonadUnliftIO m+     )+  => Camera.ViewOrbitalInput+  -> m Camera.ViewProcess spawnViewOrbital = Worker.spawnCell Camera.mkViewOrbital_  data Controls a = Controls@@ -30,7 +36,12 @@  type ControlsProcess = Controls (Worker.Timed Float ()) -spawnControls :: Camera.ViewProcess -> RIO env ControlsProcess+spawnControls+  :: ( MonadResource m+     , MonadUnliftIO m+     )+  => Camera.ViewProcess+  -> m ControlsProcess spawnControls vp =   traverse mkUpdater Controls     { panHorizontal   = panTargetHorizontal

@@ -6,17 +6,17 @@  import RIO -import UnliftIO.Resource (ReleaseKey)+import UnliftIO.Resource (MonadResource, ReleaseKey) import UnliftIO.Resource qualified as Resource -import Engine.Events.Sink (Sink)+import Engine.Events.Sink (MonadSink, Sink) import Engine.Events.Sink qualified as Sink-import Engine.Types (StageRIO)  spawn-  :: (event -> StageRIO st ())-  -> [Sink event st -> StageRIO st ReleaseKey]-  -> StageRIO st (ReleaseKey, Sink event st)+  :: MonadSink st m+  => (event -> m ())+  -> [Sink event st -> m ReleaseKey]+  -> m (ReleaseKey, Sink event st) spawn handleEvent sources = do   (sinkKey, sink) <- Sink.spawn handleEvent @@ -26,7 +26,10 @@    pure (key, sink) -registerMany :: [StageRIO st ReleaseKey] -> StageRIO st ReleaseKey+registerMany+  :: MonadResource m+  => [m ReleaseKey]+  -> m ReleaseKey registerMany actions =   sequenceA actions >>=     Resource.register . traverse_ Resource.release

@@ -4,33 +4,33 @@  import Geomancy (Vec2, vec2, pattern WithVec2) import GHC.Float (double2Float)-import UnliftIO.Resource (ReleaseKey)+import UnliftIO.Resource (MonadResource, ReleaseKey) import Vulkan.Core10 qualified as Vk import Vulkan.NamedType ((:::)) -import Engine.Types (StageRIO, askScreenVar)+import Engine.Events.Sink (MonadSink, Sink)+import Engine.Types (askScreenVar) import Engine.Window.CursorPos qualified as CursorPos import Engine.Worker qualified as Worker -import Engine.Events (Sink)- callback-  :: ( Worker.HasInput cursor+  :: ( MonadSink rs m+     , Worker.HasInput cursor      , Worker.GetInput cursor ~ Vec2      )   => cursor-  --------------------------  -> Sink e rs-  -> StageRIO rs ReleaseKey+  -> Sink e st+  -> m ReleaseKey callback cursorVar = CursorPos.callback . handler cursorVar  handler-  :: ( Worker.HasInput cursor+  :: ( MonadResource m+     , Worker.HasInput cursor      , Worker.GetInput cursor ~ Vec2      )   => cursor-  -> Sink e rs-  -> CursorPos.Callback rs+  -> Sink e st+  -> CursorPos.Callback m handler cursorVar _sink windowX windowY = do   -- logDebug $ "CursorPos event: " <> displayShow (windowX, windowY)   Worker.pushInput cursorVar \_old ->@@ -38,7 +38,9 @@  type Process = Worker.Cell ("window" ::: Vec2) ("centered" ::: Vec2) -spawn :: StageRIO env Process+spawn+  :: MonadSink rs m+  => m Process spawn = do   screen <- askScreenVar   cursorWindow <- Worker.newVar 0

@@ -9,38 +9,39 @@ import Geomancy (Vec2) import UnliftIO.Resource (ReleaseKey) -import Engine.Events.Sink (Sink)-import Engine.Types (StageRIO)+import Engine.Events.Sink (MonadSink, Sink) import Engine.Window.MouseButton (ModifierKeys, MouseButton, MouseButtonState) import Engine.Window.MouseButton qualified as MouseButton import Engine.Worker qualified as Worker -type ClickHandler e st =+type ClickHandler e st m =   Sink e st ->   Vec2 ->   (ModifierKeys, MouseButtonState, MouseButton) ->-  StageRIO st ()+  m ()  callback-  :: ( Worker.HasOutput cursor+  :: ( MonadSink rs m+     , Worker.HasOutput cursor      , Worker.GetOutput cursor ~ Vec2      )   => cursor-  -> ClickHandler e st+  -> ClickHandler e st m   -------------------------   -> Sink e st-  -> StageRIO st ReleaseKey+  -> m ReleaseKey callback cursorP eventHandler = MouseButton.callback . handler cursorP eventHandler  handler-  :: ( Worker.HasOutput cursor+  :: ( MonadSink rs m+     , Worker.HasOutput cursor      , Worker.GetOutput cursor ~ Vec2      )   => cursor-  -> ClickHandler e st+  -> ClickHandler e st m   -> Sink e st   -> (ModifierKeys, MouseButtonState, MouseButton)-  -> StageRIO st ()+  -> m () handler cursorP eventHandler sink buttonEvent = do   cursorPos <- Worker.getOutputData cursorP   logDebug $ "MouseButton event: " <> displayShow (cursorPos, buttonEvent)

@@ -1,28 +1,41 @@ module Engine.Events.Sink   ( Sink(..)   , spawn++  , MonadSink   ) where  import RIO  import Control.Concurrent.Chan.Unagi qualified as Unagi import Control.Exception (AsyncException(ThreadKilled))+import Engine.Types (GlobalHandles)+import RIO.App (App)+import RIO.State (MonadState) import UnliftIO.Concurrent (forkFinally, killThread)-import UnliftIO.Resource (ReleaseKey)+import UnliftIO.Resource (ReleaseKey, MonadResource) import UnliftIO.Resource qualified as Resource -import Engine.Types (StageRIO)+-- | A collection of properties that are available while handling events.+-- Has access to a stage @RunState@, but not @Frame@ data.+type MonadSink rs m =+  ( MonadReader (App GlobalHandles rs) m+  , MonadState rs m+  , MonadResource m+  , MonadUnliftIO m+  ) -newtype Sink event st = Sink-  { signal :: event -> StageRIO st ()+newtype Sink event rs = Sink+  { signal :: forall m . MonadSink rs m => event -> m ()   }  spawn-  :: (event -> StageRIO rs ())-  -> StageRIO rs (ReleaseKey, Sink event rs)+  :: MonadSink rs m+  => (event -> m ())+  -> m (ReleaseKey, Sink event rs) spawn handleEvent = do   (eventsIn, eventsOut) <- liftIO Unagi.newChan-  let sink = Sink \event -> liftIO (Unagi.writeChan eventsIn event)+  let sink = Sink $ liftIO . Unagi.writeChan eventsIn    let     handler = forever $

@@ -29,6 +29,7 @@ import Engine.DataRecycler (DumpResource, WaitResource) import Engine.Setup.Window qualified as Window import Engine.Types (GlobalHandles(..), StageRIO, Stage(..), Frame(..), GPUWork, RecycledResources(..))+import Engine.Types.Options (optionsPresent, optionsMsaa) import Engine.Types.RefCounted (newRefCounted) import Engine.Vulkan.Swapchain (SwapchainResources(..), SwapchainInfo(..), allocSwapchainResources, recreateSwapchainResources) import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, RenderPass(..), Queues)@@ -44,11 +45,17 @@   GlobalHandles{..} <- asks appEnv   let device = ghDevice +  let+    fPresent = optionsPresent ghOptions+    fMSAA = optionsMsaa ghOptions+   sfSwapchainResources <- case oldSR of     Nothing -> do       windowSize <- liftIO $ Window.getExtent2D ghWindow       let oldSwapchain = Vk.NULL_HANDLE       allocSwapchainResources+        fPresent+        fMSAA         oldSwapchain         windowSize         ghSurface@@ -168,6 +175,8 @@     , fPipelines                   = fPipelines f     , fRenderFinishedHostSemaphore = fRenderFinishedHostSemaphore f     , fStageResources              = fStageResources f+    , fPresent                     = fPresent f+    , fMSAA                        = fMSAA f     , fSwapchainResources     , fRenderpass     , fGPUWork@@ -178,7 +187,7 @@     getNext Frame{..} = do       if needsNewSwapchain then do         windowSize <- liftIO $ Window.getExtent2D fWindow-        newResources <- recreateSwapchainResources windowSize fSwapchainResources+        newResources <- recreateSwapchainResources fPresent fMSAA windowSize fSwapchainResources          let           formatMatch =

@@ -7,6 +7,7 @@  import Control.Monad.Trans.Resource qualified as Resource import Vulkan.Core10 qualified as Vk+import Vulkan.Core10.CommandBuffer qualified as CommandBuffer import Vulkan.Core12.Promoted_From_VK_KHR_timeline_semaphore qualified as Vk12 import Vulkan.CStruct.Extends (SomeStruct(..), pattern (:&), pattern (::&)) import Vulkan.Extensions.VK_KHR_swapchain qualified as Khr@@ -65,8 +66,8 @@        let         commandBufferBI = zero-          { Vk.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT-          } :: Vk.CommandBufferBeginInfo '[]+          { CommandBuffer.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT+          }       Vk.useCommandBuffer commandBuffer commandBufferBI $         recordCommandBuffer commandBuffer stageRecycled imageIndex 

@@ -15,6 +15,7 @@ import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..)) import Vulkan.Zero (zero) import VulkanMemoryAllocator qualified as VMA+import Vulkan.Core12 (pattern API_VERSION_1_2)  #if MIN_VERSION_vulkan(3,15,0) import Foreign.Ptr (castFunPtr)@@ -47,10 +48,18 @@     "Keid Engine"    logDebug "Creating instance"+  let+    appInfo = Vk.ApplicationInfo+      { apiVersion = API_VERSION_1_2+      , applicationName = Nothing+      , applicationVersion = 0+      , engineName = Nothing+      , engineVersion = 0+      }   ghInstance <- createInstanceFromRequirements     (deviceProps : debugUtils : windowReqs)     mempty-    zero+    (zero { Vk.applicationInfo = Just appInfo })    logDebug "Creating surface"   (_surfaceKey, ghSurface) <- Window.allocateSurface ghWindow ghInstance

@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedRecordDot #-}+ -- | Physical device tools  module Engine.Setup.Device where@@ -122,9 +124,7 @@   pdiTotalMemory <- do     props <- Vk.getPhysicalDeviceMemoryProperties phys     pure . sum $-      fmap-        (Vk.size :: Vk.MemoryHeap -> Vk.DeviceSize)-        (Vk.memoryHeaps props)+      fmap (.size) (Vk.memoryHeaps props)    pdiProperties <- Vk.getPhysicalDeviceProperties phys @@ -185,8 +185,6 @@   hasFeat <- getPhysicalDeviceFeatures2KHR phys >>= \case     _ ::& (PhysicalDeviceTimelineSemaphoreFeatures hasTimelineSemaphores :& ()) ->       pure hasTimelineSemaphores-    _ ->-      pure False    pure $ hasExt && hasFeat 

@@ -13,7 +13,7 @@ import RIO.Process (HasProcessContext, proc, readProcess_) import RIO.Text qualified as Text -import Render.Code (Code(..))+import Render.Code (Code(..), targetEnv) import Engine.Vulkan.Pipeline.Stages qualified as Stages  glsl@@ -44,7 +44,7 @@       ByteString.writeFile shaderFile outBytes       (_out, _err) <- proc         "glslangValidator"-        [ "--target-env", "vulkan1.2"+        [ "--target-env", targetEnv         , "-S", Text.unpack stage         , "-V", shaderFile         , "-o", outFile

@@ -216,12 +216,11 @@   deriving (Eq, Ord, Show)  stagesInterfaceMap-  :: ( MonadIO m-     , Traversable stages+  :: ( Traversable stages      )   => stages (Maybe Module)-  -> m (StageInterface stages)-stagesInterfaceMap = traverse $ traverse (pure . moduleInterfaceBinds)+  -> StageInterface stages+stagesInterfaceMap = fmap (fmap moduleInterfaceBinds)  moduleInterfaceBinds :: Module -> (InterfaceBinds, InterfaceBinds) moduleInterfaceBinds refl =@@ -233,6 +232,9 @@ interfaceBinds cls vars = IntMap.fromList do   var@InterfaceVariable.InterfaceVariable{location} <- toList vars   guard $ InterfaceVariable.storage_class var == cls++  -- XXX: Remove vars like @gl_FragCoord@/@SV_Position@ from potential signatures.+  guard $ InterfaceVariable.built_in var == maxBound    let     td = InterfaceVariable.type_description var

@@ -4,6 +4,7 @@  import Control.Monad.Trans.Resource (ResourceT) import Control.Monad.Trans.Resource qualified as ResourceT+import Data.Kind (Type) import Graphics.UI.GLFW qualified as GLFW import RIO.App (App, appEnv, appState) import RIO.Lens (_1)@@ -15,12 +16,12 @@ import VulkanMemoryAllocator qualified as VMA  import Engine.Setup.Window (Window)+import Engine.Types.Options (Options) import Engine.Types.RefCounted (RefCounted) import Engine.Vulkan.Swapchain (SwapchainResources(..))-import Engine.Vulkan.Types (HasVulkan(..))+import Engine.Vulkan.Types (HasVulkan(..), HasSwapchain(..)) import Engine.Vulkan.Types qualified as Vulkan import Engine.Worker qualified as Worker-import Engine.Types.Options (Options)  -- * App globals @@ -39,7 +40,10 @@   , ghStageSwitch        :: StageSwitchVar   } -askScreenVar :: StageRIO env (Worker.Var Vk.Extent2D)+{-# INLINE askScreenVar #-}+askScreenVar+  :: MonadReader (App GlobalHandles st) m+  => m (Worker.Var Vk.Extent2D) askScreenVar = asks $ ghScreenVar . appEnv  instance HasVulkan GlobalHandles where@@ -118,10 +122,13 @@  -- | All the information required to render a single frame data Frame renderpass pipelines resources = Frame-  { fIndex                       :: Word64 -- ^ Which number frame is this-  , fWindow                      :: Window-  , fSurface                     :: Khr.SurfaceKHR+  { fIndex   :: Word64 -- ^ Which number frame is this+  , fWindow  :: Window+  , fSurface :: Khr.SurfaceKHR +  , fPresent :: Maybe Khr.PresentModeKHR+  , fMSAA    :: Vk.SampleCountFlagBits+   , fSwapchainResources          :: SwapchainResources   , fRenderpass                  :: renderpass   , fPipelines                   :: pipelines@@ -154,6 +161,24 @@     -}   } +instance HasSwapchain (Frame renderpass pipelines resources) where+  getSurfaceExtent  = getSurfaceExtent . fSwapchainResources+  getSurfaceFormat  = getSurfaceFormat . fSwapchainResources+  getDepthFormat    = getDepthFormat . fSwapchainResources+  getMultisample    = getMultisample . fSwapchainResources+  getAnisotropy     = getAnisotropy . fSwapchainResources+  getSwapchainViews = getSwapchainViews . fSwapchainResources+  getMinImageCount  = getMinImageCount . fSwapchainResources+  getImageCount     = getImageCount . fSwapchainResources+  {-# INLINE getSurfaceExtent #-}+  {-# INLINE getSurfaceFormat #-}+  {-# INLINE getDepthFormat #-}+  {-# INLINE getMultisample #-}+  {-# INLINE getAnisotropy #-}+  {-# INLINE getSwapchainViews #-}+  {-# INLINE getMinImageCount #-}+  {-# INLINE getImageCount #-}+ type GPUWork =   ( "host semaphore" ::: Vk.Semaphore   , "frame index" ::: Word64@@ -184,3 +209,8 @@   liftResourceT rt =     asks (snd . fResources . snd) >>=       liftIO . ResourceT.runInternalState rt++type HKD :: (Type -> Type) -> Type -> Type+type family HKD f a where+  HKD Identity a = a+  HKD f a = f a

@@ -7,6 +7,8 @@ import RIO  import Options.Applicative.Simple qualified as Opt+import Vulkan.Core10 qualified as Vk+import Vulkan.Extensions.VK_KHR_surface qualified as Khr  import Paths_keid_core qualified @@ -14,6 +16,8 @@ data Options = Options   { optionsVerbose      :: Bool   , optionsMaxFPS       :: Maybe Int+  , optionsPresent      :: Maybe Khr.PresentModeKHR+  , optionsMsaa         :: Vk.SampleCountFlagBits   , optionsFullscreen   :: Bool   , optionsDisplay      :: Natural   , optionsSize         :: Maybe (Int, Int)@@ -51,6 +55,17 @@     , Opt.metavar "FPS"     ] +  optionsPresent <- Opt.optional . Opt.option readPresent $ mconcat+    [ Opt.long "present"+    , Opt.help "Presentation mode"+    ]++  optionsMsaa <- Opt.option readMsaa $ mconcat+    [ Opt.long "msaa"+    , Opt.help "MSAA level"+    , Opt.value Vk.SAMPLE_COUNT_4_BIT+    ]+   optionsFullscreen <- Opt.switch $ mconcat     [ Opt.long "fullscreen"     , Opt.short 'f'@@ -76,10 +91,65 @@    pure Options{..} +readPresent :: Opt.ReadM Khr.PresentModeKHR+readPresent = named <|> integral <|> Opt.readerError oops+  where+    named = do+      o <- Opt.str+      case lookup o presentModes of+        Just found ->+          pure found+        Nothing ->+          Opt.readerError $ "unexpected mode name: " <> show o++    integral =+      fmap Khr.PresentModeKHR Opt.auto++    oops = unlines+      [ "Available present modes (or use a number): "+      , show $ map fst presentModes+      ]++presentModes :: [(Text, Khr.PresentModeKHR)]+presentModes =+  [ ("immediate", Khr.PRESENT_MODE_IMMEDIATE_KHR)+  , ("mailbox", Khr.PRESENT_MODE_MAILBOX_KHR)+  , ("fifo", Khr.PRESENT_MODE_FIFO_KHR)+  , ("fifo_relaxed", Khr.PRESENT_MODE_FIFO_RELAXED_KHR)+  , ("shared_demand_refresh", Khr.PRESENT_MODE_SHARED_DEMAND_REFRESH_KHR)+  , ("shared_continuous_refresh", Khr.PRESENT_MODE_SHARED_CONTINUOUS_REFRESH_KHR)+  ]++readMsaa :: Opt.ReadM Vk.SampleCountFlagBits+readMsaa = do+  samples <- Opt.auto+  case lookup samples msaaSamples of+    Just found ->+      pure found+    Nothing ->+      Opt.readerError $ mconcat+        [ "Unexpected MSAA sample count: "+        , show samples+        , " (must be a power of 2 in [1..64] range)"+        ]++msaaSamples :: [(Int, Vk.SampleCountFlagBits)]+msaaSamples =+  [ ( 1, Vk.SAMPLE_COUNT_1_BIT)+  , ( 2, Vk.SAMPLE_COUNT_2_BIT)+  , ( 4, Vk.SAMPLE_COUNT_4_BIT)+  , ( 8, Vk.SAMPLE_COUNT_8_BIT)+  , ( 16, Vk.SAMPLE_COUNT_16_BIT)+  , ( 32, Vk.SAMPLE_COUNT_32_BIT)+  , ( 64, Vk.SAMPLE_COUNT_64_BIT)+  ]+ readSize :: Opt.ReadM (Int, Int) readSize = do   o <- Opt.str-  let (w,h) = break (== 'x') o+  let (w, h) = break (== 'x') o   case (readMaybe w, readMaybe (drop 1 h)) of-    (Just w', Just h') -> pure (w', h')-    _ -> fail "Can't read window size"+    (Just w', Just h') ->+      pure (w', h')+    _ ->+      fail "Can't read window size"

@@ -4,7 +4,8 @@  import Control.Monad.Trans.Resource (allocate_) import GHC.IO.Exception (IOErrorType(UserError), IOException(IOError))-import UnliftIO.Resource (MonadResource)+import UnliftIO.Resource (MonadResource, ReleaseKey)+import UnliftIO.Resource qualified as Resource  -- | A 'RefCounted' will perform the specified action when the count reaches 0 data RefCounted = RefCounted@@ -48,3 +49,9 @@ resourceTRefCount :: MonadResource f => RefCounted -> f () resourceTRefCount r =   void $ allocate_ (takeRefCounted r) (releaseRefCounted r)++wrapped :: MonadResource m => m (ReleaseKey, a) -> m (RefCounted, a)+wrapped action = do+  (key, res) <- action+  rc <- newRefCounted $ Resource.release key+  pure (rc, res)

@@ -42,6 +42,8 @@ import Geomancy (Transform, Vec2, Vec4, vec2, vec4, withVec2, pattern WithVec2, pattern WithVec4) import Geomancy.Transform qualified as Transform import Geomancy.Vec4 qualified as Vec4+import RIO.App (App)+import UnliftIO.Resource (MonadResource) import Vulkan.Core10 qualified as Vk import Vulkan.NamedType ((:::)) @@ -94,7 +96,12 @@  type BoxProcess = Worker.Merge Box -trackScreen :: Engine.StageRIO st BoxProcess+trackScreen+  :: ( MonadReader (App Engine.GlobalHandles st) m+     , MonadResource m+     , MonadUnliftIO m+     )+  => m BoxProcess trackScreen = do   screen <- Engine.askScreenVar   Worker.spawnMerge1 mkBox screen@@ -105,7 +112,8 @@       }  padAbs-  :: ( MonadUnliftIO m+  :: ( MonadResource m+     , MonadUnliftIO m      , Worker.HasOutput parent      , Worker.GetOutput parent ~ Box      , Worker.HasOutput padding@@ -130,7 +138,8 @@     dh = min h (top + bottom)  padRel-  :: ( MonadUnliftIO m+  :: ( MonadResource m+     , MonadUnliftIO m      , Worker.HasOutput parent      , Worker.GetOutput parent ~ Box      , Worker.HasOutput padding@@ -147,7 +156,8 @@   boxPadAbs box (pad * vec4 h w h w)  fitPlaceAbs-  :: ( MonadUnliftIO m+  :: ( MonadResource m+     , MonadUnliftIO m      , Worker.HasOutput parent      , Worker.GetOutput parent ~ Box      )@@ -210,7 +220,8 @@         aspect = w / h  splitsRelStatic-  :: ( MonadUnliftIO m+  :: ( MonadResource m+     , MonadUnliftIO m      , Worker.HasOutput parent      , Worker.GetOutput parent ~ Box      , Traversable t -- XXX: nested traversables may behave suprisingly@@ -243,7 +254,8 @@       )  hSplitRel-  :: ( MonadUnliftIO m+  :: ( MonadResource m+     , MonadUnliftIO m      , Worker.HasOutput parent      , Worker.GetOutput parent ~ Box      , Worker.HasOutput proportion@@ -274,6 +286,7 @@  vSplitRel   :: ( MonadUnliftIO m+     , MonadResource m      , Worker.HasOutput parent      , Worker.GetOutput parent ~ Box      , Worker.HasOutput proportion

@@ -0,0 +1,130 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Engine.Vulkan.Format+  ( HasVkFormat(..)+  , genericVkFormat++  , formatSize+  ) where++import RIO+import GHC.Generics+import Geomancy++import Data.Kind (Constraint, Type)+import Geomancy.IVec3 qualified as IVec3+import Geomancy.UVec3 qualified as UVec3+import Geomancy.Vec3 qualified as Vec3+import Vulkan.Core10 qualified as Vk++class HasVkFormat a where+  getVkFormat :: [Vk.Format]++  default getVkFormat+    :: GVkFormat (Rep a)+    => [Vk.Format]+  getVkFormat = genericVkFormat @a++instance HasVkFormat () where+  getVkFormat = []++instance HasVkFormat Float where+  getVkFormat = [Vk.FORMAT_R32_SFLOAT]++instance HasVkFormat Vec2 where+  getVkFormat = [Vk.FORMAT_R32G32_SFLOAT]++instance HasVkFormat Vec3 where+  getVkFormat = [Vk.FORMAT_R32G32B32A32_SFLOAT]++instance HasVkFormat Vec3.Packed where+  getVkFormat = [Vk.FORMAT_R32G32B32_SFLOAT]++instance HasVkFormat Vec4 where+  getVkFormat = [Vk.FORMAT_R32G32B32A32_SFLOAT]++instance HasVkFormat Quaternion where+  getVkFormat = [Vk.FORMAT_R32G32B32A32_SFLOAT]++instance HasVkFormat Mat4 where+  getVkFormat =+    [ Vk.FORMAT_R32G32B32A32_SFLOAT+    , Vk.FORMAT_R32G32B32A32_SFLOAT+    , Vk.FORMAT_R32G32B32A32_SFLOAT+    , Vk.FORMAT_R32G32B32A32_SFLOAT+    ]++instance HasVkFormat Transform where+  getVkFormat = getVkFormat @Mat4++instance HasVkFormat Int32 where+  getVkFormat = [Vk.FORMAT_R32_SINT]++instance HasVkFormat IVec2 where+  getVkFormat = [Vk.FORMAT_R32G32_SINT]++instance HasVkFormat IVec3 where+  getVkFormat = [Vk.FORMAT_R32G32B32_SINT]++instance HasVkFormat IVec3.Packed where+  getVkFormat = [Vk.FORMAT_R32G32B32_SINT]++instance HasVkFormat IVec4 where+  getVkFormat = [Vk.FORMAT_R32G32B32A32_SINT]++instance HasVkFormat Word32 where+  getVkFormat = [Vk.FORMAT_R32_UINT]++instance HasVkFormat UVec2 where+  getVkFormat = [Vk.FORMAT_R32G32_UINT]++instance HasVkFormat UVec3 where+  getVkFormat = [Vk.FORMAT_R32G32B32A32_UINT]++instance HasVkFormat UVec3.Packed where+  getVkFormat = [Vk.FORMAT_R32G32B32_UINT]++instance HasVkFormat UVec4 where+  getVkFormat = [Vk.FORMAT_R32G32B32A32_UINT]++instance HasVkFormat v => HasVkFormat (Point v) where+  getVkFormat = getVkFormat @v++genericVkFormat+  :: forall a+  .  GVkFormat (Rep a)+  => [Vk.Format]+genericVkFormat = gVkFormat (Proxy @(Rep a))++type GVkFormat :: (Type -> Type) -> Constraint+class GVkFormat f where+  gVkFormat :: proxy f -> [Vk.Format]++instance GVkFormat f => GVkFormat (M1 c cb f) where+  gVkFormat _m1 = gVkFormat (Proxy @f)++instance (GVkFormat l, GVkFormat r) => GVkFormat (l :*: r) where+  gVkFormat _lr = gVkFormat (Proxy @l) <> gVkFormat (Proxy @r)++instance HasVkFormat a => GVkFormat (K1 r a) where+  gVkFormat _k1 = getVkFormat @a++formatSize :: Integral a => Vk.Format -> a+formatSize = \case+  Vk.FORMAT_R32G32B32A32_SFLOAT -> 16+  Vk.FORMAT_R32G32B32_SFLOAT    -> 12+  Vk.FORMAT_R32G32_SFLOAT       -> 8+  Vk.FORMAT_R32_SFLOAT          -> 4++  Vk.FORMAT_R32G32B32A32_UINT -> 16+  Vk.FORMAT_R32G32B32_UINT    -> 12+  Vk.FORMAT_R32G32_UINT       -> 8+  Vk.FORMAT_R32_UINT          -> 4++  Vk.FORMAT_R32G32B32A32_SINT -> 16+  Vk.FORMAT_R32G32B32_SINT    -> 12+  Vk.FORMAT_R32G32_SINT       -> 8+  Vk.FORMAT_R32_SINT          -> 4++  format ->+    error $ "Format size unknown: " <> show format

@@ -1,6 +1,6 @@ module Engine.Vulkan.Pipeline   ( Pipeline(..)-  , destroy+  , allocateWith   , Specialization   ) where @@ -9,9 +9,11 @@ import Data.Kind (Type) import Data.Tagged (Tagged(..)) import Data.Vector qualified as Vector+import GHC.Stack (withFrozenCallStack)+import UnliftIO.Resource qualified as Resource import Vulkan.Core10 qualified as Vk -import Engine.Vulkan.Types (HasVulkan(..), DsLayouts)+import Engine.Vulkan.Types (DsLayouts, MonadVulkan, getDevice)  data Pipeline (dsl :: [Type]) vertices instances = Pipeline   { pipeline     :: Vk.Pipeline@@ -19,19 +21,29 @@   , pDescLayouts :: Tagged dsl DsLayouts   } -destroy-  :: ( MonadIO io-     , HasVulkan ctx+allocateWith+  :: ( MonadVulkan env m+     , Resource.MonadResource m      )-  => ctx+  => m (Pipeline dsl vertices instances)+  -> m (Resource.ReleaseKey, Pipeline dsl vertices instances)+allocateWith action = withFrozenCallStack do+  res <- action+  device <- asks getDevice+  key <- Resource.register $+    destroy device res+  pure (key, res)++destroy+  :: MonadIO io+  => Vk.Device   -> Pipeline dsl vertices instances   -> io ()-destroy context Pipeline{..} = do+destroy device Pipeline{..} = do+  -- FIXME: leave layout alone   Vector.forM_ (unTagged pDescLayouts) \dsLayout ->     Vk.destroyDescriptorSetLayout device dsLayout Nothing   Vk.destroyPipeline device pipeline Nothing   Vk.destroyPipelineLayout device (unTagged pLayout) Nothing-  where-    device = getDevice context  type family Specialization pipeline

@@ -17,7 +17,6 @@   , Pipeline(..)   , allocate   , create-  , destroy    , bind   , Compute@@ -26,31 +25,30 @@ import RIO  import Data.Kind (Type)-import Data.List qualified as List import Data.Tagged (Tagged(..)) import Data.Vector qualified as Vector import GHC.Generics (Generic1)-import GHC.Stack (callStack, getCallStack, srcLocModule, withFrozenCallStack)+import GHC.Stack (withFrozenCallStack) import UnliftIO.Resource (MonadResource, ReleaseKey)-import UnliftIO.Resource qualified as Resource import Vulkan.Core10 qualified as Vk-import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing qualified as Vk12-import Vulkan.CStruct.Extends (SomeStruct(..), pattern (:&), pattern (::&))-import Vulkan.Utils.Debug qualified as Debug+import Vulkan.CStruct.Extends (SomeStruct(..)) import Vulkan.Zero (Zero(..))  import Engine.SpirV.Reflect (Reflect) import Engine.Vulkan.DescSets (Bound(..), Compatible)-import Engine.Vulkan.Pipeline (Pipeline(..), destroy)+import Engine.Vulkan.Pipeline (Pipeline(..))+import Engine.Vulkan.Pipeline qualified as Pipeline import Engine.Vulkan.Pipeline.Stages (StageInfo(..)) import Engine.Vulkan.Shader qualified as Shader-import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, DsBindings, getPipelineCache)+import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, DsLayoutBindings, getPipelineCache) import Render.Code (Code) import Resource.Collection (Generically1(..))+import Resource.Vulkan.DescriptorLayout qualified as Layout+import Resource.Vulkan.Named qualified as Named  data Config (dsl :: [Type]) spec = Config   { cComputeCode        :: ByteString-  , cDescLayouts        :: Tagged dsl [DsBindings]+  , cDescLayouts        :: Tagged dsl [DsLayoutBindings]   , cPushConstantRanges :: Vector Vk.PushConstantRange   , cSpecialization     :: spec   }@@ -87,66 +85,46 @@      )   => Config dsl spec   -> m (ReleaseKey, Pipeline dsl Compute Compute)-allocate config = withFrozenCallStack do-  ctx <- ask-  Resource.allocate-    (create ctx config)-    (destroy ctx)+allocate config =+  withFrozenCallStack $+    Pipeline.allocateWith $ create config  create-  :: ( HasVulkan ctx-     , MonadUnliftIO m+  :: ( MonadVulkan env io      , Shader.Specialization spec+     , HasCallStack      )-  => ctx-  -> Config dsl spec-  -> m (Pipeline dsl Compute Compute)-create context Config{..} = do-  -- XXX: copypasta from Pipeline.create-  let-    originModule =-      fromString . List.intercalate "|" $-        map (srcLocModule . snd) (getCallStack callStack)--  dsLayouts <- Vector.forM (Vector.fromList $ unTagged cDescLayouts) \bindsFlags -> do-    let-      (binds, flags) = List.unzip bindsFlags--      setCI =-        zero-          { Vk.bindings = Vector.fromList binds-          }-        ::& zero-          { Vk12.bindingFlags = Vector.fromList flags-          }-        :& ()--    Vk.createDescriptorSetLayout device setCI Nothing--  -- TODO: get from outside-  layout <- Vk.createPipelineLayout device (layoutCI dsLayouts) Nothing-  Debug.nameObject device layout originModule+  => Config dsl spec+  -> io (Pipeline dsl Compute Compute)+create Config{..} = withFrozenCallStack do+  -- TODO: get from outside ?+  dsLayouts <- Layout.create $ Vector.fromList (unTagged cDescLayouts) -  -- Compute stuff begins...+  -- TODO: get from outside ??+  pipelineLayout <- Layout.forPipeline+    dsLayouts+    cPushConstantRanges+  Named.objectOrigin pipelineLayout    shader <- Shader.withSpecialization cSpecialization $-    Shader.create context Stages+    Shader.create Stages       { comp = Just cComputeCode       }    let     cis = Vector.singleton . SomeStruct $-      pipelineCI (Shader.sPipelineStages shader) layout+      pipelineCI (Shader.sPipelineStages shader) pipelineLayout +  device <- asks getDevice   Vk.createComputePipelines device cache cis Nothing >>= \case     (Vk.SUCCESS, pipelines) ->       case pipelines of-        [one] -> do-          Shader.destroy context shader-          Debug.nameObject device one originModule+        [pipeline] -> do+          Shader.destroy shader+          Named.objectOrigin pipeline           pure Pipeline-            { pipeline     = one-            , pLayout      = Tagged layout+            { pipeline     = pipeline+            , pLayout      = Tagged pipelineLayout             , pDescLayouts = Tagged dsLayouts             }         _ ->@@ -155,14 +133,7 @@       throwString $ "createComputePipelines: " <> show err    where-    device = getDevice context-    cache = getPipelineCache context--    layoutCI dsLayouts = Vk.PipelineLayoutCreateInfo-      { flags              = zero-      , setLayouts         = dsLayouts-      , pushConstantRanges = cPushConstantRanges-      }+    cache = getPipelineCache undefined      pipelineCI stages layout = zero       { Vk.layout             = layout

@@ -28,15 +28,17 @@  import RIO -import Control.Monad.Trans.Resource (ReleaseKey, ResourceT, release)+import Control.Monad.Trans.Resource (ResourceT) import Data.List (maximum) import Data.Tagged (Tagged(..)) import RIO.ByteString qualified as ByteString import RIO.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist)+import RIO.FilePath ((</>), (<.>)) import RIO.Map qualified as Map import RIO.Text qualified as Text import RIO.Time (UTCTime, getCurrentTime)-import RIO.FilePath ((</>), (<.>))+import UnliftIO.Resource (MonadResource, ReleaseKey)+import UnliftIO.Resource qualified as Resource import Vulkan.Core10 qualified as Vk  import Render.Code (Code(..))@@ -47,16 +49,17 @@ import Engine.Vulkan.Pipeline.Graphics qualified as Graphics import Engine.Vulkan.Pipeline.Stages (StageInfo(..)) import Engine.Vulkan.Shader qualified as Shader-import Engine.Vulkan.Types (DsBindings, HasRenderPass)+import Engine.Vulkan.Types (DsLayoutBindings, HasRenderPass) import Engine.Worker qualified as Worker  type Process config = Worker.Timed () config  spawn   :: ( Foldable stages-     , MonadUnliftIO m      , MonadReader env m      , HasLogFunc env+     , MonadResource m+     , MonadUnliftIO m      )   => (stages (Maybe FilePath) -> m stuff)   -> Text@@ -95,7 +98,8 @@                 )  spawnReflect-  :: ( MonadUnliftIO m+  :: ( MonadResource m+     , MonadUnliftIO m      , MonadReader env m      , HasLogFunc env      , StageInfo stages@@ -149,7 +153,7 @@    reflDS <- Reflect.stagesBindMap stageRefl -  reflIS <- Reflect.stagesInterfaceMap stageRefl+  let reflIS = Reflect.stagesInterfaceMap stageRefl   case Reflect.interfaceCompatible reflIS of     Right ok ->       logDebug $ displayShow ok@@ -221,14 +225,14 @@      )   => renderpass   -> Vk.SampleCountFlagBits-  -> Tagged dsl [DsBindings]+  -> Tagged dsl [DsLayoutBindings]   -> output   -> Worker.ObserverIO (ReleaseKey, pipeline)   -> StageFrameRIO rp p fr rs () observeGraphics rp msaa sceneBinds configP output =   void $! Worker.observeIO configP output \(oldKey, _old) config -> do     logDebug "Rebuilding pipeline"-    release oldKey+    Resource.release oldKey     mapRIO fst $ Graphics.allocate       Nothing       msaa@@ -258,14 +262,14 @@      , config ~ Compute.Configure pipeline spec      , pipeline ~ Compute.Pipeline dsl Compute Compute      )-  => Tagged dsl [DsBindings]+  => Tagged dsl [DsLayoutBindings]   -> output   -> Worker.ObserverIO (ReleaseKey, pipeline)   -> StageFrameRIO rp p fr rs () observeCompute binds configP output =   void $! Worker.observeIO configP output \(oldKey, _old) config -> do     logDebug "Rebuilding pipeline"-    release oldKey+    Resource.release oldKey     mapRIO fst $ Compute.allocate config       { Compute.cDescLayouts = binds       }@@ -297,7 +301,7 @@       )   => renderpass   -> Vk.SampleCountFlagBits-  -> Tagged dsl DsBindings+  -> Tagged dsl DsLayoutBindings   -> pf ConfigureGraphics   -> pf Observers   -> (forall a . pf a -> a ^ p)

@@ -1,3 +1,4 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE UndecidableInstances #-} @@ -27,38 +28,42 @@   , Pipeline(..)   , allocate   , create-  , Pipeline.destroy    , bind++  , HasVertexInputBindings(..)+  , vertexFormat+  , instanceFormat   ) where  import RIO+import GHC.Generics  import Data.Bits ((.|.)) import Data.Kind (Type) import Data.List qualified as List import Data.Tagged (Tagged(..)) import Data.Vector qualified as Vector-import GHC.Generics (Generic1)-import GHC.Stack (callStack, getCallStack, srcLocModule, withFrozenCallStack)+import Geomancy (Transform)+import GHC.Stack (withFrozenCallStack) import UnliftIO.Resource (MonadResource, ReleaseKey)-import UnliftIO.Resource qualified as Resource import Vulkan.Core10 qualified as Vk-import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing qualified as Vk12-import Vulkan.CStruct.Extends (SomeStruct(..), pattern (:&), pattern (::&))+import Vulkan.CStruct.Extends (SomeStruct(..)) import Vulkan.NamedType ((:::))-import Vulkan.Utils.Debug qualified as Debug import Vulkan.Zero (Zero(..))  import Engine.SpirV.Reflect (Reflect) import Engine.Vulkan.DescSets (Bound(..), Compatible)+import Engine.Vulkan.Format (HasVkFormat(..), formatSize) import Engine.Vulkan.Pipeline (Pipeline(..)) import Engine.Vulkan.Pipeline qualified as Pipeline import Engine.Vulkan.Pipeline.Stages (StageInfo(..)) import Engine.Vulkan.Shader qualified as Shader-import Engine.Vulkan.Types (HasVulkan(..), HasRenderPass(..), MonadVulkan, DsBindings, getPipelineCache)+import Engine.Vulkan.Types (HasVulkan(..), HasRenderPass(..), MonadVulkan, DsLayoutBindings, getPipelineCache) import Render.Code (Code) import Resource.Collection (Generically1(..))+import Resource.Vulkan.DescriptorLayout qualified as Layout+import Resource.Vulkan.Named qualified as Named  data Stages a = Stages   { vert :: a -- ^ vertex@@ -119,7 +124,7 @@   { cStages             :: StageSpirv   , cReflect            :: Maybe StageReflect   , cVertexInput        :: SomeStruct Vk.PipelineVertexInputStateCreateInfo-  , cDescLayouts        :: Tagged dsl [DsBindings]+  , cDescLayouts        :: Tagged dsl [DsLayoutBindings]   , cPushConstantRanges :: Vector Vk.PushConstantRange   , cBlend              :: Bool   , cDepthWrite         :: Bool@@ -175,66 +180,48 @@   -> Config dsl vertices instances spec   -> renderpass   -> m (ReleaseKey, pipeline)-allocate extent msaa config renderpass = withFrozenCallStack do-  ctx <- ask-  Resource.allocate-    (create ctx extent msaa renderpass config)-    (Pipeline.destroy ctx)+allocate extent msaa config renderpass =+  withFrozenCallStack $+    Pipeline.allocateWith $ create extent msaa renderpass config  create-  :: ( MonadUnliftIO io-     , HasVulkan ctx+  :: ( MonadVulkan env io      , HasRenderPass renderpass      , Shader.Specialization spec      , HasCallStack      )-  => ctx-  -> Maybe Vk.Extent2D+  => Maybe Vk.Extent2D   -> Vk.SampleCountFlagBits   -> renderpass   -> Config dsl vertices instances spec   -> io (Pipeline dsl vertices instances)-create context mextent msaa renderpass Config{..} = do-  let-    originModule =-      fromString . List.intercalate "|" $-        map (srcLocModule . snd) (getCallStack callStack)--  dsLayouts <- Vector.forM (Vector.fromList $ unTagged cDescLayouts) \bindsFlags -> do-    let-      (binds, flags) = List.unzip bindsFlags--      setCI =-        zero-          { Vk.bindings = Vector.fromList binds-          }-        ::& zero-          { Vk12.bindingFlags = Vector.fromList flags-          }-        :& ()--    Vk.createDescriptorSetLayout device setCI Nothing-+create mextent msaa renderpass Config{..} = withFrozenCallStack do   -- TODO: get from outside-  layout <- Vk.createPipelineLayout device (layoutCI dsLayouts) Nothing-  Debug.nameObject device layout originModule+  dsLayouts <- Layout.create $ Vector.fromList (unTagged cDescLayouts) +  -- TODO: get from outside ?+  pipelineLayout <- Layout.forPipeline+    dsLayouts+    cPushConstantRanges+  Named.objectOrigin pipelineLayout+   shader <- Shader.withSpecialization cSpecialization $-    Shader.create context cStages+    Shader.create cStages    let     cis = Vector.singleton . SomeStruct $-      pipelineCI (Shader.sPipelineStages shader) layout+      pipelineCI (Shader.sPipelineStages shader) pipelineLayout +  device <- asks getDevice   Vk.createGraphicsPipelines device cache cis Nothing >>= \case     (Vk.SUCCESS, pipelines) ->       case Vector.toList pipelines of-        [one] -> do-          Shader.destroy context shader-          Debug.nameObject device one originModule+        [pipeline] -> do+          Shader.destroy shader+          Named.objectOrigin pipeline           pure Pipeline-            { pipeline     = one-            , pLayout      = Tagged layout+            { pipeline     = pipeline+            , pLayout      = Tagged pipelineLayout             , pDescLayouts = Tagged dsLayouts             }         _ ->@@ -242,14 +229,7 @@     (err, _) ->       error $ "createGraphicsPipelines: " <> show err   where-    device = getDevice context-    cache = getPipelineCache context--    layoutCI dsLayouts = Vk.PipelineLayoutCreateInfo-      { flags              = zero-      , setLayouts         = dsLayouts-      , pushConstantRanges = cPushConstantRanges-      }+    cache = getPipelineCache undefined      pipelineCI stages layout = zero       { Vk.stages             = stages@@ -385,8 +365,14 @@   Bound $ Vk.cmdBindPipeline cb Vk.PIPELINE_BIND_POINT_GRAPHICS pipeline   Bound attrAction -vertexInput :: [(Vk.VertexInputRate, [Vk.Format])] -> SomeStruct Vk.PipelineVertexInputStateCreateInfo-vertexInput bindings = SomeStruct zero+vertexInput+  :: forall a pipeLayout vertices instances+  .  ( a ~ Pipeline pipeLayout vertices instances+     , HasVertexInputBindings vertices -- XXX: 0-2 of {positions, attrs} (e.g. position + uv)+     , HasVertexInputBindings instances -- XXX: 0+ of instance attrs (e.g. static params + dynamic transforms)+     )+  => SomeStruct Vk.PipelineVertexInputStateCreateInfo+vertexInput = SomeStruct zero   { Vk.vertexBindingDescriptions   = binds   , Vk.vertexAttributeDescriptions = attrs   }@@ -401,6 +387,11 @@      attrs = attrBindings $ map snd bindings +    bindings =+      filter (not . null . snd) $+        vertexInputBindings @vertices <>+        vertexInputBindings @instances+ -- * Utils  attrBindings :: [[Vk.Format]] -> Vector Vk.VertexInputAttributeDescription@@ -426,22 +417,19 @@             , rest             ) -formatSize :: Integral a => Vk.Format -> a-formatSize = \case-  Vk.FORMAT_R32G32B32A32_SFLOAT -> 16-  Vk.FORMAT_R32G32B32_SFLOAT    -> 12-  Vk.FORMAT_R32G32_SFLOAT       -> 8-  Vk.FORMAT_R32_SFLOAT          -> 4+type VertexInputBinding = (Vk.VertexInputRate, [Vk.Format]) -  Vk.FORMAT_R32G32B32A32_UINT -> 16-  Vk.FORMAT_R32G32B32_UINT    -> 12-  Vk.FORMAT_R32G32_UINT       -> 8-  Vk.FORMAT_R32_UINT          -> 4+vertexFormat :: forall a . HasVkFormat a => VertexInputBinding+vertexFormat = (Vk.VERTEX_INPUT_RATE_VERTEX, getVkFormat @a) -  Vk.FORMAT_R32G32B32A32_SINT -> 16-  Vk.FORMAT_R32G32B32_SINT    -> 12-  Vk.FORMAT_R32G32_SINT       -> 8-  Vk.FORMAT_R32_SINT          -> 4+instanceFormat :: forall a . HasVkFormat a => VertexInputBinding+instanceFormat = (Vk.VERTEX_INPUT_RATE_INSTANCE, getVkFormat @a) -  format ->-    error $ "Format size unknown: " <> show format+class HasVertexInputBindings a where+  vertexInputBindings :: [VertexInputBinding]++instance HasVertexInputBindings () where+  vertexInputBindings = []++instance HasVertexInputBindings Transform where+  vertexInputBindings = [instanceFormat @Transform]

@@ -18,13 +18,15 @@ import Data.Vector qualified as Vector import Data.Vector.Storable qualified as Storable import Foreign qualified+import GHC.Stack (withFrozenCallStack) import Vulkan.Core10 qualified as Vk import Vulkan.CStruct.Extends (SomeStruct(..)) import Vulkan.Zero (Zero(..)) import Unsafe.Coerce (unsafeCoerce)  import Engine.Vulkan.Pipeline.Stages (StageInfo(..))-import Engine.Vulkan.Types (HasVulkan(..))+import Engine.Vulkan.Types (MonadVulkan, getDevice)+import Resource.Vulkan.Named qualified as Named  data Shader = Shader   { sModules        :: Vector Vk.ShaderModule@@ -32,23 +34,25 @@   }  create-  :: ( MonadIO io-     , HasVulkan ctx+  :: ( MonadVulkan env io      , StageInfo t+     , HasCallStack      )-  => ctx-  -> t (Maybe ByteString)+  => t (Maybe ByteString)   -> Maybe Vk.SpecializationInfo   -> io Shader-create context stages spec = do+create stages spec = withFrozenCallStack do+  device <- asks getDevice   staged <- Vector.forM collected \(stage, code) -> do     module_ <- Vk.createShaderModule-      (getDevice context)+      device       zero         { Vk.code = code         }       Nothing +    Named.objectOrigin module_+     pure       ( module_       , SomeStruct zero@@ -68,10 +72,11 @@       (stage, Just code) <- toList $ (,) <$> stageFlagBits <*> stages       pure (stage, code) -destroy :: (MonadIO io, HasVulkan ctx) => ctx -> Shader -> io ()-destroy context Shader{sModules} =+destroy :: MonadVulkan env io => Shader -> io ()+destroy Shader{sModules} = do+  device <- asks getDevice   Vector.forM_ sModules \module_ ->-    Vk.destroyShaderModule (getDevice context) module_ Nothing+    Vk.destroyShaderModule device module_ Nothing  -- * Specialization constants 

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}  module Engine.Vulkan.Swapchain   ( SwapchainResources(..)@@ -70,7 +71,9 @@      , HasVulkan env      , HasLogFunc env      )-  => Khr.SwapchainKHR+  => Maybe Khr.PresentModeKHR+  -> Vk.SampleCountFlagBits+  -> Khr.SwapchainKHR   -- ^ Previous swapchain, can be NULL_HANDLE   -> Vk.Extent2D   -- ^ If the swapchain size determines the surface size, use this size@@ -78,11 +81,11 @@   -> Worker.Var Vk.Extent2D   -> RIO env SwapchainResources   -- -> ResourceT (RIO env) SwapchainResources-allocSwapchainResources oldSwapchain windowSize surface screenVar = do+allocSwapchainResources present msaa oldSwapchain windowSize surface screenVar = do   logDebug "Allocating swapchain resources"    device <- asks getDevice-  info@SwapchainInfo{..} <- createSwapchain oldSwapchain windowSize surface+  info@SwapchainInfo{..} <- createSwapchain present msaa oldSwapchain windowSize surface    -- XXX: Get all the swapchain images, and create views for them   (_, swapchainImages) <- Khr.getSwapchainImagesKHR device siSwapchain@@ -112,12 +115,16 @@      , HasVulkan env      , HasLogFunc env      )-  => Vk.Extent2D+  => Maybe Khr.PresentModeKHR+  -> Vk.SampleCountFlagBits+  -> Vk.Extent2D   -> SwapchainResources   -- ^ The reference to these resources will be dropped   -> RIO env SwapchainResources-recreateSwapchainResources windowSize oldResources = do+recreateSwapchainResources present msaa windowSize oldResources = do   sr <- allocSwapchainResources+    present+    msaa     (siSwapchain $ srInfo oldResources)     windowSize     (siSurface $ srInfo oldResources)@@ -131,13 +138,15 @@      , MonadVulkan env m      , HasLogFunc env      )-  => Khr.SwapchainKHR+  => Maybe Khr.PresentModeKHR+  -> Vk.SampleCountFlagBits+  -> Khr.SwapchainKHR   -- ^ Old swapchain, can be NULL_HANDLE   -> Vk.Extent2D   -- ^ If the swapchain size determines the surface size, use this size   -> Khr.SurfaceKHR   -> m SwapchainInfo-createSwapchain oldSwapchain explicitSize surf = do+createSwapchain present msaa oldSwapchain explicitSize surf = do   physical <- asks getPhysicalDevice   device <- asks getDevice   props <- asks $ pdiProperties . getPhysicalDeviceInfo@@ -152,8 +161,15 @@       throwString $ "Surface images do not support " <> show flag    -- Select a present mode+  desiredPresentModes <- case present of+    Nothing -> do+      logDebug $ "Using default present modes: " <> displayShow defaultPresentModes+      pure defaultPresentModes+    Just selected -> do+      logDebug $ "Forcing selected present mode: " <> displayShow selected+      pure [selected]   (_, availablePresentModes) <- Khr.getPhysicalDeviceSurfacePresentModesKHR physical surf-  presentMode                <-+  presentMode <-     case filter (`V.elem` availablePresentModes) desiredPresentModes of       [] -> do         logError "Unable to find a suitable present mode for swapchain"@@ -184,14 +200,14 @@   let     minImageCount =       let-        limit = case Khr.maxImageCount (surfaceCaps :: Khr.SurfaceCapabilitiesKHR) of+        limit = case surfaceCaps.maxImageCount of           0 -> maxBound           n -> n         -- Request one additional image to prevent us having to wait for         -- the driver to finish         buffer = 1         desired =-          buffer + Khr.minImageCount (surfaceCaps :: Khr.SurfaceCapabilitiesKHR)+          buffer + surfaceCaps.minImageCount       in         min limit desired @@ -232,7 +248,7 @@     , siSurfaceFormat       = surfaceFormat     , siSurfaceColorspace   = surfaceColorspace     , siDepthFormat         = depthFormat-    , siMultisample         = msaaSamples props+    , siMultisample         = msaaSamples msaa props     , siAnisotropy          = Vk.maxSamplerAnisotropy (Vk.limits props)     , siImageExtent         = imageExtent     }@@ -295,10 +311,14 @@   , Vk.FORMAT_D32_SFLOAT   ] -msaaSamples :: Vk.PhysicalDeviceProperties -> Vk.SampleCountFlagBits-msaaSamples Vk.PhysicalDeviceProperties{limits} =+msaaSamples+  :: Vk.SampleCountFlagBits+  -> Vk.PhysicalDeviceProperties+  -> Vk.SampleCountFlagBits+msaaSamples upperLimit Vk.PhysicalDeviceProperties{limits} =   case samplesAvailable of     [] ->+      -- XXX: Something went wrong...       Vk.SAMPLE_COUNT_1_BIT     best : _rest ->       best@@ -309,27 +329,26 @@      samplesAvailable = do       countBit <- msaaCandidates-      guard $ (counts .&. countBit) /= zeroBits+      guard $ countBit <= upperLimit -- XXX: requested+      guard $ (counts .&. countBit) /= zeroBits -- XXX: capable       pure countBit  msaaCandidates :: [Vk.SampleCountFlagBits] msaaCandidates =-  {--    XXX: Also possible, but not that impactful: 16x, 8x.--    Khronos MSAA best practice says:-      Use 4x MSAA if possible; it's not expensive and provides good image quality improvements.-  -}-  [ Vk.SAMPLE_COUNT_4_BIT+  [ Vk.SAMPLE_COUNT_64_BIT -- XXX: extremely unrealistic?+  , Vk.SAMPLE_COUNT_32_BIT -- XXX: unrealistic?+  , Vk.SAMPLE_COUNT_16_BIT -- XXX: possible, but not that impactful+  , Vk.SAMPLE_COUNT_8_BIT+  , Vk.SAMPLE_COUNT_4_BIT -- XXX: Khronos-recommended for rasterizing   , Vk.SAMPLE_COUNT_2_BIT+  , Vk.SAMPLE_COUNT_1_BIT -- XXX: i.e. "disable", always available   ]  -- | An ordered list of the present mode to be chosen for the swapchain.-desiredPresentModes :: [Khr.PresentModeKHR]-desiredPresentModes =+defaultPresentModes :: [Khr.PresentModeKHR]+defaultPresentModes =   [ Khr.PRESENT_MODE_FIFO_RELAXED_KHR   , Khr.PRESENT_MODE_FIFO_KHR --  ^ This will always be present-  , Khr.PRESENT_MODE_IMMEDIATE_KHR --  ^ Keep this here for easy swapping for testing   ]  -- | The images in the swapchain must support these flags.@@ -402,8 +421,14 @@         Vk.Extent2D{width, height} = extent         Vk.Rect2D{offset, extent} = viewrect -setDynamicFullscreen :: MonadIO io => Vk.CommandBuffer -> SwapchainResources -> io ()-setDynamicFullscreen cb sr = do+setDynamicFullscreen+  :: ( HasSwapchain swapchain+     , MonadIO io+     )+  => Vk.CommandBuffer+  -> swapchain+  -> io ()+setDynamicFullscreen cb swapchain = do   Vk.cmdSetViewport cb     0     [ Vk.Viewport@@ -417,11 +442,10 @@     ]   Vk.cmdSetScissor cb 0     [ Vk.Rect2D-        { offset = Vk.Offset2D 0 0-        , extent = siImageExtent+        { offset = zero+        , extent = extent         }     ]   where-    SwapchainResources{srInfo} = sr-    SwapchainInfo{siImageExtent} = srInfo-    Vk.Extent2D{width, height} = siImageExtent+    extent@Vk.Extent2D{width, height} =+      getSurfaceExtent swapchain

@@ -11,7 +11,7 @@   , Queues(..)    , DsLayouts-  , DsBindings+  , DsLayoutBindings    , Bound(..)   ) where@@ -20,6 +20,7 @@  import Data.Kind (Type) import RIO.App (App(..))+import RIO.State (MonadState(..)) import UnliftIO.Resource (MonadResource) import Vulkan.Core10 qualified as Vk import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing qualified as Vk12@@ -115,8 +116,10 @@     => a     -> RIO env () -type DsBindings = [(Vk.DescriptorSetLayoutBinding, Vk12.DescriptorBindingFlags)]+type DsLayoutBindings = [(Vk.DescriptorSetLayoutBinding, Vk12.DescriptorBindingFlags)] type DsLayouts = Vector Vk.DescriptorSetLayout  newtype Bound (dsl :: [Type]) vertices instances m a = Bound (m a)-  deriving (Foldable, Traversable, Functor, Applicative, Monad, MonadIO, MonadUnliftIO)+  deriving stock (Foldable, Traversable, Functor)+  deriving newtype (Applicative, Monad, MonadIO, MonadUnliftIO)+  deriving newtype (MonadReader r, MonadState s)

@@ -16,11 +16,15 @@ import UnliftIO.Resource (ReleaseKey) import UnliftIO.Resource qualified as Resource -import Engine.Types (GlobalHandles(..), StageRIO)+import Engine.Types (ghWindow)+import Engine.Events.Sink (MonadSink) -type Callback st = Double -> Double -> StageRIO st ()+type Callback m = Double -> Double -> m () -callback :: Callback st -> StageRIO st ReleaseKey+callback+  :: MonadSink rs m+  => Callback m+  -> m ReleaseKey callback handler = do   window <- asks $ ghWindow . appEnv   withUnliftIO \ul ->@@ -28,7 +32,7 @@   Resource.register $     GLFW.setCursorPosCallback window Nothing -mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.CursorPosCallback+mkCallback :: UnliftIO m -> Callback m -> GLFW.CursorPosCallback mkCallback (UnliftIO ul) action =   \_window px py ->     ul $ action px py

@@ -12,11 +12,12 @@ import UnliftIO.Resource (ReleaseKey) import UnliftIO.Resource qualified as Resource -import Engine.Types (GlobalHandles(..), StageRIO)+import Engine.Events.Sink (MonadSink)+import Engine.Types (GlobalHandles(..)) -type Callback st = [FilePath] -> StageRIO st ()+type Callback m = [FilePath] -> m () -callback :: Callback st -> StageRIO st ReleaseKey+callback :: MonadSink rs m => Callback m -> m ReleaseKey callback handler = do   window <- asks $ ghWindow . appEnv   withUnliftIO \ul ->@@ -24,7 +25,7 @@   Resource.register $     GLFW.setDropCallback window Nothing -mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.DropCallback+mkCallback :: UnliftIO m -> Callback m -> GLFW.DropCallback mkCallback (UnliftIO ul) action =   \_window files ->     ul $ action files

@@ -16,11 +16,12 @@ import UnliftIO.Resource (ReleaseKey) import UnliftIO.Resource qualified as Resource -import Engine.Types (GlobalHandles(..), StageRIO)+import Engine.Events.Sink (MonadSink)+import Engine.Types (ghWindow) -type Callback st = Int -> (GLFW.ModifierKeys, GLFW.KeyState, GLFW.Key) -> StageRIO st ()+type Callback m = Int -> (GLFW.ModifierKeys, GLFW.KeyState, GLFW.Key) -> m () -callback :: Callback st -> StageRIO st ReleaseKey+callback :: MonadSink rs m => Callback m -> m ReleaseKey callback handler = do   window <- asks $ ghWindow . appEnv   withUnliftIO \ul ->@@ -28,7 +29,7 @@   Resource.register $     GLFW.setKeyCallback window Nothing -mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.KeyCallback+mkCallback :: UnliftIO m -> Callback m -> GLFW.KeyCallback mkCallback (UnliftIO ul) action =   \_window key keyCode keyState mods ->     ul $ action keyCode (mods, keyState, key)

@@ -20,16 +20,20 @@ import RIO  import Graphics.UI.GLFW qualified as GLFW+import Resource.Collection (Generic1, Generically1(..)) import RIO.App (appEnv) import UnliftIO.Resource (ReleaseKey) import UnliftIO.Resource qualified as Resource-import Resource.Collection (Generic1, Generically1(..)) -import Engine.Types (GlobalHandles(..), StageRIO)+import Engine.Events.Sink (MonadSink)+import Engine.Types (GlobalHandles(..)) -type Callback st = (GLFW.ModifierKeys, GLFW.MouseButtonState, GLFW.MouseButton) -> StageRIO st ()+type Callback m = (GLFW.ModifierKeys, GLFW.MouseButtonState, GLFW.MouseButton) -> m () -callback :: Callback st -> StageRIO st ReleaseKey+callback+  :: MonadSink rs m+  => Callback m+  -> m ReleaseKey callback handler = do   window <- asks $ ghWindow . appEnv   withUnliftIO \ul ->@@ -37,7 +41,7 @@   Resource.register $     GLFW.setMouseButtonCallback window Nothing -mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.MouseButtonCallback+mkCallback :: UnliftIO m -> Callback m -> GLFW.MouseButtonCallback mkCallback (UnliftIO ul) action =   \_window button buttonState mods ->     ul $ action (mods, buttonState, button)

@@ -12,11 +12,15 @@ import UnliftIO.Resource (ReleaseKey) import UnliftIO.Resource qualified as Resource -import Engine.Types (GlobalHandles(..), StageRIO)+import Engine.Events.Sink (MonadSink)+import Engine.Types (GlobalHandles(..)) -type Callback st = Double -> Double -> StageRIO st ()+type Callback m = Double -> Double -> m () -callback :: Callback st -> StageRIO st ReleaseKey+callback+  :: MonadSink rs m+  => Callback m+  -> m ReleaseKey callback handler = do   window <- asks $ ghWindow . appEnv   withUnliftIO \ul ->@@ -24,7 +28,7 @@   Resource.register $     GLFW.setScrollCallback window Nothing -mkCallback :: UnliftIO (StageRIO st) -> Callback st -> GLFW.ScrollCallback+mkCallback :: UnliftIO m -> Callback m -> GLFW.ScrollCallback mkCallback (UnliftIO ul) action =   \_window dx dy ->     ul $ action dx dy

@@ -50,12 +50,6 @@   , newSource   , pubSource   , subSource--  , HasWorker(..)-  , register-  , registerCollection-  , registered-  , registeredCollection   ) where  import RIO@@ -286,7 +280,9 @@ type Cell input output = (Var input, Merge output)  spawnCell-  :: MonadUnliftIO m+  :: ( MonadUnliftIO m+     , MonadResource m+     )   => (input -> output)   -> input   -> m (Cell input output)@@ -298,6 +294,7 @@ -- | Timer-driven stateful producer. data Timed config output = Timed   { tWorker :: ThreadId+  , tKey    :: Resource.ReleaseKey   , tActive :: TVar Bool   , tConfig :: TVar config   , tOutput :: Var output@@ -312,7 +309,9 @@   getOutput = tOutput  spawnTimed_-  :: MonadUnliftIO m+  :: ( MonadUnliftIO m+     , MonadResource m+     )   => Bool   -> Int   -> output@@ -330,7 +329,9 @@     ()  spawnTimed-  :: MonadUnliftIO m+  :: ( MonadUnliftIO m+     , MonadResource m+     )   => Bool   -> Either Int (config -> Int)   -> (config -> m (output, state))@@ -344,6 +345,7 @@   tOutput <- newVar initialOutput   tWorker <- forkIO $     step tActive tConfig tOutput initialState+  tKey <- Resource.register $ killThread tWorker   pure Timed{..}   where     step activeVar configVar output curState = do@@ -365,8 +367,9 @@  -- | Supply-driven step cell. data Merge o = Merge-  { mWorker   :: ThreadId-  , mOutput   :: TVar (Versioned o)+  { mWorker :: ThreadId+  , mKey    :: Resource.ReleaseKey+  , mOutput :: TVar (Versioned o)   }  instance HasOutput (Merge o) where@@ -375,6 +378,7 @@  spawnMerge1   :: ( MonadUnliftIO m+     , MonadResource m      , HasOutput i      )   => (GetOutput i -> o)@@ -402,13 +406,17 @@       else         retrySTM +  key <- Resource.register $ killThread worker+   pure Merge     { mWorker = worker+    , mKey    = key     , mOutput = output     }  spawnMerge2   :: ( MonadUnliftIO m+     , MonadResource m      , HasOutput i1      , HasOutput i2      )@@ -443,8 +451,11 @@       else         retrySTM +  key <- Resource.register $ killThread worker+   pure Merge     { mWorker = worker+    , mKey    = key     , mOutput = output     }   where@@ -452,6 +463,7 @@  spawnMerge3   :: ( MonadUnliftIO m+     , MonadResource m      , HasOutput i1      , HasOutput i2      , HasOutput i3@@ -490,8 +502,11 @@       else         retrySTM +  key <- Resource.register $ killThread worker+   pure Merge     { mWorker = worker+    , mKey    = key     , mOutput = output     }   where@@ -499,6 +514,7 @@  spawnMerge4   :: ( MonadUnliftIO m+     , MonadResource m      , HasOutput i1      , HasOutput i2      , HasOutput i3@@ -541,8 +557,11 @@       else         retrySTM +  key <- Resource.register $ killThread worker+   pure Merge     { mWorker = worker+    , mKey    = key     , mOutput = output     }   where@@ -557,6 +576,7 @@   :: ( Traversable t      , HasOutput input      , MonadUnliftIO m+     , MonadResource m      )   => (t (GetOutput input) -> output)   -> t input@@ -585,8 +605,11 @@       else         retrySTM +  key <- Resource.register $ killThread worker+   pure Merge     { mWorker = worker+    , mKey    = key     , mOutput = output     } @@ -644,56 +667,3 @@  subSource :: MonadUnliftIO m => Source a -> m (UnagiPrim.OutChan a) subSource (Source ic) = liftIO $ UnagiPrim.dupChan ic---- * Utils--class HasWorker a where-  getWorker :: a -> ThreadId--instance HasWorker (Cell i o) where-  getWorker = mWorker . snd--instance HasWorker (Timed c o) where-  getWorker = tWorker--instance HasWorker (Merge o) where-  getWorker = mWorker--register-  :: ( MonadResource m-     , HasWorker process-     )-  => process-  -> m Resource.ReleaseKey-register = Resource.register . killThread . getWorker--registerCollection-  :: ( MonadResource m-     , HasWorker process-     , Foldable t-     )-  => t process-  -> m Resource.ReleaseKey-registerCollection = Resource.register . traverse_ (killThread . getWorker)--registered :: (MonadResource m, HasWorker a) => m a -> m (Resource.ReleaseKey, a)-registered spawn = do-  worker <- spawn-  key <- Resource.register $ killThread (getWorker worker)-  pure (key, worker)--registeredCollection-  :: ( MonadResource m-     , HasWorker process-     , Traversable t-     )-  => (input -> m process)-  -> t input-  -> m (Resource.ReleaseKey, t process)-registeredCollection spawn inputs = do-  workers <- traverse spawn inputs--  key <- Resource.register $-    traverse_ (killThread . getWorker) workers--  pure (key, workers)

@@ -7,6 +7,7 @@   , compileVert   , compileFrag   , compileComp+  , targetEnv   ) where  import RIO@@ -24,10 +25,13 @@   show = Text.unpack . unCode  compileVert :: Code -> Q Exp-compileVert = compileShaderQ Nothing "vert" Nothing . Text.unpack . unCode+compileVert = compileShaderQ (Just targetEnv) "vert" Nothing . Text.unpack . unCode  compileFrag :: Code -> Q Exp-compileFrag = compileShaderQ Nothing "frag" Nothing . Text.unpack . unCode+compileFrag = compileShaderQ (Just targetEnv) "frag" Nothing . Text.unpack . unCode  compileComp :: Code -> Q Exp-compileComp = compileShaderQ Nothing "comp" Nothing . Text.unpack . unCode+compileComp = compileShaderQ (Just targetEnv) "comp" Nothing . Text.unpack . unCode++targetEnv :: IsString a => a+targetEnv = "vulkan1.2"

@@ -54,7 +54,7 @@   => Vk.CommandBuffer   -> Model.Indexed storage pos attrs   -> instances-  -> Bound dsl attrs (Model.VertexBuffersOf instances) m ()+  -> Bound dsl (Model.Vertex pos attrs) (Model.VertexBuffersOf instances) m () indexed cmd model instances = indexedRanges cmd model instances [wholeIndexed]   where     wholeIndexed = Model.IndexRange@@ -73,10 +73,10 @@   -> Model.Indexed storage pos attrs   -> instances   -> [Model.IndexRange]-  -> Bound dsl attrs (Model.VertexBuffersOf instances) m ()+  -> Bound dsl (Model.Vertex pos attrs) (Model.VertexBuffersOf instances) m () indexedRanges cmd model instances ranges = do-  checkedTanges <- traverse check ranges-  Bound $ unsafeIndexedRanges True cmd model instances checkedTanges+  checkedRanges <- traverse check ranges+  Bound $ unsafeIndexedRanges True cmd model instances checkedRanges   where     check ir@Model.IndexRange{..}       | irFirstIndex > maxIndex =@@ -101,7 +101,7 @@   -> instances   -> Int   -> t Model.IndexRange-  -> Bound dsl attrs (Model.VertexBuffersOf instances) m ()+  -> Bound dsl (Model.Vertex pos attrs) (Model.VertexBuffersOf instances) m () indexedParts drawAttrs cmd model instances startInstance parts =   Bound $ unsafeIndexedParts drawAttrs cmd model instances startInstance parts @@ -113,7 +113,7 @@   => Vk.CommandBuffer   -> Model.Indexed storage pos unusedAttrs   -> instances-  -> Bound dsl ignoreAttrs (Model.VertexBuffersOf instances) m ()+  -> Bound dsl (Model.Vertex pos ignoreAttrs) (Model.VertexBuffersOf instances) m () indexedPos cmd model instances = indexedPosRanges cmd model instances [wholeIndexed]   where     wholeIndexed = Model.IndexRange@@ -128,10 +128,10 @@   -> Model.Indexed storage pos unusedAttrs   -> instances   -> [Model.IndexRange]-  -> Bound dsl ignoreAttrs (Model.VertexBuffersOf instances) m ()+  -> Bound dsl (Model.Vertex pos ignoreAttrs) (Model.VertexBuffersOf instances) m () indexedPosRanges cmd model instances ranges = do-  checkedTanges <- traverse check ranges-  Bound $ unsafeIndexedRanges False cmd model instances checkedTanges+  checkedRanges <- traverse check ranges+  Bound $ unsafeIndexedRanges False cmd model instances checkedRanges   where     check ir@Model.IndexRange{..}       | irFirstIndex > maxIndex =

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedRecordDot #-}  module Render.Pass.Offscreen   ( Settings(..)@@ -12,6 +13,7 @@  import RIO +import Control.Monad.Trans.Resource (ResourceT) import Control.Monad.Trans.Resource qualified as Resource import Data.Bits ((.|.)) import Data.Vector qualified as Vector@@ -21,11 +23,14 @@ import Vulkan.Utils.Debug qualified as Debug import Vulkan.Zero (zero) -import Engine.Types.RefCounted (RefCounted, newRefCounted, resourceTRefCount)+import Engine.Types.RefCounted (RefCounted)+import Engine.Types.RefCounted qualified as RefCounted import Engine.Vulkan.Types (HasVulkan(..), HasRenderPass(..), RenderPass(..), MonadVulkan) import Resource.Image (AllocatedImage) import Resource.Image qualified as Image+import Resource.Region qualified as Region import Resource.Texture (CubeMap, Flat, Texture(..))+import Resource.Vulkan.Named qualified as Named  {- XXX: Consider spec wrt. parameters and intended use! @@ -35,7 +40,9 @@   { sLabel       :: Text   , sExtent      :: Vk.Extent2D   , sFormat      :: Vk.Format+  , sColorLayout :: Maybe Vk.ImageLayout -- ^ Target color format when used for export.   , sDepthFormat :: Vk.Format+  , sDepthLayout :: Maybe Vk.ImageLayout -- ^ Target depth format when used for export.   , sLayers      :: Word32   , sMultiView   :: Bool -- ^ Makes sense only for multiple layers.   , sSamples     :: Vk.SampleCountFlagBits -- ^ Multisample prevents mipmapping and cubes.@@ -64,11 +71,11 @@   getRenderArea   = oRenderArea  instance RenderPass Offscreen where-  refcountRenderpass = resourceTRefCount . oRelease+  refcountRenderpass = RefCounted.resourceTRefCount . oRelease  colorTexture :: Offscreen -> Texture Flat colorTexture Offscreen{..} = Texture-  { tFormat         = Image.aiFormat oColor+  { tFormat         = oColor.aiFormat   , tMipLevels      = oMipLevels   , tLayers         = oLayers   , tAllocatedImage = oColor@@ -76,7 +83,7 @@  colorCube :: Offscreen -> Texture CubeMap colorCube Offscreen{..} = Texture-  { tFormat         = Image.aiFormat oColor+  { tFormat         = oColor.aiFormat   , tMipLevels      = oMipLevels   , tLayers         = oLayers -- TODO: get from type param   , tAllocatedImage = oColor@@ -84,7 +91,7 @@  depthTexture :: Offscreen -> Texture Flat depthTexture Offscreen{..} = Texture-  { tFormat         = Image.aiFormat oDepth+  { tFormat         = oDepth.aiFormat   , tMipLevels      = oMipLevels   , tLayers         = oLayers   , tAllocatedImage = oDepth@@ -92,7 +99,7 @@  depthCube :: Offscreen -> Texture CubeMap depthCube Offscreen{..} = Texture-  { tFormat         = Image.aiFormat oDepth+  { tFormat         = oDepth.aiFormat   , tMipLevels      = oMipLevels   , tLayers         = oLayers -- TODO: get from type param   , tAllocatedImage = oDepth@@ -106,11 +113,14 @@   => Settings   -> m Offscreen allocate settings@Settings{..} = do-  logDebug $ "Allocating Offscreen resources for " <> display sLabel--  (_rpKey, renderPass) <- allocateRenderPass settings+  (_passKey, renderPass) <- allocateRenderPass settings -  (refcounted, color, depth, framebuffer) <- allocateFramebuffer settings renderPass+  (release, resources) <- RefCounted.wrapped $ Region.run do+    Region.logDebug+      ("Allocating Offscreen resources for " <> display sLabel)+      ("Releasing Offscreen resources for " <> display sLabel)+    allocateFramebuffer settings renderPass+  let (color, depth, framebuffer) = resources    pure Offscreen     { oRenderPass  = renderPass@@ -122,7 +132,7 @@     , oColor       = color     , oDepth       = depth     , oFrameBuffer = framebuffer-    , oRelease     = refcounted+    , oRelease     = release     }   where     fullSurface = Vk.Rect2D@@ -174,7 +184,7 @@       { Vk.format         = sFormat settings       , Vk.samples        = sSamples settings       , Vk.initialLayout  = Vk.IMAGE_LAYOUT_UNDEFINED-      , Vk.finalLayout    = Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL+      , Vk.finalLayout    = fromMaybe Vk.IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL (sColorLayout settings)       , Vk.loadOp         = Vk.ATTACHMENT_LOAD_OP_CLEAR       , Vk.storeOp        = Vk.ATTACHMENT_STORE_OP_STORE       , Vk.stencilLoadOp  = Vk.ATTACHMENT_LOAD_OP_DONT_CARE@@ -185,7 +195,7 @@       { Vk.format         = sDepthFormat settings       , Vk.samples        = sSamples settings       , Vk.initialLayout  = Vk.IMAGE_LAYOUT_UNDEFINED-      , Vk.finalLayout    = Vk.IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL+      , Vk.finalLayout    = fromMaybe Vk.IMAGE_LAYOUT_DEPTH_STENCIL_ATTACHMENT_OPTIMAL (sDepthLayout settings)       , Vk.loadOp         = Vk.ATTACHMENT_LOAD_OP_CLEAR       , Vk.storeOp        = Vk.ATTACHMENT_STORE_OP_DONT_CARE       , Vk.stencilLoadOp  = Vk.ATTACHMENT_LOAD_OP_DONT_CARE@@ -246,8 +256,7 @@ -- ** Framebuffer  type FramebufferOffscreen =-  ( RefCounted-  , Image.AllocatedImage+  ( Image.AllocatedImage   , Image.AllocatedImage   , Vk.Framebuffer   )@@ -259,44 +268,36 @@      )   => Settings   -> Vk.RenderPass-  -> m FramebufferOffscreen+  -> ResourceT m FramebufferOffscreen allocateFramebuffer Settings{..} renderPass = do-  context <- ask-  let device = getDevice context-  let-    Vk.Extent2D{width, height} = sExtent-    mipLevels = extentMips sExtent+  Region.logDebug+    ("Allocating Offscreen resources for " <> display sLabel)+    ("Releasing Offscreen resources for " <> display sLabel) -  (colorKey, color) <- Resource.allocate-    ( Image.create-        context-        (Just $ sLabel <> ".color")-        Vk.IMAGE_ASPECT_COLOR_BIT-        sExtent-        (if sMipMap then mipLevels else 1)-        sLayers-        sSamples-        sFormat-        ( Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT .|.-          Vk.IMAGE_USAGE_SAMPLED_BIT .|.-          Vk.IMAGE_USAGE_TRANSFER_SRC_BIT-        )+  color <- Image.allocate+    (Just $ sLabel <> ".color")+    Vk.IMAGE_ASPECT_COLOR_BIT+    (Image.inflateExtent sExtent 1)+    (if sMipMap then mipLevels else 1)+    sLayers+    sSamples+    sFormat+    ( Vk.IMAGE_USAGE_COLOR_ATTACHMENT_BIT .|.+      Vk.IMAGE_USAGE_SAMPLED_BIT .|.+      Vk.IMAGE_USAGE_TRANSFER_SRC_BIT     )-    (Image.destroy context) -  (depthKey, depth) <- Resource.allocate-    ( Image.create-        context-        (Just $ sLabel <> ".depth")-        Vk.IMAGE_ASPECT_DEPTH_BIT-        sExtent-        (if sMipMap then mipLevels else 1)-        sLayers-        sSamples-        sDepthFormat-        (Vk.IMAGE_USAGE_DEPTH_STENCIL_ATTACHMENT_BIT .|. Vk.IMAGE_USAGE_SAMPLED_BIT)+  depth <- Image.allocate+    (Just $ sLabel <> ".depth")+    Vk.IMAGE_ASPECT_DEPTH_BIT+    (Image.inflateExtent sExtent 1)+    (if sMipMap then mipLevels else 1)+    sLayers+    sSamples+    sDepthFormat+    ( Vk.IMAGE_USAGE_DEPTH_STENCIL_ATTACHMENT_BIT .|.+      Vk.IMAGE_USAGE_SAMPLED_BIT     )-    (Image.destroy context)    let     attachments = Vector.fromList@@ -323,17 +324,15 @@       , Vk.layers      = fbNumLayers       } -  (framebufferKey, framebuffer) <- Vk.withFramebuffer device fbCI Nothing Resource.allocate-  Debug.nameObject device framebuffer $ encodeUtf8 sLabel <> ".FB"--  releaseDebug <- toIO $ logDebug "Releasing Offscreen resources"-  release <- newRefCounted do-    releaseDebug-    Resource.release colorKey-    Resource.release depthKey-    Resource.release framebufferKey+  device <- asks getDevice+  framebuffer <- Vk.createFramebuffer device fbCI Nothing+  void $! Resource.register $ Vk.destroyFramebuffer device framebuffer Nothing+  Named.object framebuffer $ sLabel <> ".FB" -  pure (release, color, depth, framebuffer)+  pure (color, depth, framebuffer)+  where+    Vk.Extent2D{width, height} = sExtent+    mipLevels = extentMips sExtent  extentMips :: Num t => Vk.Extent2D -> t extentMips Vk.Extent2D{width, height} = go 1 (min width height)

@@ -1,18 +1,18 @@-{-# LANGUAGE DeriveAnyClass #-}- module Render.Samplers   ( Collection(..)   , allocate+  , allocateFrom   , indices    , Params   , params-  , create-  , destroy++  , createInfo   ) where  import RIO +import Control.Monad.Trans.Resource (ResourceT) import Control.Monad.Trans.Resource qualified as Resource import GHC.Generics (Generic1) import Vulkan.Core10 qualified as Vk@@ -20,8 +20,9 @@ import Vulkan.Zero (zero)  import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan)-import Resource.Collection qualified as Collection import Resource.Collection (Generically1(..))+import Resource.Collection qualified as Collection+import Vulkan.CStruct.Extends (PokeChain, Extendss)  data Collection a = Collection   { linearMipRepeat  :: a -- 0@@ -54,44 +55,52 @@ indices = fmap fst $ Collection.enumerate params  allocate-  :: ( MonadVulkan env m-     , Resource.MonadResource m-     )+  :: MonadVulkan env io   => "max anisotropy" ::: Float-  -> m (Resource.ReleaseKey, Collection Vk.Sampler)-allocate maxAnisotropy = do-  context <- ask-  Resource.allocate-    (for params $ create context maxAnisotropy)-    (traverse_ $ destroy context)+  -> ResourceT io (Collection Vk.Sampler)+allocate maxAnisotropy =+  for params \p ->+    allocateFrom maxAnisotropy p id -create-  :: (MonadIO io, HasVulkan context)-  => context-  -> "max anisotropy" ::: Float+allocateFrom+  :: ( PokeChain e+     , Extendss Vk.SamplerCreateInfo e+     , MonadVulkan env io+     )+  => "max anisotropy" ::: Float   -> Params-  -> io Vk.Sampler-create context maxAnisotropy (filt, mips, reps) =-  Vk.createSampler (getDevice context) samplerCI Nothing-  where-    samplerCI = zero-      { Vk.magFilter               = filt-      , Vk.minFilter               = filt-      , Vk.addressModeU            = reps-      , Vk.addressModeV            = reps-      , Vk.addressModeW            = reps-      , Vk.anisotropyEnable        = maxAnisotropy > 1-      , Vk.maxAnisotropy           = maxAnisotropy-      , Vk.borderColor             = Vk.BORDER_COLOR_INT_OPAQUE_BLACK-      , Vk.unnormalizedCoordinates = False-      , Vk.compareEnable           = False-      , Vk.compareOp               = Vk.COMPARE_OP_ALWAYS-      , Vk.mipmapMode              = Vk.SAMPLER_MIPMAP_MODE_LINEAR-      , Vk.mipLodBias              = 0-      , Vk.minLod                  = 0-      , Vk.maxLod                  = mips-      }+  -> (Vk.SamplerCreateInfo '[] -> Vk.SamplerCreateInfo e)+  -> ResourceT io Vk.Sampler+allocateFrom maxAnisotropy (filt, mips, reps) f = do+  device <- asks getDevice+  sampler <- Vk.createSampler+    device+    (f $ createInfo maxAnisotropy filt mips reps)+    Nothing+  _key <- Resource.register $+    Vk.destroySampler device sampler Nothing+  pure sampler -destroy :: (MonadIO io, HasVulkan context) => context -> Vk.Sampler -> io ()-destroy context sampler =-  Vk.destroySampler (getDevice context) sampler Nothing+createInfo+  :: "max anisotropy" ::: Float+  -> Vk.Filter+  -> "max LoD" ::: Float+  -> Vk.SamplerAddressMode+  -> Vk.SamplerCreateInfo '[]+createInfo maxAnisotropy filt mips reps = zero+  { Vk.magFilter               = filt+  , Vk.minFilter               = filt+  , Vk.addressModeU            = reps+  , Vk.addressModeV            = reps+  , Vk.addressModeW            = reps+  , Vk.anisotropyEnable        = maxAnisotropy > 1+  , Vk.maxAnisotropy           = maxAnisotropy+  , Vk.borderColor             = Vk.BORDER_COLOR_INT_OPAQUE_BLACK+  , Vk.unnormalizedCoordinates = False+  , Vk.compareEnable           = False+  , Vk.compareOp               = Vk.COMPARE_OP_ALWAYS+  , Vk.mipmapMode              = Vk.SAMPLER_MIPMAP_MODE_LINEAR+  , Vk.mipLodBias              = 0+  , Vk.minLod                  = 0+  , Vk.maxLod                  = mips+  }

@@ -6,16 +6,17 @@ import Data.Vector.Storable qualified as VectorS import Foreign (Storable) import Foreign qualified+import UnliftIO.Resource (MonadResource) import UnliftIO.Resource qualified as Resource import Vulkan.Core10 qualified as Vk import Vulkan.NamedType ((:::)) import Vulkan.Zero (zero) import VulkanMemoryAllocator qualified as VMA -import Engine.Types (StageRIO)-import Engine.Vulkan.Types (HasVulkan(getAllocator), Queues(qTransfer))+import Engine.Vulkan.Types (HasVulkan(getAllocator), Queues(qTransfer), MonadVulkan) import Engine.Worker qualified as Worker import Resource.CommandBuffer (oneshot_)+import Resource.Vulkan.Named qualified as Named  data Store = Staged | Coherent @@ -26,31 +27,47 @@   , aCapacity       :: Int   , aUsed           :: Word32   , aUsage          :: Vk.BufferUsageFlagBits+  , aLabel          :: Maybe Text   } deriving (Show) +instance Vk.HasObjectType (Allocated s a) where+  objectTypeAndHandle =+    Vk.objectTypeAndHandle . aBuffer+ allocateCoherent-  :: (Resource.MonadResource m, Storable a, HasVulkan context)-  => context+  :: ( MonadVulkan env m+     , Resource.MonadResource m+     , Storable a+     )+  => Maybe Text   -> Vk.BufferUsageFlagBits   -> "initial size" ::: Int   -> VectorS.Vector a   -> m (Resource.ReleaseKey, Allocated 'Coherent a)-allocateCoherent context usage initialSize xs =-  Resource.allocate-    (createCoherent context usage initialSize xs)-    (destroy context)+allocateCoherent label usage initialSize xs = do+  res <- createCoherent label usage initialSize xs+  destroyIO <- toIO do+    context <- ask+    destroy context res+  key <- Resource.register destroyIO+  pure (key, res)  createCoherent-  :: forall a context io . (Storable a, HasVulkan context, MonadUnliftIO io)-  => context+  :: forall a env m+  .  ( MonadVulkan env m+     , Storable a+     )+  => Maybe Text   -> Vk.BufferUsageFlagBits   -> "initial size" ::: Int   -> VectorS.Vector a-  -> io (Allocated 'Coherent a)-createCoherent context usage initialSize xs = do-  (aBuffer, aAllocation, aAllocationInfo) <- VMA.createBuffer (getAllocator context) bci aci+  -> m (Allocated 'Coherent a)+createCoherent aLabel usage initialSize xs = do+  allocator <- asks getAllocator+  (aBuffer, aAllocation, aAllocationInfo) <- VMA.createBuffer allocator bci aci+  traverse_ (Named.object aBuffer) aLabel -  when (len /= 0) $+  when (len > 0) $     if VMA.mappedData aAllocationInfo == Foreign.nullPtr then       error "TODO: recover from unmapped data and flush manually"     else@@ -64,7 +81,6 @@     , ..     }   where-     len = VectorS.length xs     lenBytes = Foreign.sizeOf (undefined :: a) * len @@ -88,34 +104,39 @@       }  createStaged-  :: forall a context io . (Storable a, HasVulkan context, MonadUnliftIO io)-  => context+  :: forall a env m+  .  ( Storable a+     , MonadVulkan env m+     )+  => Maybe Text   -> Queues Vk.CommandPool   -> Vk.BufferUsageFlagBits   -> Int   -> VectorS.Vector a-  -> io (Allocated 'Staged a)-createStaged context commandQueues usage initialSize xs = do-  (aBuffer, aAllocation, aAllocationInfo) <- VMA.createBuffer vma bci aci+  -> m (Allocated 'Staged a)+createStaged aLabel commandQueues usage initialSize xs = do+  allocator <- asks getAllocator+  (aBuffer, aAllocation, aAllocationInfo) <- VMA.createBuffer allocator bci aci+  traverse_ (Named.object aBuffer) aLabel -  when (len /= 0) . liftIO $-    VMA.withBuffer vma stageCI stageAI bracket \(staging, _stage, stageInfo) ->+  when (len > 0) $+    VMA.withBuffer allocator stageCI stageAI bracket \(staging, _stage, stageInfo) ->       if VMA.mappedData stageInfo == Foreign.nullPtr then         error "TODO: recover from unmapped data and flush manually"       else do-        VectorS.unsafeWith xs \src ->+        liftIO $ VectorS.unsafeWith xs \src ->           Foreign.copyBytes (Foreign.castPtr $ VMA.mappedData stageInfo) src lenBytes+        context <- ask         copyBuffer_ context commandQueues aBuffer staging (fromIntegral sizeBytes)    pure Allocated     { aCapacity = max initialSize len     , aUsed     = fromIntegral len     , aUsage    = usage+    , aLabel    = Nothing     , ..     }   where-    vma = getAllocator context-     len = VectorS.length xs     lenBytes = Foreign.sizeOf (undefined :: a) * len @@ -144,6 +165,16 @@       , VMA.requiredFlags = Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT       } +register+  :: ( MonadVulkan env m+     , MonadResource m+     )+  => Allocated stage a+  -> m Resource.ReleaseKey+register Allocated{aBuffer, aAllocation} = do+  allocator <- asks getAllocator+  Resource.register $ VMA.destroyBuffer allocator aBuffer aAllocation+ destroy   :: (MonadUnliftIO io, HasVulkan context)   => context@@ -152,16 +183,13 @@ destroy context a =   VMA.destroyBuffer (getAllocator context) (aBuffer a) (aAllocation a) -destroyAll-  :: (MonadUnliftIO io, HasVulkan context, Foldable t)-  => context-  -> t (Allocated s a)-  -> io ()-destroyAll context =-  traverse_ \a ->-    VMA.destroyBuffer (getAllocator context) (aBuffer a) (aAllocation a)--peekCoherent :: (MonadIO m, Storable a) => Word32 -> Allocated 'Coherent a -> m (Maybe a)+peekCoherent+  :: ( MonadIO m+     , Storable a+     )+  => Word32+  -> Allocated 'Coherent a+  -> m (Maybe a) peekCoherent ix Allocated{..} =   case VMA.mappedData aAllocationInfo of     _ | ix + 1 > aUsed ->@@ -172,8 +200,32 @@       liftIO . fmap Just $         Foreign.peekElemOff (Foreign.castPtr ptr) (fromIntegral ix) +{-# INLINE pokeCoherent #-}+pokeCoherent+  :: ( MonadVulkan env m+     , Storable a+     )+  => Allocated 'Coherent a+  -> Word32+  -> a+  -> m ()+pokeCoherent Allocated{..} ix new =+  case VMA.mappedData aAllocationInfo of+  _ | ix + 1 > aUsed ->+    pure ()+  ptr | ptr == Foreign.nullPtr ->+    pure ()+  ptr ->+    liftIO  $+      Foreign.pokeElemOff+        (Foreign.castPtr ptr)+        (fromIntegral ix)+        new+ updateCoherent-  :: (Foreign.Storable a, MonadUnliftIO io)+  :: ( MonadUnliftIO io+     , Foreign.Storable a+     )   => VectorS.Vector a   -> Allocated 'Coherent a   -> io (Allocated 'Coherent a)@@ -188,25 +240,30 @@     len = VectorS.length xs     lenBytes = len * Foreign.sizeOf (VectorS.head xs) +{-# INLINE updateCoherentResize_ #-} updateCoherentResize_-  :: (Storable a, HasVulkan context, MonadUnliftIO io)-  => context-  -> Allocated 'Coherent a+  :: ( MonadVulkan env m+     , Storable a+     )+  => Allocated 'Coherent a   -> VectorS.Vector a-  -> io (Allocated 'Coherent a)-updateCoherentResize_ ctx old xs =+  -> m (Allocated 'Coherent a)+updateCoherentResize_ old xs =   if newSize <= oldSize then     updateCoherent xs old   else do-    destroyAll ctx [old]-    createCoherent ctx (aUsage old) newSize xs+    ctx <- ask+    destroy ctx old+    createCoherent (aLabel old) (aUsage old) newSize xs   where     oldSize = aCapacity old     newSize = VectorS.length xs  -- TODO: add a staged buffer to check out the transfer queue copyBuffer_-  :: (MonadUnliftIO io, HasVulkan context)+  :: ( MonadUnliftIO io+     , HasVulkan context+     )   => context   -> Queues Vk.CommandPool   -> ("dstBuffer" ::: Vk.Buffer)@@ -221,16 +278,19 @@ type ObserverCoherent a = Worker.ObserverIO (Allocated 'Coherent a)  newObserverCoherent-  :: Storable a-  => Vk.BufferUsageFlagBits+  :: ( MonadVulkan env m+     , Storable a+     )+  => "label" ::: Text+  -> Vk.BufferUsageFlagBits   -> Int-  -> Resource.ResourceT (StageRIO st) (ObserverCoherent a)-newObserverCoherent usage initialSize = do-  context <- ask--  initialBuffer <- createCoherent context usage initialSize mempty+  -> VectorS.Vector a+  -> Resource.ResourceT m (ObserverCoherent a)+newObserverCoherent label usage initialCapacity initialData = do+  initialBuffer <- createCoherent (Just label) usage initialCapacity initialData   observer <- Worker.newObserverIO initialBuffer +  context <- ask   void $! Resource.register do     currentBuffer <- Worker.readObservedIO observer     destroy context currentBuffer@@ -239,15 +299,27 @@  {-# INLINE observeCoherentResize_ #-} observeCoherentResize_-  :: ( HasVulkan env+  :: ( MonadVulkan env m      , Worker.HasOutput source      , Worker.GetOutput source ~ VectorS.Vector output      , Storable output      )   => source   -> ObserverCoherent output-  -> RIO env ()+  -> m () observeCoherentResize_ source observer = do-  context <- ask-  Worker.observeIO_ source observer $-    updateCoherentResize_ context+  Worker.observeIO_ source observer updateCoherentResize_++{-# INLINE observeCoherentSingle #-}+observeCoherentSingle+  :: ( MonadVulkan env m+     , Worker.HasOutput source+     , Worker.GetOutput source ~ output+     , Storable output+     )+  => source+  -> ObserverCoherent output+  -> m ()+observeCoherentSingle source observer =+  Worker.observeIO_ source observer \a b ->+    pokeCoherent a 0 b $> a

@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedRecordDot #-}+ module Resource.CommandBuffer   ( allocatePools   , withPools@@ -10,6 +12,7 @@ import UnliftIO.Resource (MonadResource) import UnliftIO.Resource qualified as Resource import Vulkan.Core10 qualified as Vk+import Vulkan.Core10.CommandBuffer qualified as CommandBuffer import Vulkan.CStruct.Extends (SomeStruct(..)) import Vulkan.Utils.QueueAssignment (QueueFamilyIndex(..)) import Vulkan.Zero (zero)@@ -55,9 +58,8 @@   Vk.withCommandBuffers device commandBufferAllocateInfo bracket \case     (Vector.toList -> [buf]) -> do       let-        oneTime :: Vk.CommandBufferBeginInfo '[]         oneTime = zero-          { Vk.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT+          { CommandBuffer.flags = Vk.COMMAND_BUFFER_USAGE_ONE_TIME_SUBMIT_BIT           }        Vk.useCommandBuffer buf oneTime $ action buf

@@ -1,37 +0,0 @@-module Resource.DescriptorSet-  ( allocatePool-  , TypeMap-  , mkPoolCI-  ) where--import RIO--import UnliftIO.Resource qualified as Resource-import RIO.Vector qualified as Vector-import Vulkan.Core10 qualified as Vk-import Vulkan.Zero (zero)--import Engine.Vulkan.Types (HasVulkan(getDevice))--allocatePool-  :: ( Resource.MonadResource m-     , MonadReader env m-     , HasVulkan env-     )-  => Word32-  -> TypeMap Word32-  -> m (Resource.ReleaseKey, Vk.DescriptorPool)-allocatePool maxSets sizes = do-  device <- asks getDevice-  Vk.withDescriptorPool device (mkPoolCI maxSets sizes) Nothing Resource.allocate--type TypeMap a = [(Vk.DescriptorType, a)]--mkPoolCI-  :: Word32-  -> TypeMap Word32-  -> Vk.DescriptorPoolCreateInfo '[]-mkPoolCI maxSets sizes = zero-  { Vk.maxSets   = maxSets-  , Vk.poolSizes = Vector.fromList $ map (uncurry Vk.DescriptorPoolSize) sizes-  }

@@ -1,29 +1,43 @@+{-# LANGUAGE OverloadedRecordDot #-}+ module Resource.Image   ( AllocatedImage(..)-  , create-  , destroy-  , subresource+  , allocate+  , allocateView++  , DstImage+  , allocateDst+  , copyBufferToDst+  , updateFromStorable+   , transitionLayout   , copyBufferToImage++  , subresource+  , inflateExtent   ) where  import RIO  import Data.Bits (shiftR, (.|.)) import RIO.Vector qualified as Vector+import RIO.Vector.Storable qualified as Storable+import UnliftIO.Resource (MonadResource)+import UnliftIO.Resource qualified as Resource import Vulkan.Core10 qualified as Vk import Vulkan.CStruct.Extends (SomeStruct(..)) import Vulkan.NamedType ((:::))-import Vulkan.Utils.Debug qualified as Debug import Vulkan.Zero (zero) import VulkanMemoryAllocator qualified as VMA -import Engine.Vulkan.Types (HasVulkan(..), Queues(..))+import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, Queues(..))+import Resource.Buffer qualified as Buffer import Resource.CommandBuffer (oneshot_)+import Resource.Vulkan.Named qualified as Named  data AllocatedImage = AllocatedImage   { aiAllocation  :: VMA.Allocation-  , aiExtent      :: Vk.Extent2D+  , aiExtent      :: Vk.Extent3D   , aiFormat      :: Vk.Format   , aiImage       :: Vk.Image   , aiImageView   :: Vk.ImageView@@ -31,38 +45,32 @@   }   deriving (Show) -create-  :: ( MonadIO io-     , HasVulkan ctx+allocate+  :: ( MonadVulkan env io+     , MonadResource io      )-  => ctx-  -> Maybe Text+  => Maybe Text   -> Vk.ImageAspectFlags-  -> "image dimensions" ::: Vk.Extent2D+  -> "image dimensions" ::: Vk.Extent3D   -> "mip levels" ::: Word32   -> "stored layers" ::: Word32   -> Vk.SampleCountFlagBits   -> Vk.Format   -> Vk.ImageUsageFlags   -> io AllocatedImage-create context mlabel aspect extent mipLevels numLayers samples format usage = do-  let-    device    = getDevice context-    allocator = getAllocator context+allocate mlabel aspect extent mipLevels numLayers samples format usage = do+  allocator <- asks getAllocator    (image, allocation, _info) <- VMA.createImage     allocator     imageCI     imageAllocationCI-  for_ mlabel \label ->-    Debug.nameObject device image $ encodeUtf8 label <> ".label"+  void $! Resource.register $+    VMA.destroyImage allocator image allocation+  traverse_ (Named.object image) mlabel -  imageView <- Vk.createImageView-    device-    (imageViewCI image)-    Nothing-  for_ mlabel \label ->-    Debug.nameObject device image $ encodeUtf8 label <> ".view"+  imageView <- allocateView image format subr+  traverse_ (Named.object imageView) $ fmap (<> ":view") mlabel    pure AllocatedImage     { aiAllocation = allocation@@ -73,13 +81,18 @@     , aiImageRange = subr     }   where-    Vk.Extent2D{width, height} = extent+    imageType =+      case extent of+        Vk.Extent3D{depth=1} ->+          Vk.IMAGE_TYPE_2D+        _ ->+          Vk.IMAGE_TYPE_3D      imageCI = zero-      { Vk.imageType     = Vk.IMAGE_TYPE_2D+      { Vk.imageType     = imageType       , Vk.flags         = createFlags       , Vk.format        = format-      , Vk.extent        = Vk.Extent3D width height 1+      , Vk.extent        = extent       , Vk.mipLevels     = mipLevels       , Vk.arrayLayers   = numLayers       , Vk.tiling        = Vk.IMAGE_TILING_OPTIMAL@@ -94,45 +107,164 @@       , VMA.requiredFlags = Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT       } -    imageViewCI image = zero+    createFlags =+      case numLayers of+        6 ->+          Vk.IMAGE_CREATE_CUBE_COMPATIBLE_BIT+        _ ->+          zero++    subr = subresource aspect mipLevels numLayers++allocateView+  :: ( MonadVulkan env m+     , MonadResource m+     )+  => Vk.Image+  -> Vk.Format+  -> Vk.ImageSubresourceRange+  -> m Vk.ImageView+allocateView image format subr = do+  device <- asks getDevice+  imageView <- Vk.createImageView+    device+    imageViewCI+    Nothing+  void $! Resource.register $ Vk.destroyImageView device imageView Nothing+  pure imageView++  where+    imageViewCI = zero       { Vk.image            = image-      , Vk.viewType         = viewType+      , Vk.viewType         = guessViewType subr       , Vk.format           = format       , Vk.components       = zero       , Vk.subresourceRange = subr       } -    (createFlags, viewType) =-      case numLayers of-        1 ->-          (zero, Vk.IMAGE_VIEW_TYPE_2D)-        6 ->-          (Vk.IMAGE_CREATE_CUBE_COMPATIBLE_BIT, Vk.IMAGE_VIEW_TYPE_CUBE)-        _ ->-          (zero, Vk.IMAGE_VIEW_TYPE_2D_ARRAY)+-------------------------------------------- -    subr = subresource aspect mipLevels numLayers+newtype DstImage = DstImage AllocatedImage -destroy-  :: ( MonadIO io-     , HasVulkan context+-- | Allocate an image and transition it into TRANSFER_DST_OPTIOMAL+allocateDst+  :: ( MonadVulkan env m+     , MonadResource m      )-  => context+  => Queues Vk.CommandPool+  -> Maybe Text+  -> ("image dimensions" ::: Vk.Extent3D)+  -> ("mip levels" ::: Word32)+  -> ("stored layers" ::: Word32)+  -> Vk.Format+  -> m DstImage+allocateDst pool name extent3d mipLevels numLayers format = do+  ai <- allocate+    name+    Vk.IMAGE_ASPECT_COLOR_BIT+    extent3d+    mipLevels+    numLayers+    Vk.SAMPLE_COUNT_1_BIT+    format+    (Vk.IMAGE_USAGE_SAMPLED_BIT .|. Vk.IMAGE_USAGE_TRANSFER_DST_BIT)++  transitionLayout+    pool+    (aiImage ai)+    mipLevels+    numLayers -- XXX: arrayLayers is always 0 for now+    format+    Vk.IMAGE_LAYOUT_UNDEFINED+    Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL++  pure $ DstImage ai++copyBufferToDst+  :: ( MonadVulkan env m+     , Integral deviceSize+     , Foldable t+     )+  => Queues Vk.CommandPool+  -> Vk.Buffer+  -> DstImage+  -> "mip offsets" ::: t deviceSize+  -> m AllocatedImage+copyBufferToDst pool source (DstImage ai) offsets = do+  copyBufferToImage+    pool+    source+    (aiImage ai)+    (aiExtent ai)+    offsets+    layerCount++  transitionLayout+    pool+    (aiImage ai)+    levelCount+    layerCount -- XXX: arrayLayers is always 0 for now+    (aiFormat ai)+    Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL+    Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL++  pure ai+  where+    Vk.ImageSubresourceRange{layerCount, levelCount} = aiImageRange ai++{-# INLINE updateFromStorable #-}+updateFromStorable+  :: ( Storable a+     , MonadVulkan env m+     , MonadResource m+     )+  => Queues Vk.CommandPool   -> AllocatedImage-  -> io ()-destroy context AllocatedImage{..} = do-  -- traceM "destroyAllocatedImage"-  Vk.destroyImageView (getDevice context) aiImageView Nothing-  VMA.destroyImage (getAllocator context) aiImage aiAllocation+  -> Storable.Vector a+  -> m AllocatedImage+updateFromStorable pools ai update = do+  (_transient, staging) <-+    Buffer.allocateCoherent+      (Just "updateFromStorable:staging")+      Vk.BUFFER_USAGE_TRANSFER_SRC_BIT+      1+      update ---------------------------------------------+  transitionLayout+    pools+    ai.aiImage+    1+    1+    ai.aiFormat+    Vk.IMAGE_LAYOUT_UNDEFINED+    Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL +  copyBufferToImage+    pools+    staging.aBuffer+    ai.aiImage+    (Vk.Extent3D ai.aiExtent.width ai.aiExtent.height 1)+    (Vector.singleton 0 :: Vector Word32) -- offsets+    1++  transitionLayout+    pools+    ai.aiImage+    1+    1+    ai.aiFormat+    Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL+    Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL++  -- logDebug "Updating map texture... done"+  pure ai++{-# INLINE transitionLayout #-} transitionLayout-  :: ( HasVulkan context-     , MonadUnliftIO m+  :: ( MonadVulkan env m+    --  , MonadUnliftIO m      )-  => context-  -> Queues Vk.CommandPool+  => Queues Vk.CommandPool   -> Vk.Image   -> "mip levels" ::: Word32   -> "layer count" ::: Word32@@ -140,7 +272,8 @@   -> "old" ::: Vk.ImageLayout   -> "new" ::: Vk.ImageLayout   -> m ()-transitionLayout ctx pool image mipLevels layerCount format old new =+transitionLayout pool image mipLevels layerCount format old new = do+  ctx <- ask   case (old, new) of     (Vk.IMAGE_LAYOUT_UNDEFINED, Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL) ->       oneshot_ ctx pool qTransfer \buf ->@@ -207,56 +340,22 @@       , Vk.subresourceRange    = subresource aspectMask mipLevels layerCount       } --- imageBarrier cb oldLayout newLayout aspectMask srcStage srcMask dstStage dstMask image mipLevels layerCount =---   Vk.cmdPipelineBarrier---     cb---     srcStage---     dstStage---     zero---     mempty---     mempty---     (Vector.singleton barrier)---   where---     barrier = SomeStruct zero---       { Vk.srcAccessMask       = srcMask---       , Vk.dstAccessMask       = dstMask---       , Vk.oldLayout           = oldLayout---       , Vk.newLayout           = newLayout---       , Vk.srcQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED---       , Vk.dstQueueFamilyIndex = Vk.QUEUE_FAMILY_IGNORED---       , Vk.image               = image---       , Vk.subresourceRange    = subresource aspectMask mipLevels layerCount---       }--subresource-  :: Vk.ImageAspectFlags-  -> "mip levels" ::: Word32-  -> "layer count" ::: Word32-  -> Vk.ImageSubresourceRange-subresource aspectMask mipLevels layerCount = Vk.ImageSubresourceRange-  { aspectMask     = aspectMask-  , baseMipLevel   = 0-  , levelCount     = mipLevels -- XXX: including base-  , baseArrayLayer = 0-  , layerCount     = layerCount-  }-+{-# INLINE copyBufferToImage #-} copyBufferToImage-  :: ( HasVulkan context-     , Foldable t+  :: ( Foldable t      , Integral deviceSize-     , MonadUnliftIO m+     , MonadVulkan env m      )-  => context-  -> Queues Vk.CommandPool+  => Queues Vk.CommandPool   -> Vk.Buffer   -> Vk.Image   -> "base extent" ::: Vk.Extent3D   -> "mip offsets" ::: t deviceSize   -> "layer count" ::: Word32   -> m ()-copyBufferToImage ctx pool src dst Vk.Extent3D{..} mipOffsets layerCount =-  oneshot_ ctx pool qTransfer \cmd ->+copyBufferToImage pools src dst Vk.Extent3D{..} mipOffsets layerCount = do+  context <- ask+  oneshot_ context pools qTransfer \cmd ->     Vk.cmdCopyBufferToImage cmd src dst Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL $       Vector.fromList copyRegions   where@@ -276,6 +375,35 @@         , Vk.imageExtent = Vk.Extent3D             { width  = max 1 $ width `shiftR` mipLevel             , height = max 1 $ height `shiftR` mipLevel-            , depth  = depth+            , depth  = max 1 $ depth `shiftR` mipLevel             }         }++-- * Helpers++{-# INLINEABLE inflateExtent #-}+inflateExtent :: Vk.Extent2D -> Word32 -> Vk.Extent3D+inflateExtent Vk.Extent2D{..} depth = Vk.Extent3D{..}++subresource+  :: Vk.ImageAspectFlags+  -> "mip levels" ::: Word32+  -> "layer count" ::: Word32+  -> Vk.ImageSubresourceRange+subresource aspectMask mipLevels layerCount = Vk.ImageSubresourceRange+  { aspectMask     = aspectMask+  , baseMipLevel   = 0+  , levelCount     = mipLevels -- XXX: including base+  , baseArrayLayer = 0+  , layerCount     = layerCount+  }++guessViewType :: Vk.ImageSubresourceRange -> Vk.ImageViewType+guessViewType Vk.ImageSubresourceRange{layerCount} =+  case layerCount of+    1 ->+      Vk.IMAGE_VIEW_TYPE_2D+    6 ->+      Vk.IMAGE_VIEW_TYPE_CUBE+    _ ->+      Vk.IMAGE_VIEW_TYPE_2D_ARRAY

@@ -27,6 +27,7 @@ import Engine.Vulkan.Types (MonadVulkan, Queues) import Resource.Buffer qualified as Buffer import Resource.Model qualified as Model+import Resource.Region qualified as Region  -- * Format meta @@ -181,18 +182,21 @@   -> FilePath   -> m     ( Resource.ReleaseKey-    , (meta, Storable.Vector nodes, Model.Indexed 'Buffer.Staged Vec3.Packed attrs)+    , ( meta+      , Storable.Vector nodes+      , Model.Indexed 'Buffer.Staged Vec3.Packed attrs+      )     ) loadIndexed pools fp = do   logInfo $ "Loading " <> fromString fp   (meta, nodes, (positions, indices, attrs)) <- loadBlobs fp   logDebug $ displayShow meta -  logDebug $ "Staging " <> fromString fp-  context <- ask-  indexed <- Model.createStaged context pools positions attrs indices-  key <- Resource.register $ Model.destroyIndexed context indexed-  pure (key, (meta, nodes, indexed))+  Region.run do+    logDebug $ "Staging " <> fromString fp+    indexed <- Model.createStaged (Just $ fromString fp) pools positions attrs indices+    Model.registerIndexed_ indexed+    pure (meta, nodes, indexed)  loadBlobs   :: forall attrs env nodes meta m

@@ -1,22 +1,36 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+ module Resource.Model where  import RIO+import GHC.Generics  import Codec.Serialise qualified as CBOR+import Data.Kind (Constraint, Type) import Data.List qualified as List import Data.Vector.Storable qualified as Storable import Foreign (Storable(..))+import Geomancy (Vec2)+import Geomancy.Vec3 qualified as Vec3+import UnliftIO.Resource (MonadResource) import Vulkan.Core10 qualified as Vk -import Engine.Vulkan.Types (HasVulkan(..), Queues(..))+import Engine.Vulkan.Pipeline.Graphics (HasVertexInputBindings(..))+import Engine.Vulkan.Format (HasVkFormat(..))+import Engine.Vulkan.Pipeline.Graphics qualified as Graphics+import Engine.Vulkan.Types (MonadVulkan, Queues(..)) import Resource.Buffer qualified as Buffer  data Indexed storage pos attrs = Indexed-  { iPositions :: Buffer.Allocated storage pos+  { iLabel     :: Maybe Text+  , iPositions :: Buffer.Allocated storage pos   , iAttrs     :: Buffer.Allocated storage attrs   , iIndices   :: Buffer.Allocated storage Word32   } deriving (Show) +type Vertex2d attrs = Vertex Vec2 attrs+type Vertex3d attrs = Vertex Vec3.Packed attrs+ data Vertex pos attrs = Vertex   { vPosition :: pos   , vAttrs    :: attrs@@ -39,11 +53,37 @@     , vAttrs    = inject pos     } +instance+  ( HasVkFormat pos+  , HasVkFormat attrs+  ) =>+  Graphics.HasVertexInputBindings (Vertex pos attrs) where+    vertexInputBindings =+      [ Graphics.vertexFormat @pos+      , Graphics.vertexFormat @attrs+      ]+ class HasVertexBuffers a where   type VertexBuffersOf a   getVertexBuffers :: a -> [Vk.Buffer]   getInstanceCount :: a -> Word32 +  default getVertexBuffers+    :: ( Generic a+       , GHasVertexBuffers (Rep a)+       )+    => a+    -> [Vk.Buffer]+  getVertexBuffers = genericGetVertexBuffers++  default getInstanceCount+    :: ( Generic a+       , GHasVertexBuffers (Rep a)+       )+    => a+    -> Word32+  getInstanceCount = genericGetInstanceCount+ instance HasVertexBuffers () where   type VertexBuffersOf () = () @@ -62,6 +102,39 @@   {-# INLINE getInstanceCount #-}   getInstanceCount = Buffer.aUsed +genericGetVertexBuffers+  :: ( Generic a+     , GHasVertexBuffers (Rep a)+     )+  => a+  -> [Vk.Buffer]+genericGetVertexBuffers = gVertexBuffers . GHC.Generics.from++genericGetInstanceCount+  :: ( Generic a+     , GHasVertexBuffers (Rep a)+     )+  => a+  -> Word32+genericGetInstanceCount = gInstanceCount . GHC.Generics.from++type GHasVertexBuffers :: (Type -> Type) -> Constraint+class GHasVertexBuffers f where+  gVertexBuffers  :: forall a . f a -> [Vk.Buffer]+  gInstanceCount :: forall a . f a -> Word32++instance GHasVertexBuffers f => GHasVertexBuffers (M1 c cb f) where+  gVertexBuffers (M1 f) = gVertexBuffers f+  gInstanceCount (M1 f) = gInstanceCount f++instance (GHasVertexBuffers l, GHasVertexBuffers r) => GHasVertexBuffers (l :*: r) where+  gVertexBuffers (l :*: r) = gVertexBuffers l <> gVertexBuffers r+  gInstanceCount (l :*: r) = min (gInstanceCount l) (gInstanceCount r)++instance HasVertexBuffers a => GHasVertexBuffers (K1 r a) where+  gVertexBuffers (K1 a) = getVertexBuffers a+  gInstanceCount (K1 a) = getInstanceCount a+ data IndexRange = IndexRange   { irFirstIndex :: Word32   , irIndexCount :: Word32@@ -85,13 +158,16 @@     pokeByteOff ptr 4 irIndexCount  createStagedL-  :: (HasVulkan context, Storable pos, Storable attrs, MonadUnliftIO io)-  => context+  :: ( MonadVulkan env m+     , Storable pos+     , Storable attrs+     )+  => Maybe Text   -> Queues Vk.CommandPool   -> [Vertex pos attrs]   -> Maybe [Word32]-  -> io (Indexed 'Buffer.Staged pos attrs)-createStagedL context pool vertices mindices = createStaged context pool pv av iv+  -> m (Indexed 'Buffer.Staged pos attrs)+createStagedL label pool vertices mindices = createStaged label pool pv av iv   where     pv = Storable.fromList ps     av = Storable.fromList as@@ -108,52 +184,72 @@       pure (vPosition, vAttrs)  createStaged-  :: (HasVulkan context, Storable pos, Storable attrs, MonadUnliftIO io)-  => context+  :: ( MonadVulkan env m+     , Storable pos+     , Storable attrs+     )+  => Maybe Text   -> Queues Vk.CommandPool   -> Storable.Vector pos   -> Storable.Vector attrs   -> Storable.Vector Word32-  -> io (Indexed 'Buffer.Staged pos attrs)-createStaged context pool pv av iv = do-  positions <- Buffer.createStaged context pool Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT 0 pv-  attrs     <- Buffer.createStaged context pool Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT 0 av-  indices   <- Buffer.createStaged context pool Vk.BUFFER_USAGE_INDEX_BUFFER_BIT  0 iv+  -> m (Indexed 'Buffer.Staged pos attrs)+createStaged label pool pv av iv = do+  positions <- Buffer.createStaged (label <&> \m -> mappend m ".positions") pool Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT 0 pv+  attrs     <- Buffer.createStaged (label <&> \m -> mappend m ".attrs") pool Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT 0 av+  indices   <- Buffer.createStaged (label <&> \m -> mappend m ".indices") pool Vk.BUFFER_USAGE_INDEX_BUFFER_BIT  0 iv   pure Indexed-    { iPositions = positions+    { iLabel     = label+    , iPositions = positions     , iAttrs     = attrs     , iIndices   = indices     }  createCoherentEmpty-  :: (HasVulkan context, Storable pos, Storable attrs, MonadUnliftIO io)-  => context+  :: ( MonadVulkan env m+     , Storable pos+     , Storable attrs+     )+  => Maybe Text   -> Int-  -> io (Indexed 'Buffer.Coherent pos attrs)-createCoherentEmpty ctx initialSize = Indexed-  <$> Buffer.createCoherent ctx Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT initialSize mempty-  <*> Buffer.createCoherent ctx Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT initialSize mempty-  <*> Buffer.createCoherent ctx Vk.BUFFER_USAGE_INDEX_BUFFER_BIT  initialSize mempty+  -> m (Indexed 'Buffer.Coherent pos attrs)+createCoherentEmpty label initialSize = Indexed label+  <$> Buffer.createCoherent (label <&> \m -> mappend m ".positions") Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT initialSize mempty+  <*> Buffer.createCoherent (label <&> \m -> mappend m ".attrs") Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT initialSize mempty+  <*> Buffer.createCoherent (label <&> \m -> mappend m ".indices") Vk.BUFFER_USAGE_INDEX_BUFFER_BIT  initialSize mempty +registerIndexed_+  :: ( MonadVulkan env m+     , MonadResource m+     )+  => Indexed storage pos attrs+  -> m ()+registerIndexed_ Indexed{..} = do+  void $! Buffer.register iPositions+  void $! Buffer.register iAttrs+  void $! Buffer.register iIndices+ destroyIndexed-  :: (HasVulkan context, MonadUnliftIO io)-  => context-  -> Indexed storage pos attrs-  -> io ()-destroyIndexed ctx Indexed{..} = do-  Buffer.destroyAll ctx [iPositions]-  Buffer.destroyAll ctx [iAttrs]-  Buffer.destroyAll ctx [iIndices]+  :: MonadVulkan env m+  => Indexed storage pos attrs+  -> m ()+destroyIndexed Indexed{..} = do+  ctx <- ask+  Buffer.destroy ctx iPositions+  Buffer.destroy ctx iAttrs+  Buffer.destroy ctx iIndices  updateCoherent-  :: (HasVulkan context, Storable pos, Storable attrs, MonadUnliftIO io)-  => context-  -> [Vertex pos attrs]+  :: ( MonadVulkan env m+     , Storable pos+     , Storable attrs+     )+  => [Vertex pos attrs]   -> Indexed 'Buffer.Coherent pos attrs-  -> io (Indexed 'Buffer.Coherent pos attrs)-updateCoherent ctx vertices old = do+  -> m (Indexed 'Buffer.Coherent pos attrs)+updateCoherent vertices old = do   Indexed{..} <- pick-  Indexed+  Indexed iLabel     <$> Buffer.updateCoherent pv iPositions     <*> Buffer.updateCoherent av iAttrs     <*> Buffer.updateCoherent iv iIndices@@ -162,8 +258,8 @@       if oldSize > newSize then         pure old       else do-        destroyIndexed ctx old-        createCoherentEmpty ctx (max newSize $ oldSize * 2)+        destroyIndexed old+        createCoherentEmpty (iLabel old) (max newSize $ oldSize * 2)      oldSize = Buffer.aCapacity $ iIndices old     newSize = Storable.length pv

@@ -0,0 +1,211 @@+{- | Experimental helpers for managing models with multiple instance buffers.++Only works with fully-coherent models and atomic stores.+Not particularly efficient: when any element is changed, everything gets fully updated.+-}++module Resource.Model.Observer+  ( newCoherent+  , observeCoherent++  , VertexBuffers(..)+  , genericCreateInitial+  , genericDestroyCurrent++  , UpdateCoherent(..)+  , genericUpdateCoherent+  ) where++import RIO+import GHC.Generics++import Control.Monad.Trans.Resource (ResourceT)+import Control.Monad.Trans.Resource qualified as Resource+import Data.Kind (Type)+import Data.Text qualified as Text+import Data.Vector.Storable qualified as Storable+import Vulkan.Core10 qualified as Vk++import Engine.Types ()+import Engine.Vulkan.Types (HasVulkan, MonadVulkan)+import Engine.Worker qualified as Worker+import Resource.Buffer qualified as Buffer++newCoherent+  :: ( VertexBuffers res+     , MonadVulkan env m+     )+  => Int+  -> Text+  -> ResourceT m (Worker.ObserverIO res)+newCoherent initialSize label = do+  initial <- createInitial initialSize label+  observer <- Worker.newObserverIO initial++  context <- ask+  void $! Resource.register do+    current <- Worker.readObservedIO observer+    destroyCurrent context current++  pure observer++observeCoherent+  :: ( MonadVulkan env m+    , Worker.HasOutput output+    , UpdateCoherent bufs (Worker.GetOutput output)+    )+  => output+  -> Worker.ObserverIO bufs+  -> m ()+observeCoherent process observer =+  void $ Worker.observeIO process observer updateCoherent++class VertexBuffers a where+  createInitial :: forall env m . MonadVulkan env m => Int -> Text -> ResourceT m a++  default createInitial+    :: forall env m+    .  ( Generic a+       , GVertexBuffers (Rep a)+       , MonadVulkan env m+       )+    => Int+    -> Text+    -> ResourceT m a+  createInitial = genericCreateInitial++  destroyCurrent :: forall env . HasVulkan env => env -> a -> IO ()+  default destroyCurrent+    :: forall env+    .  ( Generic a+       , GVertexBuffers (Rep a)+       , HasVulkan env+       )+    => env+    -> a+    -> IO ()+  destroyCurrent = genericDestroyCurrent++{- XXX: Terminal instance for generic observable requiring only MonadVulkan.++Initial values can be written post-hoc using `updateCoherent` on observed data.+The more problematic part is using hardcoded usage argument.+This is fine for the main use case of model instance buffers, but makes it unsuitable for other uses.+-}+instance Storable a => VertexBuffers (Buffer.Allocated 'Buffer.Coherent a) where+  createInitial initialCapacity label =+    Buffer.createCoherent+      (Just label)+      Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT+      initialCapacity+      mempty++  destroyCurrent ctx buf = Buffer.destroy ctx buf++genericCreateInitial+  :: ( Generic a+     , GVertexBuffers (Rep a)+     , MonadVulkan env m+     )+  => Int+  -> Text+  -> ResourceT m a+genericCreateInitial size label =+  fmap GHC.Generics.to (gcreate size label)++genericDestroyCurrent+  :: ( Generic a+     , GVertexBuffers (Rep a)+     , HasVulkan env+     )+  => env+  -> a+  -> IO ()+genericDestroyCurrent env = gdestroy env . GHC.Generics.from++class GVertexBuffers (f :: Type -> Type) where+  gcreate :: forall env m a . MonadVulkan env m => Int -> Text -> ResourceT m (f a)+  gdestroy :: forall env a . HasVulkan env => env -> f a -> IO ()++instance GVertexBuffers f => GVertexBuffers (D1 c f) where+  gcreate size label = fmap M1 $ gcreate size label+  gdestroy env (M1 a) = gdestroy env a++instance GVertexBuffers f => GVertexBuffers (C1 c f) where+  gcreate size label = fmap M1 $ gcreate size label+  gdestroy env (M1 a) = gdestroy env a++instance (GVertexBuffers l, GVertexBuffers r) => GVertexBuffers (l :*: r) where+  gcreate size label = (:*:)+    <$> gcreate size label+    <*> gcreate size label+  gdestroy env (l :*: r) =+    gdestroy env r <>+    gdestroy env l++instance (GVertexBuffers f, Selector c) => GVertexBuffers (M1 S c f) where+  gcreate size label =+    fmap M1 $+      gcreate size $+        Text.intercalate "."+          [ label+          , fromString $ selName (undefined :: t c f a)+          ]+  gdestroy env (M1 a) = gdestroy env a++instance VertexBuffers a => GVertexBuffers (K1 r a) where+  gcreate size label = fmap K1 $ createInitial size label+  gdestroy env (K1 a) = destroyCurrent env a++-- TODO: class UpdateStaged bufs stores++class UpdateCoherent bufs stores where+  updateCoherent :: forall env m . MonadVulkan env m => bufs -> stores -> m bufs++  default updateCoherent+    :: forall env m+    .  ( Generic bufs+       , Generic stores+       , GUpdateCoherent (Rep bufs) (Rep stores)+       , MonadVulkan env m+       )+    => bufs+    -> stores+    -> m bufs+  updateCoherent = genericUpdateCoherent++genericUpdateCoherent+  :: ( Generic bufs+      , Generic stores+      , GUpdateCoherent (Rep bufs) (Rep stores)+      , MonadVulkan env m+      )+  => bufs+  -> stores+  -> m bufs+genericUpdateCoherent bufs stores =+  fmap GHC.Generics.to $+    gUpdateCoherent+      (GHC.Generics.from bufs)+      (GHC.Generics.from stores)++instance Storable a => UpdateCoherent (Buffer.Allocated 'Buffer.Coherent a) (Storable.Vector a) where+  updateCoherent = Buffer.updateCoherentResize_++-- TODO: barbies-style update+-- instance (ApplicativeB collection) => UpdateCoherent (collection (Buffer.Allocated 'Buffer.Coherent)) (collection Storable.Vector) where+--   update = bzipWith Buffer.updateCoherentResize_++class GUpdateCoherent (fb :: Type -> Type) (fs :: Type -> Type) where+  gUpdateCoherent :: forall env m b s . MonadVulkan env m => fb b -> fs s -> m (fb b)++instance GUpdateCoherent fb fs => GUpdateCoherent (M1 c cb fb) (M1 c cs fs) where+  gUpdateCoherent (M1 gb) (M1 gs) = fmap M1 $ gUpdateCoherent gb gs++instance (GUpdateCoherent fbl fsl, GUpdateCoherent fbr fsr) => GUpdateCoherent (fbl :*: fbr) (fsl :*: fsr) where+  gUpdateCoherent (bl :*: br) (sl :*: sr) = (:*:)+    <$> gUpdateCoherent bl sl+    <*> gUpdateCoherent br sr++instance UpdateCoherent ba sa => GUpdateCoherent (K1 br ba) (K1 sr sa) where+  gUpdateCoherent (K1 gb) (K1 gs) = fmap K1 $ updateCoherent gb gs

@@ -0,0 +1,44 @@+{-# LANGUAGE DeriveAnyClass #-}++module Resource.Model.Observer.Example where++import RIO++import Control.Monad.Trans.Resource (ResourceT)+import Data.Vector.Storable qualified as Storable++import Engine.Types (HKD, StageRIO)+import Engine.Vulkan.Types (MonadVulkan)+import Engine.Worker qualified as Worker+import Resource.Buffer qualified as Buffer+import Resource.Model.Observer qualified as Observer++data ExampleF f = Example+  { x :: HKD f Float+  , y :: HKD f Float+  }+  deriving (Generic)++type Example = ExampleF Identity+deriving instance Show Example+{- DON'T: instance GStorable Example.++Vertex attributes are packed while GStorable gives something like std140.+-}++type ExampleStores = ExampleF Storable.Vector+deriving instance Show ExampleStores++type ExampleBuffers = ExampleF (Buffer.Allocated 'Buffer.Coherent)+deriving instance Show ExampleBuffers+instance Observer.VertexBuffers ExampleBuffers++instance Observer.UpdateCoherent ExampleBuffers ExampleStores++{-# DEPRECATED new "Just use Observer.newCoherent" #-}+new :: ResourceT (StageRIO st) (Worker.ObserverIO ExampleBuffers)+new = Observer.newCoherent 1 "SomeExample"++{-# DEPRECATED update "Just use Observer.updateCoherent" #-}+update :: MonadVulkan env m => ExampleBuffers -> ExampleStores -> m ExampleBuffers+update = Observer.updateCoherent

@@ -1,4 +1,3 @@- module Resource.Source   ( Source(..)   , load@@ -9,6 +8,7 @@  import Data.FileEmbed qualified import Data.Typeable+import GHC.Records (HasField(..)) import GHC.Stack (withFrozenCallStack) import Language.Haskell.TH.Syntax qualified as TH import Resource.Compressed.Zstd qualified as Zstd@@ -20,6 +20,13 @@   = Bytes     (Maybe Text) ByteString   | BytesZstd (Maybe Text) (Zstd.Compressed ByteString)   | File      (Maybe Text) FilePath++instance HasField "label" Source (Maybe Text) where+  {-# INLINE getField #-}+  getField = \case+    Bytes label _bytes     -> label+    BytesZstd label _bytes -> label+    File label _path       -> label  instance Show Source where   show = \case

@@ -2,7 +2,6 @@  module Resource.Texture   ( Texture(..)-  , destroy    , TextureError(..)     -- * Texture types@@ -12,8 +11,6 @@   , TextureLayers(..)      -- * Utilities-  , allocateCollectionWith-  , allocateTextureWith   , debugNameCollection   , TextureLoader @@ -22,16 +19,20 @@   , imageAllocationCI   , stageBufferCI   , stageAllocationCI++  , withSize2d+  , withSize3d   ) where  import RIO  import Data.Bits ((.|.)) import Data.List qualified as List+import Geomancy (Vec2, vec2) import GHC.Stack (withFrozenCallStack) import GHC.TypeLits (Nat, KnownNat, natVal)+import GHC.Records (HasField(..)) import RIO.FilePath (takeBaseName)-import UnliftIO.Resource qualified as Resource import Vulkan.Core10 qualified as Vk import Vulkan.NamedType ((:::)) import Vulkan.Utils.Debug qualified as Debug@@ -52,7 +53,7 @@  instance Exception TextureError -data Texture a = Texture+data Texture tag = Texture   { tFormat         :: Vk.Format   , tMipLevels      :: Word32   , tLayers         :: Word32 -- ^ Actual number of layers, up to @ArrayOf a@@@ -79,31 +80,8 @@  type TextureLoader m layers = Vk.Format -> Queues Vk.CommandPool -> FilePath -> m (Texture layers) -type TextureLoaderAction src m layers = src -> m (Texture layers)- -- * Allocation wrappers -allocateCollectionWith-  :: (Resource.MonadResource m, MonadVulkan env m, Traversable t)-  => TextureLoaderAction src m layers-  -> t src-  -> m (Resource.ReleaseKey, t (Texture layers))-allocateCollectionWith action collection = do-  res <- traverse (allocateTextureWith action) collection-  key <- Resource.register $-    traverse_ (Resource.release . fst) res-  pure (key, fmap snd res)--allocateTextureWith-  :: (Resource.MonadResource m, MonadVulkan env m)-  => TextureLoaderAction src m layers-  -> src-  -> m (Resource.ReleaseKey, Texture layers)-allocateTextureWith action path = do-  context <- ask-  createTexture <- toIO $ action path-  Resource.allocate createTexture (destroy context)- debugNameCollection   :: ( Traversable t      , MonadVulkan env m@@ -127,10 +105,6 @@  -- * Implementation -destroy :: (MonadIO io, HasVulkan context) => context -> Texture a -> io ()-destroy context Texture{tAllocatedImage} =-  Image.destroy context tAllocatedImage- createImageView   :: (MonadIO io, HasVulkan context)   => context@@ -206,3 +180,30 @@   , VMA.usage         = VMA.MEMORY_USAGE_CPU_TO_GPU   , VMA.requiredFlags = Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT   }++-- * Helpers++{-# INLINE withSize2d #-}+withSize2d :: Num i => (i -> i -> a) -> Texture tag -> a+withSize2d f t =+  f+    (fromIntegral width)+    (fromIntegral height)+  where+    Vk.Extent3D{width, height} =+      Image.aiExtent (tAllocatedImage t)++{-# INLINE withSize3d #-}+withSize3d :: Num i => (i -> i -> i -> a) -> Texture tag -> a+withSize3d f t =+  f+    (fromIntegral width)+    (fromIntegral height)+    (fromIntegral depth)+  where+    Vk.Extent3D{width, height, depth} =+      Image.aiExtent (tAllocatedImage t)++instance HasField "size" (Texture tag) Vec2 where+  {-# INLINE getField #-}+  getField = withSize2d vec2

@@ -12,12 +12,12 @@ import Data.Vector qualified as Vector import Foreign qualified import GHC.Stack (withFrozenCallStack)+import UnliftIO.Resource (MonadResource) import Vulkan.Core10 qualified as Vk import Vulkan.Utils.FromGL qualified as FromGL import VulkanMemoryAllocator qualified as VMA  import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, Queues)-import Resource.Image (AllocatedImage(..)) import Resource.Image qualified as Image import Resource.Source (Source(..)) import Resource.Source qualified as Source@@ -27,6 +27,7 @@ load   :: ( TextureLayers a      , MonadVulkan env m+     , MonadResource m      , MonadThrow m      , HasLogFunc env      , Typeable a@@ -42,6 +43,7 @@ loadBytes   :: ( TextureLayers a      , MonadVulkan env m+     , MonadResource m      , MonadThrow m      , HasLogFunc env      )@@ -60,6 +62,7 @@   :: forall a m env   .  ( TextureLayers a      , MonadVulkan env m+     , MonadResource m      , MonadThrow m      , HasLogFunc env      )@@ -126,28 +129,17 @@   logDebug $ "mipSizes: " <> displayShow mipSizes   logDebug $ "offsets: " <> displayShow offsets -  {- XXX:-    Image created before staging buffer due to `Image.copyBufferToImage`-    issued inside `VMA.withBuffer` bracket.-  -}-  (image, allocation, _info) <- VMA.createImage-    vma-    (Texture.imageCI format extent mipLevels numLayers)-    Texture.imageAllocationCI+  unless (numLayers == textureLayers @a) $+    throwM $ Texture.ArrayError (textureLayers @a) numLayers -  Image.transitionLayout-    context+  dst <- Image.allocateDst     pool-    image+    Nothing -- XXX: Name the whole collection later, tagging source with its index.+    extent     mipLevels-    numLayers -- XXX: arrayLayers is always 0 for now+    numLayers     format-    Vk.IMAGE_LAYOUT_UNDEFINED-    Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL -  unless (numLayers == textureLayers @a) $-    throwM $ Texture.ArrayError (textureLayers @a) numLayers-   VMA.withBuffer vma (Texture.stageBufferCI totalSize) Texture.stageAllocationCI bracket \(staging, stage, stageInfo) -> do     let mipImages = Vector.zip offsets images     Vector.iforM_ mipImages \mipIx (offset, Ktx1.MipLevel{imageSize, arrayElements}) -> do@@ -183,53 +175,15 @@      VMA.flushAllocation vma stage 0 Vk.WHOLE_SIZE -    -- XXX: copying to image while the staging buffer is still alive-    Image.copyBufferToImage-      context+    final <- Image.copyBufferToDst       pool       staging-      image-      extent+      dst       offsets-      numLayers -  -- XXX: staging buffer is gone--  Image.transitionLayout-    context-    pool-    image-    mipLevels-    numLayers -- XXX: arrayLayers is always 0 for now-    format-    Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL-    Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL--  imageView <- Texture.createImageView-    context-    image-    format-    mipLevels-    numLayers--  let-    extent2d =-      let-        Vk.Extent3D{..} = extent-      in-        Vk.Extent2D{..}--    allocatedImage = AllocatedImage-      { aiAllocation = allocation-      , aiExtent     = extent2d-      , aiFormat     = format-      , aiImage      = image-      , aiImageView  = imageView-      , aiImageRange = Image.subresource Vk.IMAGE_ASPECT_COLOR_BIT mipLevels numLayers+    pure Texture+      { tFormat         = format+      , tMipLevels      = mipLevels+      , tLayers         = numLayers+      , tAllocatedImage = final       }-  pure Texture-    { tFormat         = format-    , tMipLevels      = mipLevels-    , tLayers         = numLayers-    , tAllocatedImage = allocatedImage-    }

@@ -0,0 +1,183 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE NoForeignFunctionInterface #-}++module Resource.Texture.Ktx2+  ( load+  , loadBytes+  , loadKtx2+  ) where++import RIO++import Codec.Compression.Zstd.FFI qualified as Zstd+import Codec.Ktx.KeyValue qualified as KeyValue+import Codec.Ktx2.Header qualified as Header+import Codec.Ktx2.Level qualified as Level+import Codec.Ktx2.Read qualified as Read+import Data.Vector qualified as Vector+import Foreign qualified+import GHC.Stack (withFrozenCallStack)+import UnliftIO.Resource (MonadResource)+import Vulkan.Core10 qualified as Vk+import VulkanMemoryAllocator qualified as VMA++import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, Queues)+import Resource.Image qualified as Image+import Resource.Source (Source(..))+import Resource.Source qualified as Source+import Resource.Texture (Texture(..), TextureLayers(..))+import Resource.Texture qualified as Texture++load+  :: ( TextureLayers a+     , MonadVulkan env m+     , MonadResource m+     , MonadThrow m+     , HasLogFunc env+     , Typeable a+     , HasCallStack+     )+  => Queues Vk.CommandPool+  -> Source+  -> m (Texture a)+load pool source =+  withFrozenCallStack $+    case source of+      Source.File label path ->+        -- XXX: the codec has a more efficient loader for files+        loadFile label pool path+      _bytes ->+        Source.load (loadBytes source.label pool) source++loadFile+  :: ( TextureLayers a+     , MonadVulkan env m+     , MonadResource m+     , MonadThrow m+     , HasLogFunc env+     )+  => Maybe Text+  -> Queues Vk.CommandPool+  -> FilePath+  -> m (Texture a)+loadFile label pool path =+  bracket (Read.open path) Read.close $+    loadKtx2 (label <|> Just (fromString path)) pool++loadBytes+  :: ( TextureLayers a+     , MonadVulkan env m+     , MonadResource m+     , MonadThrow m+     , HasLogFunc env+     )+  => Maybe Text+  -> Queues Vk.CommandPool+  -> ByteString+  -> m (Texture a)+loadBytes label pool bytes =+  Read.bytes bytes >>= loadKtx2 label pool++loadKtx2+  :: forall a m env src+  .  ( TextureLayers a+     , MonadVulkan env m+     , MonadResource m+     , MonadThrow m+     , HasLogFunc env+     , Read.ReadChunk src+     , Read.ReadLevel src+     )+  => Maybe Text+  -> Queues Vk.CommandPool+  -> Read.Context src+  -> m (Texture a)+loadKtx2 label pool ktx2@(Read.Context _src header) = do+  logDebug $ displayShow (label, header)++  kvd <- Read.keyValueData ktx2+  logDebug $ displayShow (label, format, extent, numLayers, KeyValue.textual kvd)++  levels <- Read.levels ktx2++  unless (Vector.length levels > 0) $+    throwString "Ktx2 contains no image levels"++  unless (Vector.length levels == fromIntegral header.levelCount) $+    throwString $ "Ktx2 level count mismatch " <> show (Vector.length levels, header.levelCount)++  unless (numLayers == textureLayers @a) $+    throwM $ Texture.ArrayError (textureLayers @a) numLayers++  let+    levelSizes = fmap (fromIntegral . (.uncompressedByteLength)) levels+    totalSize = Vector.sum levelSizes+    offsets = Vector.init $ Vector.scanl' (+) 0 levelSizes++  dst <- Image.allocateDst+    pool+    label+    extent+    (fromIntegral $ Vector.length levels)+    numLayers+    format++  vma <- asks getAllocator+  VMA.withBuffer vma (Texture.stageBufferCI totalSize) Texture.stageAllocationCI bracket \(staging, stage, stageInfo) -> do+    liftIO case header.supercompressionScheme of+      Header.SC_NONE ->+        Vector.forM_ (Vector.zip offsets levels) \(offset, level) ->+          liftIO . Read.levelToPtr ktx2 level $+            Foreign.plusPtr (VMA.mappedData stageInfo) offset++      Header.SC_ZSTANDARD -> do+        let maxSize = Vector.maximum levelSizes+        Foreign.allocaBytesAligned maxSize 16 \src ->+          Vector.forM_ (Vector.zip offsets levels) \(offset, level) -> do+            let expected = fromIntegral level.uncompressedByteLength+            Read.levelToPtr ktx2 level src++            res <-+              Zstd.checkError $+                Zstd.decompress+                  (Foreign.plusPtr (VMA.mappedData stageInfo) offset)+                  expected+                  src+                  (fromIntegral level.byteLength)+            case res of+              Right size | size == expected ->+                pure ()+              Right unexpected ->+                throwString $+                  "Zstd decompressed unexpected amount of bytes: " <> show (unexpected, expected)+              Left err ->+                throwString err++      huh ->+        error $ "Unexpected supercompression scheme: " ++ show huh++    VMA.flushAllocation vma stage 0 Vk.WHOLE_SIZE++    final <- Image.copyBufferToDst+      pool+      staging+      dst+      offsets++    pure Texture+      { tFormat         = format+      , tMipLevels      = header.levelCount+      , tLayers         = numLayers+      , tAllocatedImage = final+      }+  where+    format = Vk.Format (fromIntegral header.vkFormat)++    extent = Vk.Extent3D+      { width = header.pixelWidth+      , height = header.pixelHeight+      , depth = max 1 header.pixelDepth+      }++    -- XXX: can be flat array or a cubemap+    numLayers = max header.faceCount header.layerCount

@@ -0,0 +1,47 @@+module Resource.Vulkan.DescriptorLayout where++import RIO++import Data.Vector qualified as Vector+import Engine.Vulkan.Types (getDevice, MonadVulkan)+import RIO.List qualified as List+import Vulkan.Core10 qualified as Vk+import Vulkan.Core12 qualified as Vk12+import Vulkan.CStruct.Extends (pattern (:&), pattern (::&))+import Vulkan.Zero (zero)++create+  :: MonadVulkan env m+  => Vector [(Vk.DescriptorSetLayoutBinding, Vk12.DescriptorBindingFlags)]+  -> m (Vector Vk.DescriptorSetLayout)+create dsBindings = do+  device <- asks getDevice+  Vector.forM dsBindings \bindsFlags -> do+    let+      (binds, flags) = List.unzip bindsFlags++      setCI =+        zero+          { Vk.bindings = Vector.fromList binds+          }+        ::& zero+          { Vk12.bindingFlags = Vector.fromList flags+          }+        :& ()++    Vk.createDescriptorSetLayout device setCI Nothing++forPipeline+  :: MonadVulkan env m+  => Vector Vk.DescriptorSetLayout+  -> Vector Vk.PushConstantRange+  -> m Vk.PipelineLayout+forPipeline dsLayouts pushConstantRanges = do+  device <- asks getDevice+  Vk.createPipelineLayout device layoutCI Nothing+  where+    layoutCI = Vk.PipelineLayoutCreateInfo+      { flags              = zero+      , setLayouts         = dsLayouts+      , pushConstantRanges = pushConstantRanges+      }

@@ -0,0 +1,64 @@+module Resource.Vulkan.DescriptorPool+  ( allocate++  , allocateSetsFrom+  ) where++import RIO++import Data.Vector qualified as Vector+import UnliftIO.Resource (MonadResource, ReleaseKey)+import UnliftIO.Resource qualified as Resource+import Vulkan.Core10 qualified as Vk+import Vulkan.Zero (zero)++import Engine.Vulkan.Types (MonadVulkan, getDevice)+import Resource.Vulkan.Named qualified as Named++allocate+  :: ( MonadVulkan env m+    , MonadResource m+    )+  => Maybe Text+  -> Word32+  -> [(Vk.DescriptorType, Word32)]+  -> m  (ReleaseKey, Vk.DescriptorPool)+allocate name maxSets sizes = do+  device <- asks getDevice+  res <- Vk.withDescriptorPool+    device+    poolCI+    Nothing+    Resource.allocate+  for_ name $+    Named.object (snd res)+  pure res+  where+    poolCI = zero+      { Vk.maxSets =+          maxSets+      , Vk.poolSizes =+          Vector.fromList $+            map (uncurry Vk.DescriptorPoolSize) sizes+      }++-- TODO: extract to Resource.Vulkan.DescriptorSets ?+allocateSetsFrom+  :: MonadVulkan env m+  => Vk.DescriptorPool+  -> Maybe Text+  -> Vector Vk.DescriptorSetLayout+  -> m (Vector Vk.DescriptorSet)+allocateSetsFrom pool name layouts = do+  device <- asks getDevice+  descSets <- Vk.allocateDescriptorSets device zero+    { Vk.descriptorPool = pool+    , Vk.setLayouts     = layouts+    }+  for_ name \prefix ->+    Vector.iforM_ descSets \ix ds ->+      Named.object ds $ mconcat+        [ prefix+        , "(set=", fromString (show ix), ")"+        ]+  pure descSets

@@ -0,0 +1,38 @@+module Resource.Vulkan.Named+  ( object+  , objectOrigin+  ) where++import RIO++import GHC.Stack (callStack, getCallStack, srcLocModule, withFrozenCallStack)+import RIO.List qualified as List+import Vulkan.Core10 qualified as Vk+import Vulkan.Utils.Debug qualified as Debug++import Engine.Vulkan.Types (MonadVulkan, getDevice)++object+  :: ( MonadVulkan env m+    , Vk.HasObjectType a+    )+  => a+  -> Text+  -> m ()+object o name = do+  device <- asks getDevice+  Debug.nameObject device o $+    encodeUtf8 name++objectOrigin+  :: ( MonadVulkan env m+    , Vk.HasObjectType a+    , HasCallStack+    )+  => a+  -> m ()+objectOrigin o =+  withFrozenCallStack $+    object o $+      fromString . List.intercalate "|" $+        map (srcLocModule . snd) (getCallStack callStack)