keid-core 0.1.4.0 → 0.1.5.0

raw patch · 16 files changed

+492/−101 lines, 16 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +18/−0
• README.md +2/−0
• keid-core.cabal +3/−1
• src/Engine/Camera.hs +12/−1
• src/Engine/Frame.hs +1/−1
• src/Engine/Stage/Bootstrap/Setup.hs +5/−0
• src/Engine/Stage/Bootstrap/Types.hs +0/−1
• src/Engine/Types.hs +1/−0
• src/Engine/Vulkan/Pipeline.hs +64/−80
• src/Engine/Vulkan/Pipeline/Compute.hs +157/−0
• src/Engine/Vulkan/Shader.hs +208/−0
• src/Engine/Vulkan/Types.hs +4/−12
• src/Render/Code.hs +4/−0
• src/Render/Pass/Offscreen.hs +0/−3
• src/Resource/Image.hs +6/−2
• src/Resource/Texture/Ktx1.hs +7/−0

@@ -1,5 +1,23 @@ # Changelog for keid-core +## 0.1.5.0++- Removed `allocateRenderpass_` from `RenderPass` class.+- Added `allocateRP` stage field.+- Added `Engine.Vulkan.Pipeline.Compute`.+  * Common shader code extracted to `Engine.Vulkan.Shader`.+- Added shader specialization constants.+  * Graphic and compute pipeline configs extended with `spec` parameter.+  * `Shader.Specialization` class is used to derive vulkan schema at runtime and store values.+- Added `Pipline.Configure` and `Compute.Configure` families to produce a matching `Config` type.+- Added `cDepthCompare` to `Pipeline.Config`.+- Removed `Zero` instance for pipline configs.+  * Use `baseConfig` value for better type inference and less imports.++## 0.1.4.1++- Added size information to `Resource.Image`: `aiExtent`.+ ## 0.1.4.0  - Changed `Render.Samplers.allocate` to use `maxAnisotropy` directly.

@@ -1,1 +1,3 @@ # Keid Engine Core++https://keid.haskell-game.dev

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           keid-core-version:        0.1.4.0+version:        0.1.5.0 synopsis:       Core parts of Keid engine. category:       Game Engine author:         IC Rainbow@@ -46,6 +46,8 @@       Engine.UI.Layout       Engine.Vulkan.DescSets       Engine.Vulkan.Pipeline+      Engine.Vulkan.Pipeline.Compute+      Engine.Vulkan.Shader       Engine.Vulkan.Swapchain       Engine.Vulkan.Types       Engine.Window.CursorPos

@@ -42,11 +42,22 @@   where     -- BUG: infinitePerspective gives huge clipping and effective FoV is different     -- projectionPerspective = Projection.infinitePerspective projectionFovRads width height-    projectionPerspective = Projection.perspective projectionFovRads (1/2048) 16384 width height+    projectionPerspective = Projection.perspective+      projectionFovRads+      PROJECTION_NEAR+      PROJECTION_FAR+      width+      height      projectionOrthoUI = Projection.orthoOffCenter 0 1 width height      Vk.Extent2D{width, height} = projectionScreen++pattern PROJECTION_NEAR :: (Eq a, Num a, Fractional a) => a+pattern PROJECTION_NEAR = 0x0.02 -- i.e. 1/2048++pattern PROJECTION_FAR :: (Eq a, Num a) => a+pattern PROJECTION_FAR = 16384  -- * View 

@@ -73,7 +73,7 @@     void $! ResourceT.allocate_ debugAlloc debugRelease      -- For each render pass:-    sfRenderpass <- allocateRenderpass_ sfSwapchainResources+    sfRenderpass <- sAllocateRP sfSwapchainResources      -- TODO: Recreate this if the swapchain format changes     sfPipelines <- sAllocateP sfSwapchainResources sfRenderpass

@@ -30,6 +30,7 @@ bootstrapStage handoff action = Engine.Stage   { sTitle = "Bootstrap" +  , sAllocateRP = noRendering   , sAllocateP  = noPipelines   , sInitialRS  = transitState handoff action   , sInitialRR  = noFrameResources@@ -39,6 +40,10 @@   , sRecordCommands = noCommands   , sAfterLoop      = pure   }++noRendering :: swapchain -> ResourceT (StageRIO st) NoRendering+noRendering _swapchain =+  pure NoRendering  noPipelines :: swapchain -> NoRendering -> ResourceT (StageRIO st) NoPipelines noPipelines _swapchain NoRendering =

@@ -15,7 +15,6 @@ data NoRendering = NoRendering  instance RenderPass NoRendering where-  allocateRenderpass_ _context = pure NoRendering   updateRenderpass _context = pure   refcountRenderpass _rp = pure () 

@@ -101,6 +101,7 @@ data Stage rp p rr st = forall a . Stage   { sTitle :: Text +  , sAllocateRP :: SwapchainResources -> ResourceT (StageRIO st) rp   , sAllocateP  :: SwapchainResources -> rp -> ResourceT (StageRIO st) p   , sInitialRS  :: StageRIO (Maybe SwapchainResources) (ReleaseKey, st)   , sInitialRR  :: Vulkan.Queues Vk.CommandPool -> rp -> p -> ResourceT (StageRIO st) rr

@@ -1,10 +1,19 @@ -- XXX: TypeError in Compatible generates unused constraint argument {-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# LANGUAGE OverloadedLists #-}+ module Engine.Vulkan.Pipeline-  ( Pipeline(..)-  , Config(..)+  ( Config(..)+  , baseConfig++  , Configure++  , Pipeline(..)   , allocate+  , create+  , destroy+   , bind    , pushPlaceholder@@ -33,6 +42,7 @@  import Engine.Vulkan.DescSets (Bound(..), Compatible) import Engine.Vulkan.Types (HasVulkan(..), HasRenderPass(..), MonadVulkan, DsBindings, DsLayouts, getPipelineCache)+import Engine.Vulkan.Shader qualified as Shader  data Pipeline (dsl :: [Type]) vertices instances = Pipeline   { pipeline     :: Vk.Pipeline@@ -42,7 +52,10 @@  -- * Pipeline -data Config (dsl :: [Type]) vertices instances = Config+type family Configure pipeline spec where+  Configure (Pipeline dsl vertices instances) spec = Config dsl vertices instances spec++data Config (dsl :: [Type]) vertices instances spec = Config   { cVertexCode         :: Maybe ByteString   , cFragmentCode       :: Maybe ByteString   , cVertexInput        :: SomeStruct Vk.PipelineVertexInputStateCreateInfo@@ -51,25 +64,30 @@   , cBlend              :: Bool   , cDepthWrite         :: Bool   , cDepthTest          :: Bool+  , cDepthCompare       :: Vk.CompareOp   , cTopology           :: Vk.PrimitiveTopology   , cCull               :: Vk.CullModeFlagBits   , cDepthBias          :: Maybe ("constant" ::: Float, "slope" ::: Float)+  , cSpecialization     :: spec   } -instance Zero (Config dsl vertices instances) where-  zero = Config-    { cVertexCode         = Nothing-    , cFragmentCode       = Nothing-    , cVertexInput        = zero-    , cDescLayouts        = Tagged [] -- FIXME: unsafe wrt. "dsl"-    , cPushConstantRanges = mempty-    , cBlend              = False-    , cDepthWrite         = True-    , cDepthTest          = True-    , cTopology           = Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST-    , cCull               = Vk.CULL_MODE_BACK_BIT-    , cDepthBias          = Nothing-    }+-- | Settings for generic triangle-rendering pipeline.+baseConfig :: Config '[] vertices instances ()+baseConfig = Config+  { cVertexCode         = Nothing+  , cFragmentCode       = Nothing+  , cVertexInput        = zero+  , cDescLayouts        = Tagged []+  , cPushConstantRanges = mempty+  , cBlend              = False+  , cDepthWrite         = True+  , cDepthTest          = True+  , cDepthCompare       = Vk.COMPARE_OP_LESS+  , cTopology           = Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_LIST+  , cCull               = Vk.CULL_MODE_BACK_BIT+  , cDepthBias          = Nothing+  , cSpecialization     = ()+  }  -- XXX: consider using instance attrs or uniforms pushPlaceholder :: Vk.PushConstantRange@@ -86,11 +104,12 @@   :: ( MonadVulkan env m      , MonadResource m      , HasRenderPass renderpass+     , Shader.Specialization spec      , HasCallStack      )   => Maybe Vk.Extent2D   -> Vk.SampleCountFlagBits-  -> Config dsl vertices instances+  -> Config dsl vertices instances spec   -> renderpass   -> m (ReleaseKey, Pipeline dsl vertices instances) allocate extent msaa config renderpass = withFrozenCallStack do@@ -100,12 +119,17 @@     (destroy ctx)  create-  :: (MonadIO io, HasVulkan ctx, HasRenderPass renderpass, HasCallStack)+  :: ( MonadUnliftIO io+     , HasVulkan ctx+     , HasRenderPass renderpass+     , Shader.Specialization spec+     , HasCallStack+     )   => ctx   -> Maybe Vk.Extent2D   -> Vk.SampleCountFlagBits   -> renderpass-  -> Config dsl vertices instances+  -> Config dsl vertices instances spec   -> io (Pipeline dsl vertices instances) create context mextent msaa renderpass Config{..} = do   let@@ -132,35 +156,35 @@   layout <- Vk.createPipelineLayout device (layoutCI dsLayouts) Nothing   Debug.nameObject device layout originModule -  let-    codeStages = Vector.fromList $ case (cVertexCode, cFragmentCode) of-      (Just vertCode, Just fragCode) ->-        [ (Vk.SHADER_STAGE_VERTEX_BIT, vertCode)-        , (Vk.SHADER_STAGE_FRAGMENT_BIT, fragCode)-        ]+  shader <- Shader.withSpecialization cSpecialization $+    Shader.create context $+      case (cVertexCode, cFragmentCode) of+        (Just vertCode, Just fragCode) ->+          [ (Vk.SHADER_STAGE_VERTEX_BIT, vertCode)+          , (Vk.SHADER_STAGE_FRAGMENT_BIT, fragCode)+          ] -      (Just vertCode, Nothing) ->-        [ (Vk.SHADER_STAGE_VERTEX_BIT, vertCode)-        ]+        (Just vertCode, Nothing) ->+          [ (Vk.SHADER_STAGE_VERTEX_BIT, vertCode)+          ] -      (Nothing, Just fragCode) ->-        -- XXX: good luck-        [ (Vk.SHADER_STAGE_FRAGMENT_BIT, fragCode)-        ]+        (Nothing, Just fragCode) ->+          -- XXX: good luck+          [ (Vk.SHADER_STAGE_FRAGMENT_BIT, fragCode)+          ] -      (Nothing, Nothing) ->-        []-  shader <- createShader context codeStages+        (Nothing, Nothing) ->+          []    let     cis = Vector.singleton . SomeStruct $-      pipelineCI (sPipelineStages shader) layout+      pipelineCI (Shader.sPipelineStages shader) layout    Vk.createGraphicsPipelines device cache cis Nothing >>= \case     (Vk.SUCCESS, pipelines) ->       case Vector.toList pipelines of         [one] -> do-          destroyShader context shader+          Shader.destroy context shader           Debug.nameObject device one originModule           pure Pipeline             { pipeline     = one@@ -202,7 +226,7 @@           , Vk.primitiveRestartEnable = restartable           } -        restartable = elem cTopology+        restartable = elem @Set cTopology           [ Vk.PRIMITIVE_TOPOLOGY_LINE_STRIP           , Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_STRIP           , Vk.PRIMITIVE_TOPOLOGY_TRIANGLE_FAN@@ -273,7 +297,7 @@         depthStencilState = zero           { Vk.depthTestEnable       = cDepthTest           , Vk.depthWriteEnable      = cDepthWrite-          , Vk.depthCompareOp        = Vk.COMPARE_OP_LESS+          , Vk.depthCompareOp        = cDepthCompare           , Vk.depthBoundsTestEnable = False           , Vk.minDepthBounds        = 0.0 -- Optional           , Vk.maxDepthBounds        = 1.0 -- Optional@@ -339,46 +363,6 @@         }      attrs = attrBindings $ map snd bindings---- * Shader code--data Shader = Shader-  { sModules        :: Vector Vk.ShaderModule-  , sPipelineStages :: Vector (SomeStruct Vk.PipelineShaderStageCreateInfo)-  }--createShader-  :: (MonadIO io, HasVulkan ctx)-  => ctx-  -> Vector (Vk.ShaderStageFlagBits, ByteString)-  -> io Shader-createShader context stages = do-  staged <- Vector.forM stages \(stage, code) -> do-    module_ <- Vk.createShaderModule-      (getDevice context)-      zero-        { Vk.code = code-        }-      Nothing-    pure-      ( module_-      , SomeStruct zero-          { Vk.stage   = stage-          , Vk.module' = module_-          , Vk.name    = "main"-          -- , Vk.specializationInfo = Nothing-          }-      )-  let (modules, pStages) = Vector.unzip staged-  pure Shader-    { sModules        = modules-    , sPipelineStages = pStages-    }--destroyShader :: (MonadIO io, HasVulkan ctx) => ctx -> Shader -> io ()-destroyShader context Shader{sModules} =-  Vector.forM_ sModules \module_ ->-    Vk.destroyShaderModule (getDevice context) module_ Nothing  -- * Utils 

@@ -0,0 +1,157 @@+{-# LANGUAGE OverloadedLists #-}++-- XXX: TypeError in Compatible generates unused constraint argument+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++module Engine.Vulkan.Pipeline.Compute+  ( Config(..)+  , Configure++  , Pipeline(..)+  , allocate+  , create+  , destroy++  , bind+  , Compute+  ) where++import RIO++import Data.Kind (Type)+import Data.List qualified as List+import Data.Tagged (Tagged(..))+import Data.Vector qualified as Vector+import GHC.Stack (callStack, getCallStack, srcLocModule, 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.Zero (Zero(..))++import Engine.Vulkan.DescSets (Bound(..), Compatible)+import Engine.Vulkan.Types (HasVulkan(..), MonadVulkan, DsBindings, getPipelineCache)++import Engine.Vulkan.Pipeline (Pipeline(..), destroy)+import Engine.Vulkan.Shader qualified as Shader++data Config (dsl :: [Type]) spec = Config+  { cComputeCode        :: ByteString+  , cDescLayouts        :: Tagged dsl [DsBindings]+  , cPushConstantRanges :: Vector Vk.PushConstantRange+  , cSpecialization     :: spec+  }++data Compute++type family Configure pipeline spec where+  Configure (Pipeline dsl Compute Compute) spec = Config dsl spec++allocate+  :: ( MonadVulkan env m+     , MonadResource m+     , HasCallStack+     , Shader.Specialization spec+     )+  => Config dsl spec+  -> m (ReleaseKey, Pipeline dsl Compute Compute)+allocate config = withFrozenCallStack do+  ctx <- ask+  Resource.allocate+    (create ctx config)+    (destroy ctx)++create+  :: ( HasVulkan ctx+     , MonadUnliftIO m+     , Shader.Specialization spec+     )+  => 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++  -- Compute stuff begins...++  shader <- Shader.withSpecialization cSpecialization $+    Shader.create+      context+      [(Vk.SHADER_STAGE_COMPUTE_BIT, cComputeCode)]++  let+    cis = Vector.singleton . SomeStruct $+      pipelineCI (Shader.sPipelineStages shader) layout++  Vk.createComputePipelines device cache cis Nothing >>= \case+    (Vk.SUCCESS, pipelines) ->+      case pipelines of+        [one] -> do+          Shader.destroy context shader+          Debug.nameObject device one originModule+          pure Pipeline+            { pipeline     = one+            , pLayout      = Tagged layout+            , pDescLayouts = Tagged dsLayouts+            }+        _ ->+          error "assert: exactly one pipeline requested"+    (err, _) ->+      throwString $ "createComputePipelines: " <> show err++  where+    device = getDevice context+    cache = getPipelineCache context++    layoutCI dsLayouts = Vk.PipelineLayoutCreateInfo+      { flags              = zero+      , setLayouts         = dsLayouts+      , pushConstantRanges = cPushConstantRanges+      }++    pipelineCI stages layout = zero+      { Vk.layout             = layout+      , Vk.stage              = stage+      , Vk.basePipelineHandle = zero+      }+      where+        stage = case stages of+          [one]   -> one+          _assert -> error "compute code has one stage"++bind+  :: ( Compatible pipeLayout boundLayout+     , MonadIO m+     )+  => Vk.CommandBuffer+  -> Pipeline pipeLayout vertices instances+  -> Bound boundLayout vertices instances m ()+  -> Bound boundLayout oldVertices oldInstances m ()+bind cb Pipeline{pipeline} (Bound attrAction) = do+  Bound $ Vk.cmdBindPipeline cb Vk.PIPELINE_BIND_POINT_COMPUTE pipeline+  Bound attrAction

@@ -0,0 +1,208 @@+{-# OPTIONS_GHC -Wwarn=orphans #-}++{-# LANGUAGE OverloadedLists #-}++module Engine.Vulkan.Shader+  ( Shader(..)+  , create+  , destroy++  , withSpecialization+  , Specialization(..)++  , SpecializationConst(..)+  ) where++import RIO++import Data.Vector qualified as Vector+import Data.Vector.Storable qualified as Storable+import Foreign qualified+import Vulkan.Core10 qualified as Vk+import Vulkan.CStruct.Extends (SomeStruct(..))+import Vulkan.Zero (Zero(..))+import Unsafe.Coerce (unsafeCoerce)++import Engine.Vulkan.Types (HasVulkan(..))++data Shader = Shader+  { sModules        :: Vector Vk.ShaderModule+  , sPipelineStages :: Vector (SomeStruct Vk.PipelineShaderStageCreateInfo)+  }++create+  :: (MonadIO io, HasVulkan ctx)+  => ctx+  -> Vector (Vk.ShaderStageFlagBits, ByteString)+  -> Maybe Vk.SpecializationInfo+  -> io Shader+create context stages spec = do+  staged <- Vector.forM stages \(stage, code) -> do+    module_ <- Vk.createShaderModule+      (getDevice context)+      zero+        { Vk.code = code+        }+      Nothing++    pure+      ( module_+      , SomeStruct zero+          { Vk.stage              = stage+          , Vk.module'            = module_+          , Vk.name               = "main"+          , Vk.specializationInfo = spec+          }+      )+  let (modules, pStages) = Vector.unzip staged+  pure Shader+    { sModules        = modules+    , sPipelineStages = pStages+    }++destroy :: (MonadIO io, HasVulkan ctx) => ctx -> Shader -> io ()+destroy context Shader{sModules} =+  Vector.forM_ sModules \module_ ->+    Vk.destroyShaderModule (getDevice context) module_ Nothing++-- * Specialization constants++withSpecialization+  :: ( Specialization spec+     , MonadUnliftIO m+     )+  => spec+  -> (Maybe Vk.SpecializationInfo -> m a)+  -> m a+withSpecialization spec action =+  case mapEntries of+    [] ->+      action Nothing+    _some ->+      withRunInIO \run ->+        Storable.unsafeWith specData \specPtr ->+          run . action $ Just Vk.SpecializationInfo+            { mapEntries = mapEntries+            , dataSize   = fromIntegral $ Storable.length specData * 4+            , data'      = Foreign.castPtr @_ @() specPtr+            }+  where+    specData = Storable.fromList $ specializationData spec++    mapEntries = Vector.imap+      (\ix _data -> Vk.SpecializationMapEntry+          { constantID = fromIntegral ix+          , offset     = fromIntegral $ ix * 4+          , size       = 4+          }+      )+      (Vector.convert specData)++class Specialization a where+  -- XXX: abusing the fact that most scalars (sans double) are 4-wide+  specializationData :: a -> [Word32]++instance Specialization () where+  specializationData = const []++instance Specialization [Word32] where+  specializationData = id++{- |+  The constant_id can only be applied to a scalar *int*, a scalar *float* or a scalar *bool*.+  (https://github.com/KhronosGroup/GLSL/blob/master/extensions/khr/GL_KHR_vulkan_glsl.txt)++  XXX: Apparently it is possible to pass uints and doubles too.+-}++instance Specialization Word32 where+  specializationData x = [packConstData x]++instance Specialization Int32 where+  specializationData x = [packConstData x]++instance Specialization Float where+  specializationData x = [packConstData x]++instance Specialization Bool where+  specializationData x = [packConstData x]++class SpecializationConst a where+  packConstData :: a -> Word32++instance SpecializationConst Word32 where+  packConstData = id++instance SpecializationConst Int32 where+  packConstData = unsafeCoerce++instance SpecializationConst Float where+  packConstData = unsafeCoerce++instance SpecializationConst Bool where+  packConstData = bool 0 1++instance+  ( SpecializationConst a+  , SpecializationConst b+  ) => Specialization (a, b) where+  specializationData (a, b) =+    [ packConstData a+    , packConstData b+    ]++instance+  ( SpecializationConst a+  , SpecializationConst b+  , SpecializationConst c+  ) => Specialization (a, b, c) where+  specializationData (a, b, c) =+    [ packConstData a+    , packConstData b+    , packConstData c+    ]++instance+  ( SpecializationConst a+  , SpecializationConst b+  , SpecializationConst c+  , SpecializationConst d+  ) => Specialization (a, b, c, d) where+  specializationData (a, b, c, d) =+    [ packConstData a+    , packConstData b+    , packConstData c+    , packConstData d+    ]++instance+  ( SpecializationConst a+  , SpecializationConst b+  , SpecializationConst c+  , SpecializationConst d+  , SpecializationConst e+  ) => Specialization (a, b, c, d, e) where+  specializationData (a, b, c, d, e) =+    [ packConstData a+    , packConstData b+    , packConstData c+    , packConstData d+    , packConstData e+    ]++instance+  ( SpecializationConst a+  , SpecializationConst b+  , SpecializationConst c+  , SpecializationConst d+  , SpecializationConst e+  , SpecializationConst f+  ) => Specialization (a, b, c, d, e, f) where+  specializationData (a, b, c, d, e, f) =+    [ packConstData a+    , packConstData b+    , packConstData c+    , packConstData d+    , packConstData e+    , packConstData f+    ]

@@ -20,7 +20,7 @@  import Data.Kind (Type) import RIO.App (App(..))-import UnliftIO.Resource (MonadResource, ResourceT)+import UnliftIO.Resource (MonadResource) import Vulkan.Core10 qualified as Vk import Vulkan.Core12.Promoted_From_VK_EXT_descriptor_indexing qualified as Vk12 import Vulkan.NamedType ((:::))@@ -99,24 +99,16 @@   getRenderArea          :: a -> Vk.Rect2D  class RenderPass a where-  allocateRenderpass_-    :: ( HasLogFunc env-       , HasSwapchain context-       , HasVulkan env-       , MonadResource (RIO env)-       )-    => context-    -> ResourceT (RIO env) a-   updateRenderpass     :: ( HasLogFunc env-       , HasSwapchain context+       , HasSwapchain swapchain        , HasVulkan env        , MonadResource (RIO env)        )-    => context+    => swapchain     -> a     -> RIO env a+  updateRenderpass = const pure    refcountRenderpass     :: MonadResource (RIO env)

@@ -3,6 +3,7 @@ module Render.Code   ( compileVert   , compileFrag+  , compileComp   , glsl   , trimming   , Code(..)@@ -20,6 +21,9 @@  compileFrag :: String -> Q Exp compileFrag = compileShaderQ Nothing "frag" Nothing++compileComp :: String -> Q Exp+compileComp = compileShaderQ Nothing "comp" Nothing  -- | A wrapper to `show` code into `compileShaderQ` vars. newtype Code = Code { unCode :: Text }

@@ -64,9 +64,6 @@   getRenderArea   = oRenderArea  instance RenderPass Offscreen where-  allocateRenderpass_ = error "Don't allocate Offscreen via class"-  updateRenderpass    = error "Don't recreate Offscreen on resize"-   refcountRenderpass = resourceTRefCount . oRelease  colorTexture :: Offscreen -> Texture Flat

@@ -23,6 +23,7 @@  data AllocatedImage = AllocatedImage   { aiAllocation  :: VMA.Allocation+  , aiExtent      :: Vk.Extent2D   , aiFormat      :: Vk.Format   , aiImage       :: Vk.Image   , aiImageView   :: Vk.ImageView@@ -37,14 +38,14 @@   => ctx   -> Maybe Text   -> Vk.ImageAspectFlags-  -> Vk.Extent2D+  -> "image dimensions" ::: Vk.Extent2D   -> "mip levels" ::: Word32   -> "stored layers" ::: Word32   -> Vk.SampleCountFlagBits   -> Vk.Format   -> Vk.ImageUsageFlags   -> io AllocatedImage-create context mlabel aspect Vk.Extent2D{width, height} mipLevels numLayers samples format usage = do+create context mlabel aspect extent mipLevels numLayers samples format usage = do   let     device    = getDevice context     allocator = getAllocator context@@ -65,12 +66,15 @@    pure AllocatedImage     { aiAllocation = allocation+    , aiExtent     = extent     , aiFormat     = format     , aiImage      = image     , aiImageView  = imageView     , aiImageRange = subr     }   where+    Vk.Extent2D{width, height} = extent+     imageCI = zero       { Vk.imageType     = Vk.IMAGE_TYPE_2D       , Vk.flags         = createFlags

@@ -216,8 +216,15 @@     numLayers    let+    extent2d =+      let+        Vk.Extent3D{..} = extent+      in+        Vk.Extent2D{..}+     allocatedImage = AllocatedImage       { aiAllocation = allocation+      , aiExtent     = extent2d       , aiFormat     = format       , aiImage      = image       , aiImageView  = imageView