packages feed

gpu-vulkan (empty) → 0.1.0.137

raw patch · 151 files changed

+8704/−0 lines, 151 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, data-default, gpu-vulkan, gpu-vulkan-middle, hetero-parameter-list, hetero-parameter-list-with-typelevel-tools, language-spir-v, mono-traversable, stm, storable-hetero-list, storable-peek-poke, template-haskell, temporary, text, time, tools-yj, typelevel-tools-yj

Files

+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `try-gpu-vulkan`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Yoshikuni Jujo (c) 2023++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Yoshikuni Jujo nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# try-gpu-vulkan
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ debug/Debug.hs view
@@ -0,0 +1,3 @@+module Debug where++debug = True
+ gpu-vulkan.cabal view
@@ -0,0 +1,242 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:           gpu-vulkan+version:        0.1.0.137+synopsis:       Vulkan library+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/gpu-vulkan#readme>+category:       GPU+homepage:       https://github.com/YoshikuniJujo/gpu-vulkan#readme+bug-reports:    https://github.com/YoshikuniJujo/gpu-vulkan/issues+author:         Yoshikuni Jujo+maintainer:     yoshikuni.jujo@gmail.com+copyright:      2023 Yoshikuni Jujo+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md+data-files:+    th/vkPhysicalDeviceLimits.txt+    th/vkPhysicalDeviceFeatures.txt+    th/vkFormat.txt+    th/vkShaderStageFlagBits.txt++source-repository head+  type: git+  location: https://github.com/YoshikuniJujo/gpu-vulkan++flag debug+  manual: True+  default: False++library+  exposed-modules:+      Gpu.Vulkan+      Gpu.Vulkan.AllocationCallbacks+      Gpu.Vulkan.AllocationCallbacks.Internal+      Gpu.Vulkan.Attachment+      Gpu.Vulkan.Buffer+      Gpu.Vulkan.BufferView+      Gpu.Vulkan.Cmd+      Gpu.Vulkan.ColorComponent+      Gpu.Vulkan.CommandBuffer+      Gpu.Vulkan.CommandPool+      Gpu.Vulkan.Component+      Gpu.Vulkan.Descriptor+      Gpu.Vulkan.DescriptorPool+      Gpu.Vulkan.DescriptorSet+      Gpu.Vulkan.DescriptorSetLayout+      Gpu.Vulkan.DescriptorSetLayout.BindingFlags+      Gpu.Vulkan.Device+      Gpu.Vulkan.Device.Internal+      Gpu.Vulkan.Exception+      Gpu.Vulkan.Fence+      Gpu.Vulkan.Fence.Internal+      Gpu.Vulkan.Framebuffer+      Gpu.Vulkan.Image+      Gpu.Vulkan.Image.Internal+      Gpu.Vulkan.ImageView+      Gpu.Vulkan.Instance+      Gpu.Vulkan.Instance.Internal+      Gpu.Vulkan.Memory+      Gpu.Vulkan.Object+      Gpu.Vulkan.Object.Base+      Gpu.Vulkan.Object.NoAlignment+      Gpu.Vulkan.PhysicalDevice+      Gpu.Vulkan.Pipeline+      Gpu.Vulkan.Pipeline.ColorBlendAttachment+      Gpu.Vulkan.Pipeline.ColorBlendState+      Gpu.Vulkan.Pipeline.Compute+      Gpu.Vulkan.Pipeline.DepthStencilState+      Gpu.Vulkan.Pipeline.DynamicState+      Gpu.Vulkan.Pipeline.Graphics+      Gpu.Vulkan.Pipeline.InputAssemblyState+      Gpu.Vulkan.Pipeline.MultisampleState+      Gpu.Vulkan.Pipeline.RasterizationState+      Gpu.Vulkan.Pipeline.ShaderStage+      Gpu.Vulkan.Pipeline.TessellationState+      Gpu.Vulkan.Pipeline.VertexInputState+      Gpu.Vulkan.Pipeline.ViewportState+      Gpu.Vulkan.PipelineCache+      Gpu.Vulkan.PipelineLayout+      Gpu.Vulkan.PushConstant+      Gpu.Vulkan.Query+      Gpu.Vulkan.QueryPool+      Gpu.Vulkan.Queue+      Gpu.Vulkan.QueueFamily+      Gpu.Vulkan.RenderPass+      Gpu.Vulkan.Sample+      Gpu.Vulkan.Sampler+      Gpu.Vulkan.Semaphore+      Gpu.Vulkan.Semaphore.Internal+      Gpu.Vulkan.ShaderModule+      Gpu.Vulkan.Subpass+      Gpu.Vulkan.TypeEnum+      Gpu.Vulkan.VertexInput+  other-modules:+      Gpu.Vulkan.AllocationCallbacks.Type+      Gpu.Vulkan.Attachment.Enum+      Gpu.Vulkan.Buffer.Enum+      Gpu.Vulkan.Buffer.Internal+      Gpu.Vulkan.Buffer.Type+      Gpu.Vulkan.BufferView.Internal+      Gpu.Vulkan.ColorComponent.Enum+      Gpu.Vulkan.CommandBuffer.Enum+      Gpu.Vulkan.CommandBuffer.Type+      Gpu.Vulkan.CommandPool.Enum+      Gpu.Vulkan.CommandPool.Type+      Gpu.Vulkan.Component.Enum+      Gpu.Vulkan.Descriptor.Enum+      Gpu.Vulkan.Descriptor.Internal+      Gpu.Vulkan.DescriptorPool.Enum+      Gpu.Vulkan.DescriptorPool.Type+      Gpu.Vulkan.DescriptorSet.BindingAndArrayElem+      Gpu.Vulkan.DescriptorSet.BindingAndArrayElem.Buffer+      Gpu.Vulkan.DescriptorSet.Copy+      Gpu.Vulkan.DescriptorSet.Type+      Gpu.Vulkan.DescriptorSet.Write+      Gpu.Vulkan.DescriptorSet.Write.Sources+      Gpu.Vulkan.DescriptorSetLayout.Enum+      Gpu.Vulkan.DescriptorSetLayout.Type+      Gpu.Vulkan.DescriptorSetLayout.UpdateDynamicLengths+      Gpu.Vulkan.Device.Enum+      Gpu.Vulkan.Device.Type+      Gpu.Vulkan.Enum+      Gpu.Vulkan.Exception.Enum+      Gpu.Vulkan.Fence.Enum+      Gpu.Vulkan.Fence.Type+      Gpu.Vulkan.Framebuffer.Enum+      Gpu.Vulkan.Framebuffer.Type+      Gpu.Vulkan.Image.Enum+      Gpu.Vulkan.Image.Type+      Gpu.Vulkan.ImageView.Enum+      Gpu.Vulkan.ImageView.Type+      Gpu.Vulkan.Instance.Type+      Gpu.Vulkan.Internal+      Gpu.Vulkan.Memory.Bind+      Gpu.Vulkan.Memory.Enum+      Gpu.Vulkan.Memory.ImageBuffer+      Gpu.Vulkan.Memory.OffsetSize+      Gpu.Vulkan.Memory.Type+      Gpu.Vulkan.PhysicalDevice.Enum+      Gpu.Vulkan.PhysicalDevice.Struct+      Gpu.Vulkan.Pipeline.Enum+      Gpu.Vulkan.Pipeline.Graphics.Type+      Gpu.Vulkan.Pipeline.ShaderStage.Enum+      Gpu.Vulkan.Pipeline.ShaderStage.Internal+      Gpu.Vulkan.Pipeline.VertexInputState.BindingOffset+      Gpu.Vulkan.Pipeline.VertexInputState.Data.Type.TypeFam+      Gpu.Vulkan.Pipeline.VertexInputState.Data.Type.TypeValMap+      Gpu.Vulkan.Pipeline.VertexInputState.Formattable+      Gpu.Vulkan.Pipeline.VertexInputState.GHC.Generics.TypeFam+      Gpu.Vulkan.Pipeline.VertexInputState.Internal+      Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment+      Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment.Internal+      Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment.TH+      Gpu.Vulkan.PipelineCache.Type+      Gpu.Vulkan.PipelineLayout.Type+      Gpu.Vulkan.PushConstant.Internal+      Gpu.Vulkan.Query.Enum+      Gpu.Vulkan.QueryPool.Type+      Gpu.Vulkan.Queue.Enum+      Gpu.Vulkan.RenderPass.Enum+      Gpu.Vulkan.RenderPass.Internal+      Gpu.Vulkan.RenderPass.Type+      Gpu.Vulkan.Sample.Enum+      Gpu.Vulkan.Sampler.Enum+      Gpu.Vulkan.Sampler.Type+      Gpu.Vulkan.Semaphore.Type+      Gpu.Vulkan.ShaderModule.Internal+      Gpu.Vulkan.Subpass.Enum+      Gpu.Vulkan.TypeEnum.Th+      Gpu.Vulkan.TypeEnum.TypeValues+      Gpu.Vulkan.VertexInput.Internal+      Paths_gpu_vulkan+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , bytestring <1+    , containers <1+    , data-default <1+    , gpu-vulkan-middle <1+    , hetero-parameter-list <1+    , hetero-parameter-list-with-typelevel-tools <1+    , language-spir-v <1+    , mono-traversable <2+    , stm <3+    , storable-hetero-list <1+    , storable-peek-poke <1+    , template-haskell <3+    , temporary <2+    , text <3+    , time <2+    , tools-yj <1+    , typelevel-tools-yj <1+  default-language: Haskell2010+  if flag(debug)+    other-modules:+        Debug+    hs-source-dirs:+        debug+  else+    other-modules:+        Debug+    hs-source-dirs:+        nodebug++test-suite gpu-vulkan-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_gpu_vulkan+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , bytestring <1+    , containers <1+    , data-default <1+    , gpu-vulkan+    , gpu-vulkan-middle <1+    , hetero-parameter-list <1+    , hetero-parameter-list-with-typelevel-tools <1+    , language-spir-v <1+    , mono-traversable <2+    , stm <3+    , storable-hetero-list <1+    , storable-peek-poke <1+    , template-haskell <3+    , temporary <2+    , text <3+    , time <2+    , tools-yj <1+    , typelevel-tools-yj <1+  default-language: Haskell2010
+ nodebug/Debug.hs view
@@ -0,0 +1,3 @@+module Debug where++debug = False
+ src/Gpu/Vulkan.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan (++	-- * INFO++	-- ** ApplicationINfo++	ApplicationInfo(..),+	ApiVersion, makeApiVersion, apiVersion_1_0, apiVersion_1_1,++	-- ** SubmitInfo++	SubmitInfo(..),+	SubmitInfoListToMiddle, SemaphorePipelineStageFlags(..),++	-- * PROPERTIES++	LayerProperties(..),+	FormatProperties(..),++	-- * NAMES++	LayerName(..), layerKhronosValidation,++	-- * PIPELINE VALUES++	-- ** ViewPort++	Viewport, pattern Viewport,+	viewportX, viewportY, viewportWidth, viewportHeight,+	viewportMinDepth, viewportMaxDepth,++	-- ** StencilOpState++	StencilOpState(..),++	-- ** ClearValue++	ClearValue(..), ClearValueListToCore,++	-- *** ClearType++	ClearType(..), ClearColorType(..),++	-- *** ClearColorValue++	-- *** ClearDepthStencilValue++	ClearDepthStencilValue, pattern ClearDepthStencilValue,+	clearDepthStencilValueDepth, clearDepthStencilValueStencil,++	-- * RECT, OFFSET AND EXTENT++	-- ** Rect++	Rect2d, pattern Rect2d, rect2dExtent, rect2dOffset,++	-- ** Offset++	Offset2d, pattern Offset2d, offset2dX, offset2dY,+	Offset3d, pattern Offset3d, offset3dX, offset3dY, offset3dZ,++	-- ** Extent++	Extent2d, pattern Extent2d,+	extent2dWidth, extent2dHeight,++	Extent3d, pattern Extent3d,+	extent3dWidth, extent3dHeight, extent3dDepth,++	-- * OTHERS++	Size(..),++	-- * ENUM++	module Gpu.Vulkan.Enum,++	) where++import Gpu.Vulkan.Internal+import Gpu.Vulkan.Enum
+ src/Gpu/Vulkan/AllocationCallbacks.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.AllocationCallbacks (++	-- * CREATE++	create, Functions, FunctionsInfo(..),++	-- ** Function Types++	FnAllocationFunction, FnReallocationFunction, FnFreeFunction,+	FnInternalAllocationNotification, FnInternalFreeNotification,++	-- *** Size and Alignment++	Size, Alignment,++	-- * APPLY++	apply, A, ToMiddle++	) where++import Gpu.Vulkan.AllocationCallbacks.Internal
+ src/Gpu/Vulkan/AllocationCallbacks/Internal.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.AllocationCallbacks.Internal (++	-- * CREATE++	create, Functions, M.FunctionsInfo(..),++	-- ** Function Types++	M.FnAllocationFunction, M.FnReallocationFunction, M.FnFreeFunction,+	M.FnInternalAllocationNotification, M.FnInternalFreeNotification,++	-- *** Size and Alignment++	M.Size, M.Alignment,++	-- * APPLY++	apply, A, ToMiddle(..)++	) where++import Control.Exception+import Gpu.Vulkan.AllocationCallbacks.Type+import Gpu.Vulkan.AllocationCallbacks.Middle qualified as M++create :: M.FunctionsInfo a -> (forall s . Functions s a -> IO b) -> IO b+create fns f = bracket (M.create fns) M.destroy (f . Functions)
+ src/Gpu/Vulkan/AllocationCallbacks/Type.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.AllocationCallbacks.Type (++	-- * A++	A(..), ToMiddle(..),++	-- * Functions++	Functions(..), apply++	) where++import Foreign.Ptr+import Data.Kind+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry++import Gpu.Vulkan.AllocationCallbacks.Middle qualified as M++newtype A s a = A (M.A a)  deriving Show++class ToMiddle msa where+	type Snd msa :: Maybe Type+	toMiddle :: TPMaybe.M (U2 A) msa -> TPMaybe.M M.A (Snd msa)++instance ToMiddle 'Nothing where+	type Snd 'Nothing = 'Nothing+	toMiddle TPMaybe.N = TPMaybe.N++instance ToMiddle ('Just '(s, a)) where+	type Snd ('Just '(s, a)) = 'Just a+	toMiddle (TPMaybe.J (U2 (A a))) = TPMaybe.J a++newtype Functions s a = Functions { toMiddleFunctions :: M.Functions a }+	deriving Show++apply :: Functions s a -> Ptr a -> A s a+Functions f `apply` p = A $ f `M.apply` p
+ src/Gpu/Vulkan/Attachment.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Attachment (++	-- * DESCRIPTION++	Description(..), DescriptionListToMiddle(..),++	-- * REFERENCE++	M.Reference(..), M.A,++	-- * ENUM++	module Gpu.Vulkan.Attachment.Enum++	) where++import qualified Data.HeteroParList as HeteroParList+import Data.HeteroParList (pattern (:**))++import Gpu.Vulkan.Attachment.Enum++import qualified Gpu.Vulkan.TypeEnum as T+import qualified Gpu.Vulkan.Sample.Enum as Sample+import qualified Gpu.Vulkan.Image.Enum as Image++import Gpu.Vulkan.Attachment.Middle qualified as M++data Description (fmt :: T.Format) = Description {+	descriptionFlags :: DescriptionFlags,+	descriptionSamples :: Sample.CountFlagBits,+	descriptionLoadOp :: LoadOp,+	descriptionStoreOp :: StoreOp,+	descriptionStencilLoadOp :: LoadOp,+	descriptionStencilStoreOp :: StoreOp,+	descriptionInitialLayout :: Image.Layout,+	descriptionFinalLayout :: Image.Layout }+	deriving Show++class DescriptionListToMiddle fmts where+	descriptionListToMiddle ::+		HeteroParList.PL Description fmts -> [M.Description]++instance DescriptionListToMiddle '[] where descriptionListToMiddle HeteroParList.Nil = []++instance (T.FormatToValue fmt, DescriptionListToMiddle fmts) =>+	DescriptionListToMiddle (fmt ': fmts) where+	descriptionListToMiddle (d :** ds) =+		descriptionToMiddle d : descriptionListToMiddle ds++descriptionToMiddle :: forall fmt . T.FormatToValue fmt => Description fmt -> M.Description+descriptionToMiddle Description {+	descriptionFlags = flgs,+	descriptionSamples = smpls,+	descriptionLoadOp = lop,+	descriptionStoreOp = sop,+	descriptionStencilLoadOp = slop,+	descriptionStencilStoreOp = ssop,+	descriptionInitialLayout = ilyt,+	descriptionFinalLayout = flyt+	} = M.Description {+	M.descriptionFlags = flgs,+	M.descriptionFormat = T.formatToValue @fmt,+	M.descriptionSamples = smpls,+	M.descriptionLoadOp = lop,+	M.descriptionStoreOp = sop,+	M.descriptionStencilLoadOp = slop,+	M.descriptionStencilStoreOp = ssop,+	M.descriptionInitialLayout = ilyt,+	M.descriptionFinalLayout = flyt }
+ src/Gpu/Vulkan/Attachment/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Attachment.Enum (module Gpu.Vulkan.Attachment.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Attachment.Enum
+ src/Gpu/Vulkan/Buffer.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE GADTs, TypeFamilies #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Buffer (++	-- * CREATE++	create, B, CreateInfo(..),++	-- ** Buffer Group++	Group, group, create', unsafeDestroy, lookup,++	-- * BINDED++	getMemoryRequirements, Binded, lengthBinded, IndexedForList(..),++	-- * COPY++	MakeCopies, ImageCopy(..), ImageCopyListToMiddle,++	-- * MEMORY BARRIER++	MemoryBarrier(..), MemoryBarrierListToMiddle,++	-- * ENUM++	module Gpu.Vulkan.Buffer.Enum+	+	) where++import Prelude hiding (lookup)+import Gpu.Vulkan.Buffer.Internal+import Gpu.Vulkan.Buffer.Enum
+ src/Gpu/Vulkan/Buffer/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Buffer.Enum (module Gpu.Vulkan.Buffer.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Buffer.Enum
+ src/Gpu/Vulkan/Buffer/Internal.hs view
@@ -0,0 +1,394 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE GADTs, TypeFamilies #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Buffer.Internal (++	-- * CREATE++	create, B, CreateInfo(..),++	-- ** Buffer Group++	Group, group, create', unsafeDestroy, lookup,++	-- * BINDED++	getMemoryRequirements, Binded, lengthBinded,+	IndexedForList(..), indexedListToMiddles, indexedListToMiddle,++	-- * COPY++	MakeCopies(..), CopyInfo,++	-- * IMAGE COPY++	ImageCopy(..), ImageCopyListToMiddle(..),++	-- * MEMORY BARRIER++	MemoryBarrier(..), MemoryBarrierListToMiddle(..)+	+	) where++import Prelude hiding (lookup)+import GHC.TypeLits+import Foreign.Storable.PeekPoke+import Control.Exception+import Gpu.Vulkan.Object qualified as VObj+import Data.Kind+import Data.TypeLevel.Tuple.Uncurry+import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.HeteroParList qualified as HeteroParList+import Data.HeteroParList (pattern (:**))+import Data.Word++import Gpu.Vulkan.Enum hiding (ObjectType)+import Gpu.Vulkan.Buffer.Enum++import qualified Gpu.Vulkan.Middle as C+import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.Device.Middle as Device.M+import qualified Gpu.Vulkan.Memory as Memory+import qualified Gpu.Vulkan.Buffer.Middle as M+import qualified Gpu.Vulkan.Buffer.Middle as C+import qualified Gpu.Vulkan.QueueFamily as QueueFamily+import qualified Gpu.Vulkan.Image as Image.M++import Gpu.Vulkan.Buffer.Type++import Control.Concurrent.STM+import Control.Concurrent.STM.TSem+import Data.Map qualified as Map++data CreateInfo mn objs = CreateInfo {+	createInfoNext :: TMaybe.M mn,+	createInfoFlags :: CreateFlags,+	createInfoLengths :: HeteroParList.PL VObj.Length objs,+	createInfoUsage :: UsageFlags,+	createInfoSharingMode :: SharingMode,+	createInfoQueueFamilyIndices :: [QueueFamily.Index] }++deriving instance+	(Show (TMaybe.M n), Show (HeteroParList.PL VObj.Length objs)) =>+	Show (CreateInfo n objs)++createInfoToMiddle :: VObj.SizeAlignmentList objs =>+	CreateInfo n objs -> M.CreateInfo n+createInfoToMiddle CreateInfo {+	createInfoNext = mnxt,+	createInfoFlags = flgs,+	createInfoLengths = lns,+	createInfoUsage = usg,+	createInfoSharingMode = smd,+	createInfoQueueFamilyIndices = qfis } = M.CreateInfo {+	M.createInfoNext = mnxt,+	M.createInfoFlags = flgs,+	M.createInfoSize = VObj.wholeSize lns,+	M.createInfoUsage = usg,+	M.createInfoSharingMode = smd,+	M.createInfoQueueFamilyIndices = qfis }++create :: (+	WithPoked (TMaybe.M mn),+	VObj.SizeAlignmentList objs, AllocationCallbacks.ToMiddle ma ) =>+	Device.D sd -> CreateInfo mn objs ->+	TPMaybe.M (U2 AllocationCallbacks.A) ma ->+	(forall sb . B sb nm objs -> IO a) -> IO a+create (Device.D dvc) ci (AllocationCallbacks.toMiddle -> mac) f = bracket+	(M.create dvc (createInfoToMiddle ci) mac) (\b -> M.destroy dvc b mac)+	(f . B (createInfoLengths ci))++data Group sd ma s k nm objs = Group (Device.D sd)+	(TPMaybe.M (U2 AllocationCallbacks.A) ma)+	TSem (TVar (Map.Map k (B s nm objs)))++group :: AllocationCallbacks.ToMiddle md =>+	Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) md ->+	(forall s . Group sd md s k nm objs -> IO a) -> IO a+group dvc@(Device.D mdvc) mac@(AllocationCallbacks.toMiddle -> mmac) f = do+	(sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty+	rtn <- f $ Group dvc mac sem m+	((\(B _ mb) -> M.destroy mdvc mb mmac) `mapM_`)+		=<< atomically (readTVar m)+	pure rtn++create' :: (+	Ord k, WithPoked (TMaybe.M mn),+	VObj.SizeAlignmentList objs, AllocationCallbacks.ToMiddle ma ) =>+	Group sd ma sg k nm objs -> k -> CreateInfo mn objs ->+	IO (Either String (B sg nm objs))+create' (Group (Device.D dvc)+	(AllocationCallbacks.toMiddle -> mac) sem bs) k ci = do+	ok <- atomically do+		mx <- (Map.lookup k) <$> readTVar bs+		case mx of+			Nothing -> waitTSem sem >> pure True+			Just _ -> pure False+	if ok+	then do	b <- M.create dvc (createInfoToMiddle ci) mac+		let b' = B (createInfoLengths ci) b+		atomically $ modifyTVar bs (Map.insert k b') >> signalTSem sem+		pure $ Right b'+	else pure . Left $ "Gpu.Vulkan.Buffer.create': The key already exist"++unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) =>+	Group sd ma sg k nm objs -> k -> IO (Either String ())+unsafeDestroy (Group (Device.D mdvc)+	(AllocationCallbacks.toMiddle -> ma) sem bs) k = do+	mb <- atomically do+		mx <- Map.lookup k <$> readTVar bs+		case mx of+			Nothing -> pure Nothing+			Just _ -> waitTSem sem >> pure mx+	case mb of+		Nothing -> pure $ Left "Gpu.Vulkan.Buffer.unsafeDestroy: No such key"+		Just (B _ b) -> do+			M.destroy mdvc b ma+			atomically do+				modifyTVar bs (Map.delete k)+				signalTSem sem+				pure $ Right ()++lookup :: Ord k => Group sd md sg k nm objs -> k -> IO (Maybe (B sg nm objs))+lookup (Group _ _ _sem bs) k = atomically $ Map.lookup k <$> readTVar bs++getMemoryRequirements :: Device.D sd -> B sb nm objs -> IO Memory.Requirements+getMemoryRequirements (Device.D dvc) (B _ b) = M.getMemoryRequirements dvc b++data IndexedForList sm sb nm t onm = forall objs .+	VObj.OffsetOfList t onm objs => IndexedForList (Binded sm sb nm objs)++indexedListToOffset :: forall sm sb nm v onm a . IndexedForList sm sb nm v onm ->+	(forall vs . (Binded sm sb nm vs, Device.M.Size) -> a) -> a+indexedListToOffset (IndexedForList b@(Binded lns _)) f =+	f (b, fst $ VObj.offsetOfList @v @onm lns)++indexedListToMiddle :: IndexedForList sm sb nm v onm -> (M.B, Device.M.Size)+indexedListToMiddle il = indexedListToOffset il \(Binded _ b, sz) -> (b, sz)++indexedListToMiddles ::+	HeteroParList.PL (U5 IndexedForList) smsbvs -> [(M.B, Device.M.Size)]+indexedListToMiddles HeteroParList.Nil = []+indexedListToMiddles (U5 il :** ils) =+	indexedListToMiddle il : indexedListToMiddles ils++class CopyPrefix (area :: [VObj.O]) (src :: [VObj.O]) (dst :: [VObj.O]) where+	copyCheckLengthPrefix ::+		HeteroParList.PL VObj.Length src ->+		HeteroParList.PL VObj.Length dst -> Bool+	copySizePrefix :: Word64 -> HeteroParList.PL VObj.Length src -> Word64++instance CopyPrefix '[] src dst where+	copyCheckLengthPrefix _ _ = True+	copySizePrefix sz _ = sz++instance (+	VObj.SizeAlignment a,+	CopyPrefix as ss ds ) =>+	CopyPrefix (a ': as) (a ': ss) (a ': ds) where+	copyCheckLengthPrefix (s :** ss) (d :** ds) =+		s == d && copyCheckLengthPrefix @as ss ds+	copySizePrefix sz (ln :** lns) = copySizePrefix @as @ss @ds+		(((sz - 1) `div` algn + 1) * algn + fromIntegral (VObj.size ln))+		lns+		where algn = fromIntegral $ VObj.alignment @a++class CopyInfo (area :: [VObj.O]) (is :: Nat) (id :: Nat) (src :: [VObj.O]) (dst :: [VObj.O]) where+	copyCheckLength ::+		HeteroParList.PL VObj.Length src ->+		HeteroParList.PL VObj.Length dst -> Bool+	copySrcOffset :: Word64 -> HeteroParList.PL VObj.Length src -> Word64+	copyDstOffset :: Word64 -> HeteroParList.PL VObj.Length dst -> Word64+	copySize :: HeteroParList.PL VObj.Length src -> Word64++type OT o = VObj.TypeOf o++instance (+	Sizable (VObj.TypeOf a),+	CopyPrefix (a ': as) (a ': ss) (a ': ds) ) => CopyInfo (a ': as) 0 0 (a ': ss) (a ': ds) where+	copyCheckLength = copyCheckLengthPrefix @(a ': as) @(a ': ss) @(a ': ds)+	copySrcOffset ost _ = ((ost - 1) `div` algn + 1) * algn+		where algn = fromIntegral $ alignment' @(OT a)+	copyDstOffset ost _ = ((ost - 1) `div` algn + 1) * algn+		where algn = fromIntegral $ alignment' @(OT a)+	copySize = copySizePrefix @(a ': as) @(a ': ss) @(a ': ds) 0++instance {-# OVERLAPPABLE #-}+	(VObj.SizeAlignment a, CopyInfo (a ': as) 0 (id - 1) (a ': ss) ds) =>+	CopyInfo (a ': as) 0 id (a ': ss) (a ': ds) where+	copyCheckLength ss (_ :** ds) =+		copyCheckLength @(a ': as) @0 @(id - 1) @(a ': ss) @ds ss ds+	copySrcOffset ost lns = copySrcOffset @(a ': as) @0 @(id - 1) @(a ': ss) @ds ost lns+	copyDstOffset ost (ln :** lns) = copyDstOffset @(a ': as) @0 @(id - 1) @(a ': ss)+		(((ost - 1) `div` algn + 1) * algn + fromIntegral (VObj.size ln))+		lns+		where algn = fromIntegral $ VObj.alignment @a+	copySize = copySize @(a ': as) @0 @(id - 1) @(a ': ss) @ds++instance {-# OVERLAPPABLE #-}+	(VObj.SizeAlignment d, CopyInfo (a ': as) 0 id (a ': ss) ds) =>+	CopyInfo (a ': as) 0 id (a ': ss) (d ': ds) where+	copyCheckLength ss (_ :** ds) =+		copyCheckLength @(a ': as) @0 @id @(a ': ss) @ds ss ds+	copySrcOffset ost lns = copySrcOffset @(a ': as) @0 @id @(a ': ss) @ds ost lns+	copyDstOffset ost (ln :** lns) = copyDstOffset @(a ': as) @0 @id @(a ': ss)+		(((ost - 1) `div` algn + 1) * algn + fromIntegral (VObj.size ln))+		lns+		where algn = fromIntegral $ VObj.alignment @d+	copySize = copySize @(a ': as) @0 @id @(a ': ss) @ds++instance {-# OVERLAPPABLE #-}+	(VObj.SizeAlignment a, CopyInfo (a ': as) (is - 1) id ss ds) =>+	CopyInfo (a ': as) is id (a ': ss) ds where+	copyCheckLength (_ :** ss) ds = copyCheckLength @(a ': as) @(is - 1) @id @ss @ds ss ds+	copySrcOffset ost (ln :** lns) = copySrcOffset @(a ': as) @(is - 1) @id @ss @ds+		(((ost - 1) `div` algn + 1) * algn + fromIntegral (VObj.size ln))+		lns+		where algn = fromIntegral $ VObj.alignment @a+	copyDstOffset ost lns = copyDstOffset @(a ': as) @(is - 1) @id @ss ost lns+	copySize (_ :** lns) = copySize @(a ': as) @(is - 1) @id @ss @ds lns++instance {-# OVERLAPPABLE #-}+	(VObj.SizeAlignment s,+	CopyInfo as is id ss ds) =>+	CopyInfo as is id (s ': ss) ds where+	copyCheckLength (_ :** ss) ds = copyCheckLength @as @is @id ss ds+	copySrcOffset ost (ln :** lns) = copySrcOffset @as @is @id @ss @ds+		(((ost - 1) `div` algn + 1) * algn + fromIntegral (VObj.size ln))+		lns+		where algn = fromIntegral (VObj.alignment @s)+	copyDstOffset ost lns = copyDstOffset @as @is @id @ss ost lns+	copySize (_ :** lns) = copySize @as @is @id @ss @ds lns++makeCopy :: forall (as :: [VObj.O]) is id ss ds . CopyInfo as is id ss ds =>+	HeteroParList.PL VObj.Length ss -> HeteroParList.PL VObj.Length ds -> C.Copy+makeCopy src dst+	| copyCheckLength @as @is @id src dst = C.Copy {+		C.copySrcOffset = copySrcOffset @as @is @id @ss @ds 0 src,+		C.copyDstOffset = copyDstOffset @as @is @id @ss @ds 0 dst,+		C.copySize = copySize @as @is @id @ss @ds src }+	| otherwise = error "List lengths are different"++class MakeCopies (cpss :: [([VObj.O], Nat, Nat)]) (ss :: [VObj.O]) (ds :: [VObj.O]) where+	makeCopies ::+		HeteroParList.PL VObj.Length ss ->+		HeteroParList.PL VObj.Length ds -> [C.Copy]++instance MakeCopies '[] ss ds where makeCopies _ _ = []++instance (CopyInfo as is id ss ds, MakeCopies ass ss ds) =>+	MakeCopies ('(as, is, id) ': ass) ss ds where+	makeCopies src dst = makeCopy @as @is @id src dst : makeCopies @ass src dst++{-+offsetSize :: forall v vs . (+	VObj.OffsetRange v vs, VObj.SizeAlignment v,+	VObj.LengthOf v vs ) =>+	HeteroParList.PL VObj.Length vs ->+	Device.M.Size -> (Device.M.Size, Device.M.Size)+offsetSize lns _ = (VObj.offsetNew @v lns, sizeNew @v lns)++sizeNew :: forall v vs . (+	VObj.SizeAlignment v, VObj.LengthOf v vs ) =>+	HeteroParList.PL VObj.Length vs -> Device.M.Size+sizeNew = fromIntegral . VObj.size . VObj.objectLengthOf @v+-}++data MemoryBarrier mn sm sb nm obj = forall objs . (+	VObj.OffsetRange obj objs 0, VObj.LengthOf obj objs ) =>+	MemoryBarrier {+		memoryBarrierNext :: TMaybe.M mn,+		memoryBarrierSrcAccessMask :: AccessFlags,+		memoryBarrierDstAccessMask :: AccessFlags,+		memoryBarrierSrcQueueFamilyIndex :: QueueFamily.Index,+		memoryBarrierDstQueueFamilyIndex :: QueueFamily.Index,+		memoryBarrierBuffer :: Binded sm sb nm objs }++memoryBarrierToMiddle :: forall n sm sb nm obj .+	MemoryBarrier n sm sb nm obj -> M.MemoryBarrier n+memoryBarrierToMiddle MemoryBarrier {+	memoryBarrierNext = mnxt,+	memoryBarrierSrcAccessMask = sam,+	memoryBarrierDstAccessMask = dam,+	memoryBarrierSrcQueueFamilyIndex = sqfi,+	memoryBarrierDstQueueFamilyIndex = dqfi,+	memoryBarrierBuffer = Binded lns b :: Binded sm sb nm objs } =+	M.MemoryBarrier {+		M.memoryBarrierNext = mnxt,+		M.memoryBarrierSrcAccessMask = sam,+		M.memoryBarrierDstAccessMask = dam,+		M.memoryBarrierSrcQueueFamilyIndex = sqfi,+		M.memoryBarrierDstQueueFamilyIndex = dqfi,+		M.memoryBarrierBuffer = b,+		M.memoryBarrierOffset = ost,+		M.memoryBarrierSize = sz }+	where (ost, sz) = VObj.offsetRange @obj @_ @0 0 lns++class MemoryBarrierListToMiddle nsmsbnmobjs where+	memoryBarrierListToMiddle ::+		HeteroParList.PL (U5 MemoryBarrier) nsmsbnmobjs ->+		HeteroParList.PL M.MemoryBarrier (TMapIndex.M0_5 nsmsbnmobjs)++instance MemoryBarrierListToMiddle '[] where+	memoryBarrierListToMiddle HeteroParList.Nil = HeteroParList.Nil++instance MemoryBarrierListToMiddle nsmsbnmobjs =>+	MemoryBarrierListToMiddle ('(mn, sm, sb, nm, obj) ': nsmsbnmobjs) where+	memoryBarrierListToMiddle (U5 mb :** mbs) =+		memoryBarrierToMiddle mb :** memoryBarrierListToMiddle mbs++data ImageCopy img inm = ImageCopy {+	imageCopyImageSubresource :: Image.M.SubresourceLayers,+	imageCopyImageOffset :: C.Offset3d,+	imageCopyImageExtent :: C.Extent3d }+	deriving Show++class ImageCopyListToMiddle algn objs (img :: Type) (inms :: [Symbol]) where+	imageCopyListToMiddle ::+		Binded sm sb nm objs ->+		HeteroParList.PL (ImageCopy img) inms ->+		[M.ImageCopy]++instance ImageCopyListToMiddle algn objs img '[] where+	imageCopyListToMiddle _ HeteroParList.Nil = []++instance (+	VObj.OffsetRange (VObj.Image algn img nm) objs 0,+	VObj.LengthOf (VObj.Image algn img nm) objs,+	ImageCopyListToMiddle algn objs img nms ) =>+	ImageCopyListToMiddle algn objs img (nm ': nms) where+	imageCopyListToMiddle bf (ic :** ics) =+		imageCopyToMiddle @algn @_ @nm bf (ic :: ImageCopy img nm) :+		imageCopyListToMiddle @algn bf ics++imageCopyToMiddle :: forall algn img inm sm sb nm obj objs . (+	obj ~ VObj.Image algn img inm,+	VObj.OffsetRange obj objs 0, VObj.LengthOf obj objs ) =>+	Binded sm sb nm objs -> ImageCopy img inm -> M.ImageCopy+imageCopyToMiddle (Binded lns _) ImageCopy {+	imageCopyImageSubresource = isr,+	imageCopyImageOffset = iost,+	imageCopyImageExtent = iext } = M.ImageCopy {+	M.imageCopyBufferOffset = ost,+	M.imageCopyBufferRowLength = fromIntegral r,+	M.imageCopyBufferImageHeight = fromIntegral h,+	M.imageCopyImageSubresource = isr,+	M.imageCopyImageOffset = iost,+	M.imageCopyImageExtent = iext }+	where+	(ost, _) = VObj.offsetRange @(VObj.Image algn img inm) @_ @0 0 lns+	VObj.LengthImage r _w h _d = VObj.lengthOf @obj lns
+ src/Gpu/Vulkan/Buffer/Type.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Buffer.Type where++import GHC.TypeLits+import Data.Kind+import Data.HeteroParList qualified as HeteroParList++import Gpu.Vulkan.Object qualified as VObj+import Gpu.Vulkan.Buffer.Middle qualified as M++data B s (nm :: Symbol) (objs :: [VObj.O]) =+	B (HeteroParList.PL VObj.Length objs) M.B++deriving instance Show (HeteroParList.PL VObj.Length objs) =>+	Show (B s nm objs)++deriving instance Eq (HeteroParList.PL VObj.Length objs) =>+	Eq (B s nm objs)++data Binded (sm :: Type) (sb :: Type) (nm :: Symbol) (objs :: [VObj.O]) =+	Binded (HeteroParList.PL VObj.Length objs) M.B++lengthBinded :: Binded sm sb nm objs -> HeteroParList.PL VObj.Length objs+lengthBinded (Binded ln _) = ln++deriving instance Show (HeteroParList.PL VObj.Length objs) =>+	Show (Binded sm sb nm objs)++deriving instance Eq (HeteroParList.PL VObj.Length objs) =>+	Eq (Binded sm sb nm objs)
+ src/Gpu/Vulkan/BufferView.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.BufferView (++	-- * CREATE++	create, B, CreateInfo(..), FormatOf,++	-- ** Buffer View Group+	Group, group, create', unsafeDestroy, lookup++	) where++import Prelude hiding (lookup)+import Gpu.Vulkan.BufferView.Internal
+ src/Gpu/Vulkan/BufferView/Internal.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.BufferView.Internal (++	-- * CREATE++	create, B(..), CreateInfo(..), FormatOf,++	-- ** Buffer View Group+	Group, group, create', unsafeDestroy, lookup++	) where++import Prelude hiding (lookup)++import GHC.TypeLits+import Foreign.Storable.PeekPoke+import Control.Concurrent.STM+import Control.Concurrent.STM.TSem+import Control.Exception+import Data.TypeLevel.Tuple.Uncurry+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.Map qualified as Map+import Data.HeteroParList qualified as HeteroParList+import Gpu.Vulkan.Object qualified as VObj++import Gpu.Vulkan.AllocationCallbacks qualified as AllocationCallbacks+import Gpu.Vulkan.AllocationCallbacks.Type qualified as AllocationCallbacks+import Gpu.Vulkan.Device qualified as Device+import Gpu.Vulkan.Device.Type qualified as Device+import Gpu.Vulkan.Device.Middle qualified as Device.M+import Gpu.Vulkan.TypeEnum qualified as TEnum+import Gpu.Vulkan.Buffer.Type qualified as Buffer+import Gpu.Vulkan.BufferView.Middle qualified as M++newtype B s (nm :: Symbol) t = B M.B deriving Show++create :: (+	WithPoked (TMaybe.M mn),+	TEnum.FormatToValue (FormatOf t),+	VObj.OffsetOfList t nm objs,+	AllocationCallbacks.ToMiddle mscc ) =>+	Device.D sd -> CreateInfo mn t nm '(sm, sb, bnm, objs) ->+	TPMaybe.M (U2 AllocationCallbacks.A) mscc ->+	(forall s . B s nm t -> IO a) -> IO a+create (Device.D dvc) ci+	(AllocationCallbacks.toMiddle -> macc) f = bracket+	(M.create dvc (createInfoToMiddle ci) macc)+	(\b -> M.destroy dvc b macc) (f . B)++data CreateInfo mn t (nm :: Symbol) snmobjs = CreateInfo {+	createInfoNext :: TMaybe.M mn,+	createInfoFlags :: M.CreateFlags,+	createInfoBuffer :: U4 Buffer.Binded snmobjs }++createInfoToMiddle :: forall n t nm sm sb bnm objs . (+	TEnum.FormatToValue (FormatOf t),+	VObj.OffsetOfList t nm objs ) =>+	CreateInfo n t nm '(sm, sb, bnm, objs) -> M.CreateInfo n+createInfoToMiddle CreateInfo {+	createInfoNext = mnxt,+	createInfoFlags = flgs,+	createInfoBuffer = U4 (Buffer.Binded lns b) } = M.CreateInfo {+	M.createInfoNext = mnxt,+	M.createInfoFlags = flgs,+	M.createInfoBuffer = b,+	M.createInfoFormat = TEnum.formatToValue @(FormatOf t),+	M.createInfoOffset = ost, M.createInfoRange = rng }+	where+	(ost, rng) = offsetRange @t @nm lns++type family FormatOf t :: TEnum.Format++offsetRange :: forall t nm objs .+	VObj.OffsetOfList t nm objs =>+	HeteroParList.PL VObj.Length objs -> (Device.M.Size, Device.M.Size)+offsetRange = VObj.offsetOfList @t @nm++group :: AllocationCallbacks.ToMiddle ma =>+	Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma ->+	(forall s . Group ma s k nm t -> IO a) -> IO a+group (Device.D mdvc) mac@(AllocationCallbacks.toMiddle -> mmac) f = do+	(sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty+	rtn <- f $ Group mac sem m+	((\(B mb) -> M.destroy mdvc mb mmac) `mapM_`)+		=<< atomically (readTVar m)+	pure rtn++data Group ma s k nm t = Group+	(TPMaybe.M (U2 AllocationCallbacks.A) ma)+	TSem (TVar (Map.Map k (B s nm t)))++create' :: (+	Ord k,+	WithPoked (TMaybe.M mn),+	TEnum.FormatToValue (FormatOf t),+	VObj.OffsetOfList t nm objs,+	AllocationCallbacks.ToMiddle mscc ) =>+	Device.D sd -> Group mscc s k nm t -> k ->+	CreateInfo mn t nm '(sm, sb, bnm, objs) -> IO (Either String (B s nm t))+create' (Device.D dvc)+	(Group (AllocationCallbacks.toMiddle -> mac) sem bs) k ci = do+	ok <- atomically do+		mx <- (Map.lookup k) <$> readTVar bs+		case mx of+			Nothing -> waitTSem sem >> pure True+			Just _ -> pure False+	if ok+	then do	b <- M.create dvc (createInfoToMiddle ci) mac+		let	b' = B b+		atomically $ modifyTVar bs (Map.insert k b') >> signalTSem sem+		pure $ Right b'+	else pure . Left $ "Gpu.Vulkan.BufferView.create': The key already exist"++unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) =>+	Device.D sd -> Group ma sg k nm t -> k -> IO (Either String ())+unsafeDestroy (Device.D mdvc)+	(Group (AllocationCallbacks.toMiddle -> ma) sem bs) k = do+	mb <- atomically do+		mx <- Map.lookup k <$> readTVar bs+		case mx of+			Nothing -> pure Nothing+			Just _ -> waitTSem sem >> pure mx+	case mb of+		Nothing -> pure $ Left "Gp[u.Vulkan.BufferView.unsafeDestroy: No such key"+		Just (B b) -> do+			M.destroy mdvc b ma+			atomically do+				modifyTVar bs (Map.delete k)+				signalTSem sem+				pure $ Right ()++lookup :: Ord k => Group md sg k nm t -> k -> IO (Maybe (B sg nm t))+lookup (Group _ _sem bs) k = atomically $ Map.lookup k <$> readTVar bs
+ src/Gpu/Vulkan/Cmd.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE GADTs, TypeFamilies #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGe StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Cmd (++-- * BEGIN RENDER PASS++beginRenderPass,++-- * DRAW AND DISPATCH++-- ** Draw++bindPipelineGraphics,+bindVertexBuffers, bindIndexBuffer, IsIndex,+draw, drawIndexed,+VertexCount, IndexCount, InstanceCount,+FirstVertex, FirstIndex, FirstInstance,+VertexOffset,++-- ** Dispatch++bindPipelineCompute, dispatch, GroupCountX, GroupCountY, GroupCountZ,++-- * PUSH CONSTANTS AND BIND DESCRIPTOR SETS++pushConstantsGraphics, pushConstantsCompute,+bindDescriptorSetsGraphics, bindDescriptorSetsCompute,+DynamicIndex(..), GetDynamicLength,++-- * COPY BUFFER AND IMAGES++copyBuffer, copyBufferToImage, copyImageToBuffer, blitImage,++-- * MEMORY DEPENDENCY++pipelineBarrier,++-- * QUERY++resetQueryPool,+beginQuery,+writeTimestamp,++-- * OTHERS++LayoutArgListOnlyDynamics++) where++import GHC.TypeNats+import Foreign.Storable.PeekPoke+import Foreign.Storable.HeteroList+import Control.Exception+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.List+import Data.TypeLevel.Tuple.Uncurry+import Data.TypeLevel.Tuple.Index qualified as TIndex+import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex+import qualified Data.HeteroParList as HeteroParList+import Data.HeteroParList (pattern (:**))+import Data.Word+import Data.Int++import Gpu.Vulkan+import Gpu.Vulkan.TypeEnum qualified as T++import qualified Gpu.Vulkan.CommandBuffer as CommandBuffer+import qualified Gpu.Vulkan.CommandBuffer.Type as CommandBuffer.T+import qualified Gpu.Vulkan.Pipeline.Graphics.Type as Pipeline+import qualified Gpu.Vulkan.Pipeline.Compute as Pipeline.Compute+import qualified Gpu.Vulkan.Pipeline.Enum as Pipeline+import qualified Gpu.Vulkan.PipelineLayout.Type as PipelineLayout+import qualified Gpu.Vulkan.DescriptorSet as DescriptorSet+import qualified Gpu.Vulkan.DescriptorSet.Type as DescriptorSet+import qualified Gpu.Vulkan.DescriptorSetLayout.Type as Layout+import qualified Gpu.Vulkan.Buffer.Type as Bffr+import qualified Gpu.Vulkan.Buffer as Bffr+import qualified Gpu.Vulkan.Buffer.Internal as Bffr.I+import qualified Gpu.Vulkan.Image as Image+import qualified Gpu.Vulkan.Image.Internal as Image.I+import qualified Gpu.Vulkan.Image.Type as Image+import qualified Gpu.Vulkan.Image.Middle as Image.M++import qualified Gpu.Vulkan.RenderPass.Internal as RenderPass+import qualified Gpu.Vulkan.Subpass.Enum as Subpass+import qualified Gpu.Vulkan.Cmd.Middle as M++import qualified Gpu.Vulkan.Memory as Memory++import Data.IORef -- for debug++import Gpu.Vulkan.Query.Enum qualified as Query+import Gpu.Vulkan.QueryPool qualified as QueryPool+import Gpu.Vulkan.QueryPool.Type qualified as QueryPool+import Gpu.Vulkan.Query qualified as Query+import Gpu.Vulkan.Object.Base qualified as KObj++beginRenderPass :: (WithPoked (TMaybe.M mn), ClearValueListToCore cts) =>+	CommandBuffer.C scb -> RenderPass.BeginInfo mn sr sf cts ->+	Subpass.Contents -> IO a -> IO a+beginRenderPass (CommandBuffer.T.C cb) bi cnt f = bracket_+	(M.beginRenderPass cb (RenderPass.beginInfoToMiddle bi) cnt)+	(M.endRenderPass cb) f++bindPipelineGraphics :: CommandBuffer.C scb ->+	Pipeline.BindPoint -> Pipeline.G sg vibs vias slbtss ->+	(forall sgb . CommandBuffer.GBinded sgb vibs slbtss -> IO a) -> IO a+bindPipelineGraphics (CommandBuffer.T.C c) bp (Pipeline.G g) f =+	M.bindPipelineGraphics c bp g >> f (CommandBuffer.T.GBinded c)++bindPipelineCompute :: CommandBuffer.C scmdb -> Pipeline.BindPoint ->+	Pipeline.Compute.C scp slbtss ->+	(forall scbnd . CommandBuffer.CBinded scbnd slbtss -> IO a) -> IO a+bindPipelineCompute (CommandBuffer.T.C cb) bp (Pipeline.Compute.C g) f =+	M.bindPipelineCompute cb bp g >> f (CommandBuffer.T.CBinded cb)++draw :: CommandBuffer.GBinded sc vibs slbtss ->+	VertexCount -> InstanceCount -> FirstVertex -> FirstInstance -> IO ()+draw (CommandBuffer.T.GBinded cb) vc ic fv fi = M.draw cb vc ic fv fi++type VertexCount = Word32+type InstanceCount = Word32+type FirstVertex = Word32+type FirstInstance = Word32++drawIndexed :: CommandBuffer.GBinded sc vibs slbtss ->+	IndexCount -> InstanceCount ->+	FirstIndex -> VertexOffset -> FirstInstance -> IO ()+drawIndexed (CommandBuffer.T.GBinded cb) idxc istc fidx vo fist =+	M.drawIndexed cb idxc istc fidx vo fist++type IndexCount = Word32+type FirstIndex = Word32+type VertexOffset = Int32++dispatch :: CommandBuffer.CBinded sc slbtss ->+	GroupCountX -> GroupCountY -> GroupCountZ -> IO ()+dispatch (CommandBuffer.T.CBinded cb) = M.dispatch cb++type GroupCountX = Word32+type GroupCountY = Word32+type GroupCountZ = Word32++bindDescriptorSetsGraphics :: forall sgbnd vibs sl dsls pcs dss dsls' dyns . (+	TMapIndex.M1_2 dss ~ dsls',+	LayoutArgListOnlyDynamics dsls' ~ dyns,+	InfixIndex dsls' dsls, GetDynamicLength dss,+	HeteroParList.ZipListWithC3 KObj.SizeAlignment dyns ) =>+	CommandBuffer.GBinded sgbnd vibs '(sl, dsls, pcs) ->+	Pipeline.BindPoint -> PipelineLayout.P sl dsls pcs ->+	HeteroParList.PL (U2 DescriptorSet.D) dss ->+	HeteroParList.PL3 DynamicIndex dyns -> IO ()+bindDescriptorSetsGraphics+	(CommandBuffer.T.GBinded c) bp (PipelineLayout.P l) dss idxs = do+	lns <- getDynamicLength dss+	let	dosts = concat $ concat <$> getOffsetListNew lns idxs+	M.bindDescriptorSets c bp l+		(fromIntegral $ infixIndex @_ @dsls' @dsls)+		(HeteroParList.toList+			(\(U2 (DescriptorSet.D _ s)) -> s)+			dss)+		dosts++bindDescriptorSetsCompute :: forall scbnd sl dsls pcs dss dsls' dyns . (+	TMapIndex.M1_2 dss ~ dsls',+	LayoutArgListOnlyDynamics dsls' ~ dyns,+	InfixIndex dsls' dsls, GetDynamicLength dss,+	HeteroParList.ZipListWithC3 KObj.SizeAlignment dyns ) =>+	CommandBuffer.CBinded scbnd '(sl, dsls, pcs) ->+	PipelineLayout.P sl dsls pcs ->+	HeteroParList.PL (U2 DescriptorSet.D) dss ->+	HeteroParList.PL3 DynamicIndex dyns -> IO ()+bindDescriptorSetsCompute+	(CommandBuffer.T.CBinded c) (PipelineLayout.P l) dss idxs = do+	lns <- getDynamicLength dss+	let	dosts = concat $ concat <$> getOffsetListNew lns idxs+	M.bindDescriptorSets c Pipeline.BindPointCompute l+		(fromIntegral $ infixIndex @_ @dsls' @dsls)+		(HeteroParList.toList (\(U2 (DescriptorSet.D _ s)) -> s)+			dss)+		dosts++newtype DynamicIndex (obj :: KObj.O) = DynamicIndex Word32 deriving Show+newtype DynamicOffset (obj :: KObj.O) = DynamicOffset Word32 deriving Show++getOffset' :: forall obj . KObj.SizeAlignment obj =>+	KObj.Length obj -> DynamicIndex obj -> Word32+getOffset' ln (DynamicIndex i) = fromIntegral sz * i+	where+	sz = ((KObj.size ln - 1) `div` algn + 1) * algn+	algn = KObj.alignment @obj++getOffsetListNew :: HeteroParList.ZipListWithC3 KObj.SizeAlignment osss =>+		HeteroParList.PL3 KObj.Length osss ->+		HeteroParList.PL3 DynamicIndex osss -> [[[Word32]]]+getOffsetListNew = HeteroParList.zipListWithC3 @KObj.SizeAlignment getOffset'++class GetDynamicLength sspslbtss where+	getDynamicLength ::+		HeteroParList.PL (U2 DescriptorSet.D) sspslbtss ->+		IO (HeteroParList.PL3 KObj.Length+			(LayoutArgListOnlyDynamics (TMapIndex.M1_2 sspslbtss)))++type family LayoutArgListOnlyDynamics las where+	LayoutArgListOnlyDynamics '[] = '[]+	LayoutArgListOnlyDynamics (la ': las) =+		Layout.BindingTypeListBufferOnlyDynamics (TIndex.I1_2 la) ':+			LayoutArgListOnlyDynamics las++instance GetDynamicLength '[] where+	getDynamicLength HeteroParList.Nil = pure HeteroParList.Nil++instance GetDynamicLength spslbtss =>+	GetDynamicLength (slbts ': spslbtss) where+	getDynamicLength (U2 ds :** dss) =+		(:**) <$> getDscSetLengthsNew ds <*> getDynamicLength dss++getDscSetLengthsNew :: DescriptorSet.D s slbts ->+	IO (HeteroParList.PL2 KObj.Length+		(Layout.BindingTypeListBufferOnlyDynamics (TIndex.I1_2 slbts)))+getDscSetLengthsNew (DescriptorSet.D lns _) = readIORef lns++bindVertexBuffers :: forall sg vibs slbtss smsbnmts .+	InfixIndex (TMapIndex.M3_5 smsbnmts) (TMapIndex.M0_2 vibs) =>+	CommandBuffer.GBinded sg vibs slbtss ->+	HeteroParList.PL (U5 Bffr.IndexedForList) smsbnmts -> IO ()+bindVertexBuffers (CommandBuffer.T.GBinded cb) bils = M.bindVertexBuffers+	cb (fromIntegral fb) (Bffr.I.indexedListToMiddles bils)+	where fb = infixIndex @_ @(TMapIndex.M3_5 smsbnmts) @(TMapIndex.M0_2 vibs)++bindIndexBuffer :: forall sg vibs slbtss sm sb nm i onm . IsIndex i =>+	CommandBuffer.GBinded sg vibs slbtss ->+	Bffr.IndexedForList sm sb nm i onm -> IO ()+bindIndexBuffer (CommandBuffer.T.GBinded cb) ib =+	uncurry (M.bindIndexBuffer cb) (Bffr.I.indexedListToMiddle ib) (indexType @i)++class IsIndex a where indexType :: IndexType+instance IsIndex Word16 where indexType = IndexTypeUint16+instance IsIndex Word32 where indexType = IndexTypeUint32++copyBuffer :: forall cpobjss scb sms sbs nms objss smd sbd nmd objsd .+	Bffr.MakeCopies cpobjss objss objsd => CommandBuffer.C scb ->+	Bffr.Binded sms sbs nms objss -> Bffr.Binded smd sbd nmd objsd -> IO ()+copyBuffer (CommandBuffer.T.C cb) (Bffr.Binded lnss s) (Bffr.Binded lnsd d) =+	M.copyBuffer cb s d (Bffr.I.makeCopies @cpobjss lnss lnsd)++pushConstantsGraphics :: forall sss sc vibs sl sbtss pcs ts . (+	T.ShaderStageFlagBitsListToValue sss,+	PokableList ts, InfixOffsetSize ts pcs ) =>+	CommandBuffer.GBinded sc vibs '(sl, sbtss, pcs) ->+	PipelineLayout.P sl sbtss pcs -> HeteroParList.L ts -> IO ()+pushConstantsGraphics (CommandBuffer.T.GBinded cb) (PipelineLayout.P lyt) xs =+	M.pushConstants+		cb lyt (T.shaderStageFlagBitsListToValue @sss) offt xs+		where (fromIntegral -> offt, _) = infixOffsetSize @ts @pcs++pushConstantsCompute :: forall sss sc sl sbtss pcs ts . (+	T.ShaderStageFlagBitsListToValue sss,+	PokableList ts, InfixOffsetSize ts pcs ) =>+	CommandBuffer.CBinded sc '(sl, sbtss, pcs) ->+	PipelineLayout.P sl sbtss pcs -> HeteroParList.L ts -> IO ()+pushConstantsCompute (CommandBuffer.T.CBinded cb) (PipelineLayout.P lyt) xs =+	M.pushConstants+		cb lyt (T.shaderStageFlagBitsListToValue @sss) offt xs+		where (fromIntegral -> offt, _) = infixOffsetSize @ts @pcs++pipelineBarrier :: (+	HeteroParList.ToListWithCCpsM' WithPoked TMaybe.M mbargs,+	HeteroParList.ToListWithCCpsM' WithPoked TMaybe.M+		(TMapIndex.M0_5 bmbargss),+	HeteroParList.ToListWithCCpsM' WithPoked TMaybe.M+		(TMapIndex.M0_5 imbargss),+	Bffr.MemoryBarrierListToMiddle bmbargss,+	Image.MemoryBarrierListToMiddle imbargss ) =>+	CommandBuffer.C scb -> Pipeline.StageFlags -> Pipeline.StageFlags ->+	DependencyFlags -> HeteroParList.PL Memory.Barrier mbargs ->+	HeteroParList.PL (U5 Bffr.MemoryBarrier) bmbargss ->+	HeteroParList.PL (U5 Image.MemoryBarrier) imbargss -> IO ()+pipelineBarrier (CommandBuffer.T.C cb) ssm dsm dfs mbs bmbs imbs =+	M.pipelineBarrier cb ssm dsm dfs mbs+		(Bffr.I.memoryBarrierListToMiddle bmbs)+		(Image.I.memoryBarrierListToMiddle imbs)++copyBufferToImage ::+	forall (algn :: Nat) img inms scb smb sbb bnm objs smi si inm .+	(Bffr.ImageCopyListToMiddle algn objs img inms) =>+	CommandBuffer.C scb -> Bffr.Binded smb sbb bnm objs ->+	Image.Binded smi si inm (KObj.ImageFormat img) -> Image.Layout ->+	HeteroParList.PL (Bffr.ImageCopy img) inms -> IO ()+copyBufferToImage (CommandBuffer.T.C cb)+	bf@(Bffr.Binded _ mbf) (Image.Binded mim) imlyt ics =+	M.copyBufferToImage cb mbf mim imlyt mics+	where mics = Bffr.I.imageCopyListToMiddle @algn bf ics++copyImageToBuffer ::+	forall (algn :: Nat) img inms scb smi si inm smb sbb bnm objs .+	(Bffr.ImageCopyListToMiddle algn objs img inms) =>+	CommandBuffer.C scb  ->+	Image.Binded smi si inm (KObj.ImageFormat img) -> Image.Layout ->+	Bffr.Binded smb sbb bnm objs ->+	HeteroParList.PL (Bffr.ImageCopy img) inms -> IO ()+copyImageToBuffer (CommandBuffer.T.C cb)+	(Image.Binded mim) imlyt bf@(Bffr.Binded _ mbf) ics =+	M.copyImageToBuffer cb mim imlyt mbf mics+	where mics = Bffr.I.imageCopyListToMiddle @algn bf ics++blitImage :: CommandBuffer.C scb ->+	Image.Binded sms sis nms fmts -> Image.Layout ->+	Image.Binded smd sid nmd fmtd -> Image.Layout ->+	[Image.M.Blit] -> Filter -> IO ()+blitImage (CommandBuffer.T.C cb)+	(Image.Binded src) slyt (Image.Binded dst) dlyt blts fltr =+	M.blitImage cb src slyt dst dlyt blts fltr++resetQueryPool :: CommandBuffer.C sc ->+	QueryPool.Q sq tp -> Query.First -> Query.Count -> IO ()+resetQueryPool (CommandBuffer.T.C cb) (QueryPool.Q qp) fq qc =+	M.resetQueryPool cb qp fq qc++beginQuery :: CommandBuffer.C sc ->+	QueryPool.Q sq tp -> Query.Q -> Query.ControlFlags -> IO a -> IO ()+beginQuery (CommandBuffer.T.C cb) (QueryPool.Q qp) i flgs act =+	M.beginQuery cb qp i flgs >> act >> M.endQuery cb qp i++writeTimestamp :: CommandBuffer.C sc -> Pipeline.StageFlagBits ->+	QueryPool.Q sq QueryPool.Timestamp -> Query.Q -> IO ()+writeTimestamp (CommandBuffer.T.C cb) sflgs (QueryPool.Q qp) i =+	M.writeTimestamp cb sflgs qp i
+ src/Gpu/Vulkan/ColorComponent.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.ColorComponent (module Gpu.Vulkan.ColorComponent.Enum) where++import Gpu.Vulkan.ColorComponent.Enum
+ src/Gpu/Vulkan/ColorComponent/Enum.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.ColorComponent.Enum (+	module Gpu.Vulkan.ColorComponent.Enum ) where++import "gpu-vulkan-middle" Gpu.Vulkan.ColorComponent.Enum
+ src/Gpu/Vulkan/CommandBuffer.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.CommandBuffer (++	-- * ALLOCATE++	C, GBinded, CBinded,++	-- ** Type Level List++	allocate, AllocateInfo(..),++	-- ** Value Level List++	allocateList, AllocateInfoList(..),++	-- * BEGIN AND RESET++	begin, reset, M.BeginInfo(..), M.InheritanceInfo(..),++	-- * ENUM++	module Gpu.Vulkan.CommandBuffer.Enum++	) where++import Foreign.Storable.PeekPoke+import Control.Exception+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.List qualified as TLength+import Data.HeteroParList qualified as HeteroParList+import Data.Word++import Gpu.Vulkan.CommandBuffer.Type+import Gpu.Vulkan.CommandBuffer.Enum++import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.CommandPool.Type as CommandPool+import qualified Gpu.Vulkan.CommandBuffer.Middle as M++allocate :: (+	WithPoked (TMaybe.M mn), TLength.Length c, HeteroParList.FromList c ) =>+	Device.D sd -> AllocateInfo mn scp c ->+	(forall scb . HeteroParList.LL (C scb) c -> IO a) -> IO a+allocate (Device.D dvc) ai f = bracket+	(M.allocateCs dvc $ allocateInfoToMiddle ai)+	(M.freeCs dvc+		. (\(CommandPool.C cp) -> cp) $ allocateInfoCommandPool ai)+	(f . HeteroParList.fromList (HeteroParList.Dummy . C))++allocateList :: WithPoked (TMaybe.M mn) =>+	Device.D sd -> AllocateInfoList mn scp ->+	(forall scb . [C scb] -> IO a) -> IO a+allocateList (Device.D dvc) ai f = bracket+	(M.allocateCs dvc $ allocateInfoToMiddleList ai)+	(M.freeCs dvc+		. (\(CommandPool.C cp) -> cp) $ allocateInfoCommandPoolList ai)+	(f . (C <$>))++data AllocateInfo mn scp (c :: [()]) = AllocateInfo {+	allocateInfoNext :: TMaybe.M mn,+	allocateInfoCommandPool :: CommandPool.C scp,+	allocateInfoLevel :: Level }++data AllocateInfoList mn scp = AllocateInfoList {+	allocateInfoNextList :: TMaybe.M mn,+	allocateInfoCommandPoolList :: CommandPool.C scp,+	allocateInfoLevelList :: Level,+	allocateInfoCommandBufferCountList :: Word32 }++deriving instance Show (TMaybe.M mn) => Show (AllocateInfo mn s c)++allocateInfoToMiddle :: forall n s c . TLength.Length c =>+	AllocateInfo n s c -> M.AllocateInfo n+allocateInfoToMiddle AllocateInfo {+	allocateInfoNext = mnxt,+	allocateInfoCommandPool = CommandPool.C cp,+	allocateInfoLevel = lvl } = M.AllocateInfo {+	M.allocateInfoNext = mnxt,+	M.allocateInfoCommandPool = cp,+	M.allocateInfoLevel = lvl,+	M.allocateInfoCommandBufferCount = TLength.length @_ @c }++allocateInfoToMiddleList :: AllocateInfoList n s -> M.AllocateInfo n+allocateInfoToMiddleList AllocateInfoList {+	allocateInfoNextList = mnxt,+	allocateInfoCommandPoolList = CommandPool.C cp,+	allocateInfoLevelList = lvl,+	allocateInfoCommandBufferCountList = c } = M.AllocateInfo {+	M.allocateInfoNext = mnxt,+	M.allocateInfoCommandPool = cp,+	M.allocateInfoLevel = lvl,+	M.allocateInfoCommandBufferCount = c }++begin :: (WithPoked (TMaybe.M mn), WithPoked (TMaybe.M ii)) =>+	C s -> M.BeginInfo mn ii -> IO a -> IO a+begin (C cb) bi act = bracket_ (M.begin cb bi) (M.end cb) act++reset :: C sc -> ResetFlags -> IO ()+reset (C cb) rfs = M.reset cb rfs
+ src/Gpu/Vulkan/CommandBuffer/Enum.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.CommandBuffer.Enum (+	module Gpu.Vulkan.CommandBuffer.Enum ) where++import "gpu-vulkan-middle" Gpu.Vulkan.CommandBuffer.Enum
+ src/Gpu/Vulkan/CommandBuffer/Type.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.CommandBuffer.Type where++import Data.Kind++import Gpu.Vulkan.DescriptorSetLayout.Type qualified as DscStLyt+import Gpu.Vulkan.CommandBuffer.Middle qualified as M++import Gpu.Vulkan.VertexInput qualified as VertexInput++newtype C s = C { unC :: M.C }++newtype GBinded s (vibs :: [(Type, VertexInput.Rate)])+	(largs :: (Type, [(Type, [DscStLyt.BindingType])], [Type])) =+	GBinded { unGBinded :: M.C }++newtype CBinded s+	(largs :: (Type, [(Type, [DscStLyt.BindingType])], [Type])) =+	CBinded { unCBinded :: M.C }
+ src/Gpu/Vulkan/CommandPool.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.CommandPool (++	-- * CREATE++	create, reset, C, M.CreateInfo(..),++	-- * ENUM++	module Gpu.Vulkan.CommandPool.Enum++	) where++import Foreign.Storable.PeekPoke+import Control.Exception+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry++import Gpu.Vulkan.CommandPool.Type++import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.CommandPool.Middle as M+import qualified Gpu.Vulkan.CommandPool.Enum as Enum+import Gpu.Vulkan.CommandPool.Enum++create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle ma) =>+	Device.D sd -> M.CreateInfo mn ->+	TPMaybe.M (U2 AllocationCallbacks.A) ma ->+	(forall s . C s -> IO a) -> IO a+create (Device.D dvc) ci+	(AllocationCallbacks.toMiddle -> macc) f =+	bracket (M.create dvc ci macc) (\c -> M.destroy dvc c macc) (f . C)++reset :: Device.D sd -> C s -> Enum.ResetFlags -> IO ()+reset (Device.D dv) (C c) fs = M.reset dv c fs
+ src/Gpu/Vulkan/CommandPool/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.CommandPool.Enum (module Gpu.Vulkan.CommandPool.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.CommandPool.Enum
+ src/Gpu/Vulkan/CommandPool/Type.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.CommandPool.Type where++import qualified Gpu.Vulkan.CommandPool.Middle as M++newtype C s = C M.C deriving Show
+ src/Gpu/Vulkan/Component.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Component (++	-- * MAPPING++	Mapping(..),++	-- * ENUM++	module Gpu.Vulkan.Component.Enum++	) where++import Gpu.Vulkan.Component.Middle+import Gpu.Vulkan.Component.Enum
+ src/Gpu/Vulkan/Component/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Component.Enum (module Gpu.Vulkan.Component.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Component.Enum
+ src/Gpu/Vulkan/Descriptor.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Descriptor (++	-- * EXTENSION NAME++	indexingExtensionName,++	-- * BUFFER INFO++	BufferInfo(..),++	-- * IMAGE INFO++	ImageInfo(..), ImageInfoNoSampler(..),++	-- * ENUM++	module Gpu.Vulkan.Descriptor.Enum++	) where++import Gpu.Vulkan.Descriptor.Internal+import Gpu.Vulkan.Descriptor.Enum
+ src/Gpu/Vulkan/Descriptor/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Descriptor.Enum (module Gpu.Vulkan.Descriptor.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Descriptor.Enum
+ src/Gpu/Vulkan/Descriptor/Internal.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE GADTs, TypeFamilies #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Descriptor.Internal (++	-- * EXTENSION NAME++	indexingExtensionName,++	-- * BUFFER INFO++	BufferInfo(..), bufferInfoToMiddle,++	-- * IMAGE INFO++	ImageInfo(..), imageInfoToMiddle,+	ImageInfoNoSampler(..), imageInfoNoSamplerToMiddle++	) where++import Gpu.Vulkan.Object qualified as VObj++import qualified Gpu.Vulkan.Buffer as Buffer+import qualified Gpu.Vulkan.Buffer.Type as Buffer+import qualified Gpu.Vulkan.Descriptor.Middle as M++import qualified Gpu.Vulkan.Sampler.Type as Sampler+import qualified Gpu.Vulkan.Image.Enum as Image+import qualified Gpu.Vulkan.ImageView as ImageView+import qualified Gpu.Vulkan.ImageView.Type as ImageView++import Gpu.Vulkan.Sampler.Middle as Sampler.M++import Gpu.Vulkan.PhysicalDevice qualified as PhysicalDevice++indexingExtensionName :: PhysicalDevice.ExtensionName+indexingExtensionName = PhysicalDevice.ExtensionName M.indexingExtensionName++data BufferInfo sm sb nm obj i = forall objs .+	(Show (Buffer.Binded sm sb nm objs), VObj.OffsetRange obj objs i) =>+	BufferInfo (Buffer.Binded sm sb nm objs)++deriving instance Show (BufferInfo sm sb nm obj i)++bufferInfoToMiddle :: forall sb sm nm obj i .+	BufferInfo sm sb nm obj i -> M.BufferInfo+bufferInfoToMiddle (BufferInfo (Buffer.Binded lns b)) = M.BufferInfo {+	M.bufferInfoBuffer = b,+	M.bufferInfoOffset = ost,+	M.bufferInfoRange = rng }+	where (ost, rng) = VObj.offsetRange @obj @_ @i 0 lns++data ImageInfo ss fmt nm si = ImageInfo {+	imageInfoSampler :: Sampler.S ss,+	imageInfoImageView :: ImageView.I fmt nm si,+	imageInfoImageLayout :: Image.Layout }+	deriving Show++imageInfoToMiddle ::+	ImageInfo ss fmt nm si -> M.ImageInfo+imageInfoToMiddle ImageInfo {+	imageInfoSampler = s,+	imageInfoImageView = ImageView.I iv,+	imageInfoImageLayout = lyt } = M.ImageInfo {+	M.imageInfoSampler = Sampler.sToMiddle s,+	M.imageInfoImageView = iv,+	M.imageInfoImageLayout = lyt }++data ImageInfoNoSampler fmt nm si = ImageInfoNoSampler {+	imageInfoNoSamplerImageView :: ImageView.I fmt nm si,+	imageInfoNoSamplerImageLayout :: Image.Layout }+	deriving Show++imageInfoNoSamplerToMiddle ::+	ImageInfoNoSampler fmt nm si -> M.ImageInfo+imageInfoNoSamplerToMiddle ImageInfoNoSampler {+	imageInfoNoSamplerImageView = ImageView.I iv,+	imageInfoNoSamplerImageLayout = lyt } = M.ImageInfo {+	M.imageInfoSampler = Sampler.M.Null,+	M.imageInfoImageView = iv,+	M.imageInfoImageLayout = lyt }
+ src/Gpu/Vulkan/DescriptorPool.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.DescriptorPool (++	-- * CREATE++	create, P, M.CreateInfo(..), M.Size(..),++	-- * ENUM++	module Gpu.Vulkan.DescriptorPool.Enum++	) where++import Foreign.Storable.PeekPoke+import Control.Exception+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry++import Gpu.Vulkan.DescriptorPool.Type+import Gpu.Vulkan.DescriptorPool.Enum++import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.DescriptorPool.Middle as M++create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) =>+	Device.D sd -> M.CreateInfo mn ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . P s -> IO a) -> IO a+create (Device.D dvc) ci+	(AllocationCallbacks.toMiddle -> macc) f =+	bracket (M.create dvc ci macc) (\p -> M.destroy dvc p macc) (f . P)
+ src/Gpu/Vulkan/DescriptorPool/Enum.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.DescriptorPool.Enum (+	module Gpu.Vulkan.DescriptorPool.Enum ) where++import "gpu-vulkan-middle" Gpu.Vulkan.DescriptorPool.Enum
+ src/Gpu/Vulkan/DescriptorPool/Type.hs view
@@ -0,0 +1,5 @@+module Gpu.Vulkan.DescriptorPool.Type where++import qualified Gpu.Vulkan.DescriptorPool.Middle as M++newtype P s = P M.D deriving Show
+ src/Gpu/Vulkan/DescriptorSet.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE GADTs, TypeFamilies #-}+{-# LANGUAGE DataKinds, ConstraintKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.DescriptorSet (++	-- * ALLOCATE++	allocateDs, D, AllocateInfo(..), DListFromMiddle, DefaultDynamicLengths,++	-- ** Descriptor Set Group++	Group, group, allocateDs', unsafeFreeDs, lookup,++	-- * UPDATE++	updateDs,++	-- ** Write++	W.Write(..), W.WriteListToMiddle,+	W.WriteListUpdateDynamicLengths, W.UpdateDynamicLength,+	W.WriteSources(..), W.WriteSourcesArg(..),+	W.WriteSourcesToMiddle,++	-- ** Copy++	Copy(..), CopyListToMiddle,++	-- ** BindingAndArrayElem++	BindingAndArrayElem, W.BindingAndArrayElemImage,+	W.BindingAndArrayElemImageWithImmutableSampler,+	W.BindingAndArrayElemBuffer, W.BindingAndArrayElemBufferView++	) where++import Prelude hiding (lookup)++import Foreign.Storable.PeekPoke+import Data.Default+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.Tuple.Uncurry+import Data.TypeLevel.Tuple.Index qualified as TIndex+import qualified Data.HeteroParList as HeteroParList+import Data.HeteroParList (pattern (:**))++import Gpu.Vulkan.DescriptorSet.Type++import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.DescriptorPool.Type as Descriptor.Pool+import qualified Gpu.Vulkan.DescriptorSetLayout.Type as Layout+import qualified Gpu.Vulkan.DescriptorSetLayout.Middle as Layout.M+import qualified Gpu.Vulkan.DescriptorSet.Write as W+import qualified Gpu.Vulkan.DescriptorSet.Middle as M++import Gpu.Vulkan.DescriptorSet.Copy++import Gpu.Vulkan.Object.Base qualified as KObj++import Control.Concurrent.STM+import Control.Concurrent.STM.TSem+import Data.Map qualified as Map++import Data.IORef.ToolsYj++import Data.TypeLevel.Tuple.MapIndex qualified++import Control.Monad+import Debug++layoutToMiddle :: U2 Layout.D slbts -> Layout.M.D+layoutToMiddle (U2 (Layout.D l)) = l++data AllocateInfo mn sp slbtss = AllocateInfo {+	allocateInfoNext :: TMaybe.M mn,+	allocateInfoDescriptorPool :: Descriptor.Pool.P sp,+	allocateInfoSetLayouts :: HeteroParList.PL (U2 Layout.D) slbtss }++deriving instance (Show (TMaybe.M n), Show (HeteroParList.PL (U2 Layout.D) slbtss)) =>+	Show (AllocateInfo n sp slbtss)++allocateInfoToMiddle :: AllocateInfo n sp slbtss -> M.AllocateInfo n+allocateInfoToMiddle AllocateInfo {+	allocateInfoNext = mnxt,+	allocateInfoDescriptorPool = Descriptor.Pool.P dp,+	allocateInfoSetLayouts = dscsls+	} = M.AllocateInfo {+		M.allocateInfoNext = mnxt,+		M.allocateInfoDescriptorPool = dp,+		M.allocateInfoSetLayouts =+			HeteroParList.toList layoutToMiddle dscsls }++class DListFromMiddle slbtss where+	dListFromMiddle :: [M.D] -> IO (HeteroParList.PL (D s) slbtss)++instance DListFromMiddle '[] where+	dListFromMiddle = \case [] -> pure HeteroParList.Nil; _ -> error "bad"++instance (+	DefaultDynamicLengths slbts,+	DListFromMiddle slbtss ) =>+	DListFromMiddle (slbts ': slbtss) where+	dListFromMiddle = \case+		(d : ds) -> (:**)+			<$> ((`D` d) <$> newDefaultIORef)+			<*> dListFromMiddle @slbtss ds+		_ -> error "bad"++type DefaultDynamicLengths slbts = Default+	(HeteroParList.PL+		(HeteroParList.PL KObj.Length)+		(Layout.BindingTypeListBufferOnlyDynamics (TIndex.I1_2 slbts)))++allocateDs :: (WithPoked (TMaybe.M mn), DListFromMiddle slbtss) =>+	Device.D sd -> AllocateInfo mn sp slbtss ->+	(forall s . HeteroParList.PL (D s) slbtss -> IO a) -> IO a+allocateDs (Device.D dvc) ai f = do+	dsm <- M.allocateDs dvc (allocateInfoToMiddle ai)+	ds <- dListFromMiddle dsm+	f ds <* M.freeDs dvc+		((\(Descriptor.Pool.P p) -> p) $ allocateInfoDescriptorPool ai)+		dsm++data Group sd s k sp slbtss = Group (Device.D sd) TSem+	(TVar (Map.Map k (Descriptor.Pool.P sp, HeteroParList.PL (D s) slbtss)))++group :: Device.D sd -> (forall s . Group sd s k sp slbtss -> IO a) -> IO a+group dv@(Device.D mdvc) f = do+	(sem, dsss) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty+	rtn <- f $ Group dv sem dsss+	((\(Descriptor.Pool.P dsp, dss) -> M.freeDs mdvc dsp $ dListToMiddle dss) `mapM_`) =<<+		(Map.elems <$> atomically (readTVar dsss))+	pure rtn++allocateDs' :: (Ord k, WithPoked (TMaybe.M mn), DListFromMiddle slbtss) =>+	Group sd sg k sp slbtss -> k -> AllocateInfo mn sp slbtss ->+	IO (Either String (HeteroParList.PL (D sg) slbtss))+allocateDs' (Group (Device.D dvc) sem mp) k ai = do+	ok <- atomically do+		mx <- (Map.lookup k) <$> readTVar mp+		case mx of+			Nothing -> waitTSem sem >> pure True+			Just _ -> pure False+	if ok+	then do	dsm <- M.allocateDs dvc (allocateInfoToMiddle ai)+		ds <- dListFromMiddle dsm+		atomically do+			modifyTVar mp (Map.insert k (sp, ds))+			signalTSem sem+		pure $ Right ds+	else pure . Left+		$ "Gpu.Vulkan.DescriptorSet.allocateDs': The key already exist"+--	where Descriptor.Pool.P sp  = allocateInfoDescriptorPool ai+	where sp  = allocateInfoDescriptorPool ai++unsafeFreeDs :: Ord k => Group sd sg k sp slbtss -> k -> IO (Either String ())+unsafeFreeDs (Group (Device.D mdvc) sem mp) k = do+	md <- atomically do+		mx <- Map.lookup k <$> readTVar mp+		case mx of+			Nothing -> pure Nothing+			Just _ -> waitTSem sem >> pure mx+	case md of+		Nothing -> pure $ Left "Gpu.Vulkan.DescriptorSet.unsafeFreeDs"+		Just (Descriptor.Pool.P p, ds) -> do+			M.freeDs mdvc p (dListToMiddle ds)+			atomically do+				modifyTVar mp (Map.delete k)+				signalTSem sem+				pure $ Right ()++lookup :: Ord k =>+	Group sd s k sp slbtss -> k -> IO (Maybe (HeteroParList.PL (D s) slbtss))+lookup (Group _ _sem mp) k = atomically $ (snd <$>) . Map.lookup k <$> readTVar mp++dListToMiddle :: HeteroParList.PL (D s) slbtss -> [M.D]+dListToMiddle = HeteroParList.toList \(D _ md) -> md++updateDs :: (+	Show (HeteroParList.PL M.Write (Data.TypeLevel.Tuple.MapIndex.M0_5 writeArgs)),+	W.WriteListToMiddle writeArgs,+	W.WriteListUpdateDynamicLengths writeArgs,+	CopyListToMiddle copyArgs) =>+	Device.D sd ->+	HeteroParList.PL (U5 W.Write) writeArgs ->+	HeteroParList.PL (U8 Copy) copyArgs  -> IO ()+updateDs (Device.D dvc) ws cs = when debug (print ws') >>+	W.writeListUpdateDynamicLength ws >> M.updateDs dvc ws' cs'+	where ws' = W.writeListToMiddle ws; cs' = copyListToMiddle cs
+ src/Gpu/Vulkan/DescriptorSet/BindingAndArrayElem.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs -fno-warn-redundant-constraints #-}++module Gpu.Vulkan.DescriptorSet.BindingAndArrayElem (++	-- * IMAGE++	BindingAndArrayElemImage(..),+	BindingAndArrayElemImageWithImmutableSampler(..),++	-- * BUFFER VIEW++	BindingAndArrayElemBufferView(..) ) where++import GHC.TypeLits+import Data.Kind+import Data.TypeLevel.List qualified as TList+import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex++import Gpu.Vulkan.TypeEnum qualified as T+import Gpu.Vulkan.DescriptorSetLayout.Type qualified as Lyt++-- * IMAGE++-- ** Image++class BindingAndArrayElemImage+	(lbts :: [Lyt.BindingType])+	(iargs :: [(Symbol, T.Format)]) (i :: Nat) where+	bindingAndArrayElemImage :: Integral n => n -> n -> (n, n)++instance TList.IsPrefixOf iargs liargs =>+	BindingAndArrayElemImage+		('Lyt.Image (iarg ': liargs) : lbts) (iarg ': iargs) 0 where+	bindingAndArrayElemImage b ae = (b, ae)++instance {-# OVERLAPPABLE #-}+	BindingAndArrayElemImage+		('Lyt.Image liargs ': lbts) (iarg ': iargs) (i - 1) =>+	BindingAndArrayElemImage+		('Lyt.Image (iarg ': liargs) ': lbts) (iarg ': iargs) i where+	bindingAndArrayElemImage b ae = bindingAndArrayElemImage+		@('Lyt.Image liargs ': lbts) @(iarg ': iargs) @(i - 1) b (ae + 1)++instance {-# OVERLAPPABLE #-}+	BindingAndArrayElemImage ('Lyt.Image liargs : lbts) iargs i =>+	BindingAndArrayElemImage+		('Lyt.Image (liarg ': liargs) ': lbts) iargs i where+	bindingAndArrayElemImage b a = bindingAndArrayElemImage+		@('Lyt.Image liargs : lbts) @iargs @i b (a + 1)++instance {-# OVERLAPPABLE #-}+	BindingAndArrayElemImage lbts iargs i =>+	BindingAndArrayElemImage (bt ': lbts) iargs i where+	bindingAndArrayElemImage b _ =+		bindingAndArrayElemImage @lbts @iargs @i (b + 1) 0++-- ** Image With Immutable Sampler++class BindingAndArrayElemImageWithImmutableSampler+	(lbts :: [Lyt.BindingType])+	(iargs :: [(Symbol, T.Format)]) (i :: Nat) where+	bindingAndArrayElemImageWithImmutableSampler :: Integral n => n -> n -> (n, n)++instance TList.IsPrefixOf iargs (TMapIndex.M0'1_3 liargs) =>+	BindingAndArrayElemImageWithImmutableSampler+		('Lyt.ImageSampler ('(nm, fmt, ss) ': liargs) : lbts) ('(nm, fmt) ': iargs) 0 where+	bindingAndArrayElemImageWithImmutableSampler b ae = (b, ae)++instance {-# OVERLAPPABLE #-}+	BindingAndArrayElemImageWithImmutableSampler+		('Lyt.ImageSampler liargs ': lbts) ('(nm, fmt) ': iargs) (i - 1) =>+	BindingAndArrayElemImageWithImmutableSampler+		('Lyt.ImageSampler ('(nm, fmt, ss) ': liargs) ': lbts) ('(nm, fmt) ': iargs) i where+	bindingAndArrayElemImageWithImmutableSampler b ae =+		bindingAndArrayElemImageWithImmutableSampler+			@('Lyt.ImageSampler liargs ': lbts) @('(nm, fmt) ': iargs)+			@(i - 1) b (ae + 1)++instance {-# OVERLAPPABLE #-}+	BindingAndArrayElemImageWithImmutableSampler ('Lyt.ImageSampler liargs : lbts) iargs i =>+	BindingAndArrayElemImageWithImmutableSampler+		('Lyt.ImageSampler (liarg ': liargs) ': lbts) iargs i where+	bindingAndArrayElemImageWithImmutableSampler b a = bindingAndArrayElemImageWithImmutableSampler+		@('Lyt.ImageSampler liargs : lbts) @iargs @i b (a + 1)++instance {-# OVERLAPPABLE #-}+	BindingAndArrayElemImageWithImmutableSampler lbts iargs i =>+	BindingAndArrayElemImageWithImmutableSampler (bt ': lbts) iargs i where+	bindingAndArrayElemImageWithImmutableSampler b _ =+		bindingAndArrayElemImageWithImmutableSampler @lbts @iargs @i (b + 1) 0++-- * BUFFER VIEW++class BindingAndArrayElemBufferView+	(bt :: [Lyt.BindingType]) (bvargs :: [(Symbol, Type)]) (i :: Nat) where+	bindingAndArrayElemBufferView :: Integral n => n -> n -> (n, n)++instance TList.IsPrefixOf bvargs lbvargs => BindingAndArrayElemBufferView+		('Lyt.BufferView (bvarg ': lbvargs) ': lbts)+		(bvarg ': bvargs) 0 where+	bindingAndArrayElemBufferView b a = (b, a)++instance {-# OVERLAPPABLE #-}+	BindingAndArrayElemBufferView+		('Lyt.BufferView lbvargs ': lbts) (bvarg ': bvargs) (i - 1) =>+	BindingAndArrayElemBufferView+		('Lyt.BufferView (bvarg ': lbvargs) ': lbts)+		(bvarg ': bvargs) i where+	bindingAndArrayElemBufferView b a = bindingAndArrayElemBufferView+		@('Lyt.BufferView lbvargs ': lbts) @(bvarg ': bvargs) @(i - 1)+		b a++instance {-# OVERLAPPABLE #-} BindingAndArrayElemBufferView+	('Lyt.BufferView lbvargs ': lbts) bvargs i =>+	BindingAndArrayElemBufferView+		('Lyt.BufferView (bvarg ': lbvargs) ': lbts) bvargs i where+	bindingAndArrayElemBufferView b a = bindingAndArrayElemBufferView+		@('Lyt.BufferView lbvargs ': lbts) @bvargs @i b (a + 1)++instance {-# OVERLAPPABLE #-} BindingAndArrayElemBufferView lbts bvargs i =>+	BindingAndArrayElemBufferView+		(bt ': lbts) bvargs i where+	bindingAndArrayElemBufferView b _a =+		bindingAndArrayElemBufferView @lbts @bvargs @i (b + 1) 0
+ src/Gpu/Vulkan/DescriptorSet/BindingAndArrayElem/Buffer.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs -fno-warn-redundant-constraints #-}++module Gpu.Vulkan.DescriptorSet.BindingAndArrayElem.Buffer where++import GHC.TypeLits++import Gpu.Vulkan.Object qualified as VO+import Gpu.Vulkan.DescriptorSetLayout.Type qualified as Lyt++-- * BUFFER++-- ** BindingAndArrayElemBuffer++class BindingAndArrayElemBuffer+	(lbts :: [Lyt.BindingType]) (objs :: [VO.O]) (i :: Nat) where+	bindingAndArrayElemBuffer :: Integral n => n -> n -> (n, n)++instance IsPrefixObject objs lobjs => BindingAndArrayElemBuffer+		('Lyt.Buffer (VO.Static al 'Nothing ot t ': lobjs) ': lbts)+		(VO.Static al ('Just _nm) ot t ': objs) 0 where+	bindingAndArrayElemBuffer b ae = (b, ae)++instance IsPrefixObject objs lobjs => BindingAndArrayElemBuffer+		('Lyt.Buffer (VO.Static al ('Just _nm) ot t ': lobjs) ': lbts)+		(VO.Static al 'Nothing ot t ': objs) 0 where+	bindingAndArrayElemBuffer b ae = (b, ae)++instance IsPrefixObject objs lobjs => BindingAndArrayElemBuffer+		('Lyt.Buffer (VO.Dynamic n al 'Nothing ot t ': lobjs) ': lbts)+		(VO.Dynamic n al ('Just _nm) ot t ': objs) 0 where+	bindingAndArrayElemBuffer b ae = (b, ae)++instance IsPrefixObject objs lobjs => BindingAndArrayElemBuffer+		('Lyt.Buffer (VO.Dynamic n al ('Just _nm) ot t ': lobjs) ': lbts)+		(VO.Dynamic n al 'Nothing ot t ': objs) 0 where+	bindingAndArrayElemBuffer b ae = (b, ae)++instance IsPrefixObject objs lobjs => BindingAndArrayElemBuffer+		('Lyt.Buffer (obj ': lobjs) ': lbts) (obj ': objs) 0 where+	bindingAndArrayElemBuffer b ae = (b, ae)++instance {-# OVERLAPPABLE #-}+	BindingAndArrayElemBuffer ('Lyt.Buffer lobjs ': lbts)+		(VO.Static al ('Just nm) ot t ': objs) (i - 1) =>+	BindingAndArrayElemBuffer+		('Lyt.Buffer (VO.Static al 'Nothing ot t ': lobjs) ': lbts)+		(VO.Static al ('Just nm) ot t ': objs) i where+	bindingAndArrayElemBuffer b ae = bindingAndArrayElemBuffer+		@('Lyt.Buffer lobjs ': lbts)+		@(VO.Static al ('Just nm) ot t ': objs) @(i - 1) b (ae + 1)++instance {-# OVERLAPPABLE #-} (+	BindingAndArrayElemBuffer ('Lyt.Buffer lobjs ': lbts)+		(VO.Static al 'Nothing ot t ': objs) (i - 1) ) =>+	BindingAndArrayElemBuffer+		('Lyt.Buffer (VO.Static al ('Just _nm) ot t ': lobjs) ': lbts)+		(VO.Static al 'Nothing ot t ': objs) i where+	bindingAndArrayElemBuffer b ae = bindingAndArrayElemBuffer+		@('Lyt.Buffer lobjs ': lbts)+		@(VO.Static al 'Nothing ot t ': objs) @(i - 1) b (ae + 1)++instance {-# OVERLAPPABLE #-} (+	BindingAndArrayElemBuffer ('Lyt.Buffer lobjs ': lbts)+		(VO.Dynamic n al ('Just nm) ot t ': objs) (i - 1) ) =>+	BindingAndArrayElemBuffer+		('Lyt.Buffer (VO.Dynamic n al 'Nothing ot t ': lobjs) ': lbts)+		(VO.Dynamic n al ('Just nm) ot t ': objs) i where+	bindingAndArrayElemBuffer b ae =+		bindingAndArrayElemBuffer+			@('Lyt.Buffer lobjs ': lbts)+			@(VO.Dynamic n al ('Just nm) ot t ': objs) @(i - 1)+			b (ae + 1)++instance {-# OVERLAPPABLE #-} (+	BindingAndArrayElemBuffer ('Lyt.Buffer lobjs ': lbts)+		(VO.Dynamic n al 'Nothing ot t ': objs) (i - 1) ) =>+	BindingAndArrayElemBuffer+		('Lyt.Buffer (VO.Dynamic n al ('Just _nm) ot t ': lobjs) ': lbts)+		(VO.Dynamic n al 'Nothing ot t ': objs) i where+	bindingAndArrayElemBuffer b ae =+		bindingAndArrayElemBuffer+			@('Lyt.Buffer lobjs ': lbts)+			@(VO.Dynamic n al 'Nothing ot t ': objs) @(i - 1)+			b (ae + 1)++instance {-# OVERLAPPABLE #-} (+	BindingAndArrayElemBuffer ('Lyt.Buffer lobjs ': lbts)+		(obj ': objs) (i - 1) ) =>+	BindingAndArrayElemBuffer+		('Lyt.Buffer (obj ': lobjs) ': lbts) (obj ': objs) i where+	bindingAndArrayElemBuffer b ae =+		bindingAndArrayElemBuffer+			@('Lyt.Buffer lobjs ': lbts)+			@(obj ': objs) @(i - 1) b (ae + 1)++instance {-# OVERLAPPABLE #-}+	BindingAndArrayElemBuffer ('Lyt.Buffer lobjs ': lbts) (obj ': objs) i =>+	BindingAndArrayElemBuffer+		('Lyt.Buffer (lobj ': lobjs) ': lbts) (obj ': objs) i where+	bindingAndArrayElemBuffer b ae =+		bindingAndArrayElemBuffer+			@('Lyt.Buffer lobjs ': lbts)+			@(obj ': objs) @i b (ae + 1)++instance {-# OVERLAPPABLE #-}+	BindingAndArrayElemBuffer lbts (obj ': objs) i =>+	BindingAndArrayElemBuffer (bt ': lbts) (obj ': objs) i where+	bindingAndArrayElemBuffer b _ae =+		bindingAndArrayElemBuffer @lbts @(obj ': objs) @i (b + 1) 0++-- ** IsPrefixObject++class IsPrefixObject (objs :: [VO.O]) (objs' :: [VO.O])++instance IsPrefixObject '[] objs'++instance IsPrefixObject objs objs' => IsPrefixObject+	(VO.Static al 'Nothing ot t ': objs)+	(VO.Static al ('Just _nm) ot t ': objs')++instance IsPrefixObject objs objs' => IsPrefixObject+	(VO.Static al ('Just _nm) ot t ': objs)+	(VO.Static al 'Nothing ot t ': objs')++instance IsPrefixObject objs objs' => IsPrefixObject+	(VO.Dynamic n al 'Nothing ot t ': objs)+	(VO.Dynamic n al ('Just _nm) ot t ': objs')++instance IsPrefixObject objs objs' => IsPrefixObject+	(VO.Dynamic n al ('Just _nm) ot t ': objs)+	(VO.Dynamic n al 'Nothing ot t ': objs')++instance IsPrefixObject objs objs' =>+	IsPrefixObject (obj ': objs) (obj ': objs')
+ src/Gpu/Vulkan/DescriptorSet/Copy.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE GADTs, TypeFamilies #-}+{-# LANGUAGE DataKinds, ConstraintKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.DescriptorSet.Copy (++	-- * COPY++	Copy(..),++	-- ** CopyListToMiddle++	CopyListToMiddle(..),++	-- ** BindingAndArrayElem++	BindingAndArrayElem,++	-- ** BindingLength++	BindingLength++	) where++import Data.TypeLevel.List qualified as TList+import Gpu.Vulkan.DescriptorSet.BindingAndArrayElem+import Gpu.Vulkan.DescriptorSet.BindingAndArrayElem.Buffer++import GHC.TypeLits+import Foreign.Storable.PeekPoke+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.Tuple.Uncurry+import Data.TypeLevel.Tuple.Index qualified as TIndex+import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex+import qualified Data.HeteroParList as HeteroParList+import Data.HeteroParList (pattern (:**))++import Gpu.Vulkan.DescriptorSet.Type++import qualified Gpu.Vulkan.DescriptorSetLayout.Type as Lyt+import qualified Gpu.Vulkan.DescriptorSet.Middle as M++-- * COPY++data Copy mn sdss slbtss (is :: Nat) sdsd slbtsd (id :: Nat)+	(lbts :: Lyt.BindingType) = Copy {+	copyNext :: TMaybe.M mn,+	copySrcSet :: D sdss slbtss, copyDstSet :: D sdsd slbtsd }++-- ** CopyListToMiddle++class M.CopyListToCore (TMapIndex.M0_8 cargs) =>+	CopyListToMiddle cargs where+	copyListToMiddle ::+		HeteroParList.PL (U8 Copy) cargs ->+		HeteroParList.PL M.Copy (TMapIndex.M0_8 cargs)++instance CopyListToMiddle '[] where+	copyListToMiddle HeteroParList.Nil = HeteroParList.Nil++instance (+	WithPoked (TMaybe.M mn),+	BindingAndArrayElem (TIndex.I1_2 slbtss) lbts is,+	BindingAndArrayElem (TIndex.I1_2 slbtsd) lbts id,+	BindingLength lbts, CopyListToMiddle cargs ) =>+	CopyListToMiddle (+		'(mn, sdss, slbtss, is, sdsd, slbtsd, id, lbts) ': cargs) where+	copyListToMiddle (U8 c :** cs) = copyToMiddle c :** copyListToMiddle cs++copyToMiddle :: forall mn sdss slbtss is sdsd slbtsd id lbts . (+	BindingAndArrayElem (TIndex.I1_2 slbtss) lbts is,+	BindingAndArrayElem (TIndex.I1_2 slbtsd) lbts id, BindingLength lbts ) =>+	Copy mn sdss slbtss is sdsd slbtsd id lbts -> M.Copy mn+copyToMiddle Copy {+	copyNext = mnxt, copySrcSet = D _ ss, copyDstSet = D _ sd } = let+	(bs, aes) = bindingAndArrayElem @(TIndex.I1_2 slbtss) @lbts @is+	(bd, aed) = bindingAndArrayElem @(TIndex.I1_2 slbtsd) @lbts @id+	cnt = bindingLength @lbts in+	M.Copy {+		M.copyNext = mnxt,+		M.copySrcSet = ss,+		M.copySrcBinding = bs, M.copySrcArrayElement = aes,+		M.copyDstSet = sd,+		M.copyDstBinding = bd, M.copyDstArrayElement = aed,+		M.copyDescriptorCount = cnt }++-- ** BindingAndArrayElem++class BindingAndArrayElem+	(lbts :: [Lyt.BindingType])+	(lbt :: Lyt.BindingType) (i :: Nat) where+	bindingAndArrayElem :: Integral n => (n, n)++instance BindingAndArrayElemBuffer lbts objs i =>+	BindingAndArrayElem lbts (Lyt.Buffer objs) i where+	bindingAndArrayElem = bindingAndArrayElemBuffer @lbts @objs @i 0 0++instance BindingAndArrayElemImage lbts iargs i =>+	BindingAndArrayElem lbts (Lyt.Image iargs) i where+	bindingAndArrayElem = bindingAndArrayElemImage @lbts @iargs @i 0 0++instance BindingAndArrayElemImageWithImmutableSampler lbts (TMapIndex.M0'1_3 iargs) i =>+	BindingAndArrayElem lbts (Lyt.ImageSampler iargs) i where+	bindingAndArrayElem =+		bindingAndArrayElemImageWithImmutableSampler @lbts @(TMapIndex.M0'1_3 iargs) @i 0 0++instance BindingAndArrayElemBufferView lbts bvargs i =>+	BindingAndArrayElem lbts (Lyt.BufferView bvargs) i where+	bindingAndArrayElem = bindingAndArrayElemBufferView @lbts @bvargs @i 0 0++-- ** BindingLength++class BindingLength (bt :: Lyt.BindingType) where+	bindingLength :: Integral n => n++instance TList.Length objs => BindingLength (Lyt.Buffer objs) where+	bindingLength = TList.length @_ @objs++instance TList.Length iargs => BindingLength (Lyt.Image iargs) where+	bindingLength = TList.length @_ @iargs++instance TList.Length bvargs => BindingLength (Lyt.BufferView bvargs) where+	bindingLength = TList.length @_ @bvargs++instance TList.Length isargs => BindingLength (Lyt.ImageSampler isargs) where+	bindingLength = TList.length @_ @isargs
+ src/Gpu/Vulkan/DescriptorSet/Type.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.DescriptorSet.Type (D(..)) where++import Data.Kind+import Data.TypeLevel.Tuple.Index qualified as TIndex+import Data.IORef+import Data.HeteroParList qualified as HeteroParList++import Gpu.Vulkan.Object.Base qualified as KObj+import Gpu.Vulkan.DescriptorSet.Middle qualified as M+import Gpu.Vulkan.DescriptorSetLayout.Type qualified as Lyt++data D s (slbts :: (Type, [Lyt.BindingType])) = D+	(IORef (HeteroParList.PL2 KObj.Length+		(Lyt.BindingTypeListBufferOnlyDynamics (TIndex.I1_2 slbts))))+	M.D
+ src/Gpu/Vulkan/DescriptorSet/Write.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE GADTs, TypeFamilies #-}+{-# LANGUAGE DataKinds, ConstraintKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.DescriptorSet.Write (++	-- * WRITE++	-- ** Types++	Write(..), WriteSources(..), WriteSourcesArg(..),++	-- ** WriteListToMiddle++	WriteListToMiddle(..), WriteSourcesToMiddle,+	BindingAndArrayElemImage, BindingAndArrayElemImageWithImmutableSampler,+	BindingAndArrayElemBuffer, BindingAndArrayElemBufferView,++	-- ** WriteListUpdateDynamicLengths++	WriteListUpdateDynamicLengths(..),+	WriteSourcesUpdateDynamicLengths, UpdateDynamicLength++	) where++import GHC.TypeLits+import Foreign.Storable.PeekPoke+import Data.TypeLevel.Tuple.Index qualified as TIndex+import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.Tuple.Uncurry+import qualified Data.HeteroParList as HeteroParList+import Data.HeteroParList (pattern (:**))++import Gpu.Vulkan.DescriptorSet.Type++import qualified Gpu.Vulkan.Descriptor.Enum as Descriptor+import qualified Gpu.Vulkan.DescriptorSet.Middle as M++import Gpu.Vulkan.DescriptorSet.Write.Sources++-- * WRITE++data Write mn sds slbts wsarg (i :: Nat) = Write {+	writeNext :: TMaybe.M mn,+	writeDstSet :: D sds slbts,+	writeDescriptorType :: Descriptor.Type,+	writeSources :: WriteSources wsarg }++-- ** WriteListToMiddle++class M.WriteListToCore (TMapIndex.M0_5 wargs) => WriteListToMiddle wargs where+	writeListToMiddle ::+		HeteroParList.PL (U5 Write) wargs ->+		HeteroParList.PL M.Write (TMapIndex.M0_5 wargs)++instance WriteListToMiddle '[] where+	writeListToMiddle HeteroParList.Nil = HeteroParList.Nil++instance (+	WithPoked (TMaybe.M mn),+	WriteSourcesToMiddle (TIndex.I1_2 slbts) wsarg i,+	WriteListToMiddle wargs ) =>+	WriteListToMiddle ('(mn, sds, slbts, wsarg, i) ': wargs) where+	writeListToMiddle (U5 w :** ws) =+		writeToMiddle w :** writeListToMiddle ws++writeToMiddle :: forall mn s slbts wsa i .+	WriteSourcesToMiddle (TIndex.I1_2 slbts) wsa i =>+	Write mn s slbts wsa i -> M.Write mn+writeToMiddle Write {+	writeNext = mnxt,+	writeDstSet = D _ ds,+	writeDescriptorType = dt,+	writeSources = srcs } = M.Write {+		M.writeNext = mnxt,+		M.writeDstSet = ds,+		M.writeDstBinding = bdg, M.writeDstArrayElement = ae,+		M.writeDescriptorType = dt,+		M.writeSources = srcs' }+	where ((bdg, ae), srcs') =+		writeSourcesToMiddle @(TIndex.I1_2 slbts) @_ @i srcs++-- ** WriteListUpdateDynamicLengths++class WriteListUpdateDynamicLengths wargs where+	writeListUpdateDynamicLength ::+		HeteroParList.PL (U5 Write) wargs -> IO ()++instance WriteListUpdateDynamicLengths '[] where+	writeListUpdateDynamicLength HeteroParList.Nil = pure ()++instance (+	WriteSourcesUpdateDynamicLengths bts wsarg,+	WriteListUpdateDynamicLengths wargs ) =>+	WriteListUpdateDynamicLengths+		('(mn, sds, '(sl, bts), wsarg, i) ': wargs) where+	writeListUpdateDynamicLength (U5 w :** ws) =+		writeUpdateDynamicLength w >> writeListUpdateDynamicLength ws++writeUpdateDynamicLength ::+	WriteSourcesUpdateDynamicLengths bts wsarg =>+	Write n s '(sl, bts) wsarg i -> IO ()+writeUpdateDynamicLength Write { writeDstSet = ds, writeSources = ws } =+	writeSourcesUpdateDynamicLength ds ws
+ src/Gpu/Vulkan/DescriptorSet/Write/Sources.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE GADTs, TypeFamilies #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.DescriptorSet.Write.Sources (++	-- * WRITE SOURCES++	-- ** Types++	WriteSources(..), WriteSourcesArg(..),+	DstBinding, DstArrayElement, DescriptorCount,++	-- ** WriteSourcesToMiddle++	WriteSourcesToMiddle(..),+	BindingAndArrayElemImage, BindingAndArrayElemImageWithImmutableSampler,+	BindingAndArrayElemBuffer, BindingAndArrayElemBufferView,++	-- ** WriteSourcesUpdateDynamicLengths++	WriteSourcesUpdateDynamicLengths(..), UpdateDynamicLength++	) where++import GHC.TypeLits+import Data.Kind+import Data.TypeLevel.Tuple.Uncurry+import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex+import Data.HeteroParList qualified as HeteroParList+import Data.HeteroParList.Tuple qualified as HeteroParList+import Data.Word+import Data.IORef++import Gpu.Vulkan.Object qualified as VObj++import Gpu.Vulkan.TypeEnum qualified as T++import Gpu.Vulkan.Descriptor.Internal qualified as Descriptor+import Gpu.Vulkan.Descriptor.Middle qualified as Descriptor.M++import Gpu.Vulkan.DescriptorSet.Type+import Gpu.Vulkan.DescriptorSet.BindingAndArrayElem+import Gpu.Vulkan.DescriptorSet.BindingAndArrayElem.Buffer+import Gpu.Vulkan.DescriptorSet.Middle qualified as M+import Gpu.Vulkan.DescriptorSetLayout.Type qualified as Layout+import Gpu.Vulkan.DescriptorSetLayout.UpdateDynamicLengths++import Gpu.Vulkan.Buffer.Type qualified as Buffer+import Gpu.Vulkan.BufferView.Internal qualified as BufferView+import Gpu.Vulkan.BufferView.Middle qualified as BufferView.M++-- * WRITE SOURCES++-- ** Types++data WriteSources arg where+	ImageInfos ::+		HeteroParList.PL (U4 Descriptor.ImageInfo) iiargs ->+		WriteSources ('WriteSourcesArgImage iiargs)+	ImageInfosNoSampler ::+		HeteroParList.PL (U3 Descriptor.ImageInfoNoSampler) iiargs ->+		WriteSources ('WriteSourcesArgImageNoSampler iiargs)+	BufferInfos ::+		HeteroParList.PL (U5 Descriptor.BufferInfo) biargs ->+		WriteSources ('WriteSourcesArgBuffer biargs)+	TexelBufferViews ::+		HeteroParList.PL (U3 BufferView.B) tbvargs ->+		WriteSources ('WriteSourcesArgBufferView tbvargs)+	WriteSourcesInNext :: DstBinding -> DstArrayElement ->+		DescriptorCount -> WriteSources 'WriteSourcesArgInNext++data WriteSourcesArg+	= WriteSourcesArgImage [(Type, Symbol, T.Format, Type)]+	| WriteSourcesArgImageNoSampler [(Symbol, T.Format, Type)]+	| WriteSourcesArgBuffer [(Type, Type, Symbol, VObj.O, Nat)]+	| WriteSourcesArgBufferView [(Type, Symbol, Type)]+	| WriteSourcesArgInNext++type DstBinding = Word32+type DstArrayElement = Word32+type DescriptorCount = Word32++-- ** WriteSourcesToMiddle++class WriteSourcesToMiddle (lbts :: [Layout.BindingType]) wsarg (i :: Nat) where+	writeSourcesToMiddle ::+		WriteSources wsarg -> ((Word32, Word32), M.WriteSources)++instance (BindingAndArrayElemBuffer lbts (TMapIndex.M3_5 barg) i) =>+	WriteSourcesToMiddle lbts ('WriteSourcesArgBuffer barg) i where+	writeSourcesToMiddle (BufferInfos bis) = (+		bindingAndArrayElemBuffer @lbts @(TMapIndex.M3_5 barg) @i 0 0,+		M.WriteSourcesBufferInfo $ bufferInfoListToMiddle bis )+		where+		bufferInfoListToMiddle ::+			HeteroParList.PL (U5 Descriptor.BufferInfo) biargs ->+			[Descriptor.M.BufferInfo]+		bufferInfoListToMiddle = HeteroParList.toList \(U5 bi) ->+			Descriptor.bufferInfoToMiddle bi++instance BindingAndArrayElemImage lbts (TMapIndex.M1'2_4 iarg) i =>+	WriteSourcesToMiddle lbts ('WriteSourcesArgImage iarg) i where+	writeSourcesToMiddle (ImageInfos iis) = (+		bindingAndArrayElemImage @lbts @(TMapIndex.M1'2_4 iarg) @i 0 0,+		M.WriteSourcesImageInfo $ imageInfosToMiddle iis )+		where+		imageInfosToMiddle ::+			HeteroParList.PL (U4 Descriptor.ImageInfo) iiargs ->+			[Descriptor.M.ImageInfo]+		imageInfosToMiddle = HeteroParList.toList \(U4 ii) ->+			Descriptor.imageInfoToMiddle ii++instance BindingAndArrayElemImageWithImmutableSampler+		lbts (TMapIndex.M0'1_3 iarg) i =>+	WriteSourcesToMiddle lbts ('WriteSourcesArgImageNoSampler iarg) i where+	writeSourcesToMiddle (ImageInfosNoSampler iis) = (+		bindingAndArrayElemImageWithImmutableSampler+			@lbts @(TMapIndex.M0'1_3 iarg) @i 0 0,+		M.WriteSourcesImageInfo $ imageInfosToMiddle iis )+		where+		imageInfosToMiddle ::+			HeteroParList.PL+				(U3 Descriptor.ImageInfoNoSampler) iiargs ->+			[Descriptor.M.ImageInfo]+		imageInfosToMiddle = HeteroParList.toList \(U3 ii) ->+			Descriptor.imageInfoNoSamplerToMiddle ii++instance BindingAndArrayElemBufferView lbts (TMapIndex.M1'2_3 bvarg) i =>+	WriteSourcesToMiddle lbts ('WriteSourcesArgBufferView bvarg) i where+	writeSourcesToMiddle (TexelBufferViews bvarg) = (+		bindingAndArrayElemBufferView+			@lbts @(TMapIndex.M1'2_3 bvarg) @i 0 0,+		M.WriteSourcesBufferView $ bvsToMiddle bvarg )+		where+		bvsToMiddle :: HeteroParList.PL (U3 BufferView.B) bvs ->+			[BufferView.M.B]+		bvsToMiddle =+			HeteroParList.toList \(U3 (BufferView.B mbv)) -> mbv++instance WriteSourcesToMiddle lbts 'WriteSourcesArgInNext i where+	writeSourcesToMiddle (WriteSourcesInNext bdg ae cnt) =+		((bdg, ae), M.WriteSourcesInNext cnt)++-- ** WriteSourcesUpdateDynamicLengths++class WriteSourcesUpdateDynamicLengths lbts wsarg where+	writeSourcesUpdateDynamicLength ::+		D sds '(sl, lbts) -> WriteSources wsarg -> IO ()++instance (+	TMapIndex.M3_5 bargs ~ objs, UpdateDynamicLength lbts objs,+	HeteroParList.Map3_5 bargs ) =>+	WriteSourcesUpdateDynamicLengths+		lbts (WriteSourcesArgBuffer bargs) where+	writeSourcesUpdateDynamicLength (D rlns _) (BufferInfos bis) = do+		lns <- readIORef rlns+		writeIORef rlns+			. updateDynamicLength @lbts @objs lns+			. VObj.onlyDynamicLength @objs+			$ HeteroParList.map3_5 (toLength . unU5) bis+		where+		toLength :: Descriptor.BufferInfo sm sb nm obj i ->+			VObj.Length obj+		toLength (Descriptor.BufferInfo (Buffer.Binded lns _)) =+			HeteroParList.typeIndex lns++instance {-# OVERLAPPABLE #-} WriteSourcesUpdateDynamicLengths lbts wsarg where+	writeSourcesUpdateDynamicLength _ _ = pure ()
+ src/Gpu/Vulkan/DescriptorSetLayout.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications, RankNTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.DescriptorSetLayout (++	-- * CREATE++	create, D, CreateInfo(..),++	-- ** Binding++	Binding(..), BindingListToMiddle,++	-- ** BindingType++	BindingType(..), BindingTypeListBufferOnlyDynamics,++	-- * ENUM++	module Gpu.Vulkan.DescriptorSetLayout.Enum++	) where++import Prelude hiding (length)++import Foreign.Storable.PeekPoke+import Control.Exception+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.List+import Data.TypeLevel.Tuple.Uncurry+import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex+import Data.HeteroParList qualified as HeteroParList+import Data.HeteroParList (pattern (:**))+import Data.Word++import Gpu.Vulkan.Enum+import Gpu.Vulkan.DescriptorSetLayout.Type+import Gpu.Vulkan.DescriptorSetLayout.Enum++import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.Descriptor.Enum as Descriptor+import qualified Gpu.Vulkan.DescriptorSetLayout.Middle as M+import qualified Gpu.Vulkan.Sampler.Type as Sampler++create :: (+	WithPoked (TMaybe.M mn), BindingListToMiddle bts,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd -> CreateInfo mn bts ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . D s bts -> IO a) -> IO a+create (Device.D dvc) ci (AllocationCallbacks.toMiddle -> mac) f =+	bracket (M.create dvc (createInfoToMiddle ci) mac)+		(\l -> M.destroy dvc l mac) (f . D)++data CreateInfo mn bts = CreateInfo {+	createInfoNext :: TMaybe.M mn,+	createInfoFlags :: CreateFlags,+	createInfoBindings :: HeteroParList.PL Binding bts }++-- deriving instance (Show (TMaybe.M mn), Show (HeteroParList.PL Binding bts)) =>+--	Show (CreateInfo mn bts)++createInfoToMiddle ::+	BindingListToMiddle bts => CreateInfo mn bts -> M.CreateInfo mn+createInfoToMiddle CreateInfo {+	createInfoNext = mnxt,+	createInfoFlags = flgs,+	createInfoBindings = bds } = M.CreateInfo {+		M.createInfoNext = mnxt,+		M.createInfoFlags = flgs,+		M.createInfoBindings = bindingListToMiddle bds 0 }++data Binding (bt :: BindingType) where+	BindingBuffer :: {+		bindingBufferDescriptorType :: Descriptor.Type,+		bindingBufferStageFlags :: ShaderStageFlags+		} -> Binding ('Buffer objs)+	BindingBufferView :: {+		bindingBufferViewDescriptorType :: Descriptor.Type,+		bindingBufferViewStageFlags :: ShaderStageFlags+		} -> Binding ('BufferView bvargs)+	BindingImage :: {+		bindingImageDescriptorType :: Descriptor.Type,+		bindingImageStageFlags :: ShaderStageFlags+		} -> Binding ('Image iargs)+	BindingImageSampler :: {+		bindingImageSamplerDescriptorType :: Descriptor.Type,+		bindingImageSamplerStageFlags :: ShaderStageFlags,+		bindingImageSamplerImmutableSamplers ::+			HeteroParList.PL Sampler.S (TMapIndex.M2_3 iargs)+		} -> Binding ('ImageSampler iargs)++class BindingListToMiddle bts where+	bindingListToMiddle ::+		HeteroParList.PL Binding bts -> Word32 -> [M.Binding]++instance BindingListToMiddle '[] where+	bindingListToMiddle HeteroParList.Nil _ = []++instance (BindingToMiddle bt, BindingListToMiddle bts) =>+	BindingListToMiddle (bt ': bts) where+	bindingListToMiddle (bd :** bds) bb =+		bindingToMiddle bd bb : bindingListToMiddle bds (bb + 1)++class BindingToMiddle bt where+	bindingToMiddle :: Binding bt -> Word32 -> M.Binding++instance Length objs => BindingToMiddle ('Buffer objs) where+	bindingToMiddle BindingBuffer {+		bindingBufferDescriptorType = dt,+		bindingBufferStageFlags = sfs } bb = M.Binding {+			M.bindingBinding = bb,+			M.bindingDescriptorType = dt,+			M.bindingDescriptorCountOrImmutableSamplers =+				Left (length @_ @objs),+			M.bindingStageFlags = sfs }++instance Length bvargs => BindingToMiddle ('BufferView bvargs) where+	bindingToMiddle BindingBufferView {+		bindingBufferViewDescriptorType = dt,+		bindingBufferViewStageFlags = sfs } bb = M.Binding {+			M.bindingBinding = bb,+			M.bindingDescriptorType = dt,+			M.bindingDescriptorCountOrImmutableSamplers =+				Left (length @_ @bvargs),+			M.bindingStageFlags = sfs }++instance Length iargs => BindingToMiddle ('Image iargs) where+	bindingToMiddle BindingImage {+		bindingImageDescriptorType = dt,+		bindingImageStageFlags = sfs } bb = M.Binding {+			M.bindingBinding = bb,+			M.bindingDescriptorType = dt,+			M.bindingDescriptorCountOrImmutableSamplers =+				Left (length @_ @iargs),+			M.bindingStageFlags = sfs }++instance BindingToMiddle ('ImageSampler iargs) where+	bindingToMiddle BindingImageSampler {+		bindingImageSamplerDescriptorType = dt,+		bindingImageSamplerStageFlags = sfs,+		bindingImageSamplerImmutableSamplers = iss } bb = M.Binding {+			M.bindingBinding = bb,+			M.bindingDescriptorType = dt,+			M.bindingDescriptorCountOrImmutableSamplers = Right+				$ HeteroParList.toList Sampler.sToMiddle iss,+			M.bindingStageFlags = sfs }
+ src/Gpu/Vulkan/DescriptorSetLayout/BindingFlags.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.DescriptorSetLayout.BindingFlags (M.CreateInfo(..)) where++import Gpu.Vulkan.DescriptorSetLayout.BindingFlags.Middle qualified as M
+ src/Gpu/Vulkan/DescriptorSetLayout/Enum.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.DescriptorSetLayout.Enum (+	module Gpu.Vulkan.DescriptorSetLayout.Enum ) where++import "gpu-vulkan-middle" Gpu.Vulkan.DescriptorSetLayout.Enum
+ src/Gpu/Vulkan/DescriptorSetLayout/Type.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.DescriptorSetLayout.Type where++import GHC.TypeLits+import Data.Kind+import Gpu.Vulkan.Object qualified as VObj++import qualified Gpu.Vulkan.TypeEnum as T+import qualified Gpu.Vulkan.DescriptorSetLayout.Middle as M++newtype D s (bts :: [BindingType]) = D { unL :: M.D } deriving Show++data BindingType+	= Image [(Symbol, T.Format)] | ImageSampler [(Symbol, T.Format, Type)]+	| Buffer [VObj.O] | BufferView [(Symbol, Type)]++type family BindingTypeListBufferOnlyDynamics bts where+	BindingTypeListBufferOnlyDynamics '[] = '[]+	BindingTypeListBufferOnlyDynamics (bt ': bts) =+		BindingTypeBufferOnlyDynamics bt ':+		BindingTypeListBufferOnlyDynamics bts++type family BindingTypeBufferOnlyDynamics bt where+	BindingTypeBufferOnlyDynamics bt =+		VObj.OnlyDynamics (BindingTypeBufferObjects bt)++type family BindingTypeBufferObjects bt where+	BindingTypeBufferObjects (Buffer os) = os+	BindingTypeBufferObjects _ = '[]
+ src/Gpu/Vulkan/DescriptorSetLayout/UpdateDynamicLengths.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.DescriptorSetLayout.UpdateDynamicLengths (++	-- * UPDATE DYNAMIC LENGTHS++	UpdateDynamicLength(..) ) where++import Gpu.Vulkan.Object qualified as VObj+import Gpu.Vulkan.Object.Base qualified as KObj+import Data.HeteroParList qualified as HeteroParList+import Data.HeteroParList (pattern (:**))++import qualified Gpu.Vulkan.DescriptorSetLayout.Type as Layout++class VObj.OnlyDynamicLengths objs => UpdateDynamicLength bts objs where+	updateDynamicLength ::+		HeteroParList.PL+			(HeteroParList.PL KObj.Length)+			(Layout.BindingTypeListBufferOnlyDynamics bts) ->+		HeteroParList.PL KObj.Length+			(VObj.OnlyDynamics objs) ->+		HeteroParList.PL+			(HeteroParList.PL KObj.Length)+			(Layout.BindingTypeListBufferOnlyDynamics bts)++instance UpdateDynamicLength _bts '[] where updateDynamicLength x _ = x++instance UpdateDynamicLength bts (o ': os) =>+	UpdateDynamicLength ('Layout.Buffer '[] ': bts) (o ': os) where+	updateDynamicLength (HeteroParList.Nil :** lnss) lns =+		HeteroParList.Nil :** updateDynamicLength @bts @(o ': os) lnss lns++instance (UpdateDynamicLengthPrefix os os', VObj.OnlyDynamicLengths os) =>+	UpdateDynamicLength+		('Layout.Buffer (VObj.Static algn 'Nothing ot t ': os') ': bts)+		(VObj.Static algn ('Just _nm) ot t ': os) where+	updateDynamicLength (lns' :** lnss) lns =+		updateDynamicLengthPrefix @os @os' lns' lns :** lnss++instance (UpdateDynamicLengthPrefix os os', VObj.OnlyDynamicLengths os) =>+	UpdateDynamicLength+		('Layout.Buffer (VObj.Static algn ('Just _nm) ot t ': os') ': bts)+		(VObj.Static algn 'Nothing ot t ': os) where+	updateDynamicLength (lns' :** lnss) lns =+		updateDynamicLengthPrefix @os @os' lns' lns :** lnss++instance (UpdateDynamicLengthPrefix os os', VObj.OnlyDynamicLengths os) =>+	UpdateDynamicLength+		('Layout.Buffer (VObj.Dynamic n algn 'Nothing ot t ': os') ': bts)+		(VObj.Dynamic n algn ('Just _nm) ot t ': os) where+	updateDynamicLength ((_ln :** lns') :** lnss) (ln :** lns) =+		(KObj.renameLength ln :** updateDynamicLengthPrefix @os @os' lns' lns) :** lnss++instance (UpdateDynamicLengthPrefix os os', VObj.OnlyDynamicLengths os) =>+	UpdateDynamicLength+		('Layout.Buffer (VObj.Dynamic n algn ('Just _nm) ot t ': os') ': bts)+		(VObj.Dynamic n algn 'Nothing ot t ': os) where+	updateDynamicLength ((_ln :** lns') :** lnss) (ln :** lns) =+		(KObj.renameLength ln :** updateDynamicLengthPrefix @os @os' lns' lns) :** lnss++instance (UpdateDynamicLengthPrefix os os', VObj.OnlyDynamicLengths os) =>+	UpdateDynamicLength+		('Layout.Buffer (VObj.Static_ o ': os') ': bts)+		(VObj.Static_ o ': os) where+	updateDynamicLength (lns' :** lnss) lns =+		updateDynamicLengthPrefix @os @os' lns' lns :** lnss++instance (UpdateDynamicLengthPrefix os os', VObj.OnlyDynamicLengths os) =>+	UpdateDynamicLength+		('Layout.Buffer ('VObj.Dynamic n o ': os') ': bts)+		('VObj.Dynamic n o ': os) where+	updateDynamicLength ((_ln :** lns') :** lnss) (ln :** lns) =+		(ln :** updateDynamicLengthPrefix @os @os' lns' lns) :** lnss++instance {-# OVERLAPPABLE #-}+	UpdateDynamicLength+		('Layout.Buffer os' ': bts) (oo ': os) =>+	UpdateDynamicLength+		('Layout.Buffer (VObj.Static_ o ': os') ': bts) (oo ': os) where+	updateDynamicLength lnss lns =+		updateDynamicLength+			@('Layout.Buffer os' ': bts) @(oo ': os) lnss lns++instance {-# OVERLAPPABLE #-}+	UpdateDynamicLength+		('Layout.Buffer os' ': bts) (oo ': os) =>+	UpdateDynamicLength+		('Layout.Buffer ('VObj.Dynamic n o ': os') ': bts) (oo ': os) where+	updateDynamicLength ((ln :** lns') :** lnss) lns = let+		ls' :** lss = updateDynamicLength+			@('Layout.Buffer os' ': bts) @(oo ': os) (lns' :** lnss) lns in+		(ln :** ls') :** lss++class UpdateDynamicLengthPrefix (objs :: [VObj.O]) (objs' :: [VObj.O]) where+	updateDynamicLengthPrefix ::+		HeteroParList.PL KObj.Length (VObj.OnlyDynamics objs') ->+		HeteroParList.PL KObj.Length (VObj.OnlyDynamics objs) ->+		HeteroParList.PL KObj.Length (VObj.OnlyDynamics objs')++instance UpdateDynamicLengthPrefix '[] objs where+	updateDynamicLengthPrefix lns _ = lns++instance UpdateDynamicLengthPrefix os os' =>+	UpdateDynamicLengthPrefix+		(VObj.Static algn 'Nothing ot t ': os)+		(VObj.Static algn ('Just _nm) ot t ': os') where+	updateDynamicLengthPrefix lns' lns  =+		updateDynamicLengthPrefix @os @os' lns' lns++instance UpdateDynamicLengthPrefix os os' =>+	UpdateDynamicLengthPrefix+		(VObj.Static algn ('Just _nm) ot t ': os)+		(VObj.Static algn 'Nothing ot t ': os') where+	updateDynamicLengthPrefix lns' lns  =+		updateDynamicLengthPrefix @os @os' lns' lns++instance UpdateDynamicLengthPrefix os os' =>+	UpdateDynamicLengthPrefix+		(VObj.Dynamic n algn 'Nothing ot t ': os)+		(VObj.Dynamic n algn ('Just _nm) ot t ': os') where+	updateDynamicLengthPrefix (_ln :** lns') (ln :** lns)  =+		KObj.renameLength ln :** updateDynamicLengthPrefix @os @os' lns' lns++instance UpdateDynamicLengthPrefix os os' =>+	UpdateDynamicLengthPrefix+		(VObj.Dynamic n algn ('Just _nm) ot t ': os)+		(VObj.Dynamic n algn 'Nothing ot t ': os') where+	updateDynamicLengthPrefix (_ln :** lns') (ln :** lns)  =+		KObj.renameLength ln :** updateDynamicLengthPrefix @os @os' lns' lns++instance UpdateDynamicLengthPrefix os os' =>+	UpdateDynamicLengthPrefix+		(VObj.Static_ o : os) (VObj.Static_ o : os') where+	updateDynamicLengthPrefix lns' lns  =+		updateDynamicLengthPrefix @os @os' lns' lns++instance UpdateDynamicLengthPrefix os os' =>+	UpdateDynamicLengthPrefix+		('VObj.Dynamic n o : os) ('VObj.Dynamic n o : os') where+	updateDynamicLengthPrefix (_ln :** lns') (ln :** lns) =+		ln :** updateDynamicLengthPrefix @os @os' lns' lns
+ src/Gpu/Vulkan/Device.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Device (++	-- * CREATE++	create, D, CreateInfo(..),+	CreateFlags, QueueCreateInfo(..),++	-- ** Group++	group, Group, create', unsafeDestroy, lookup,++	-- * GET QUEUE AND WAIT IDLE++	getQueue, waitIdle,++	-- * SIZE++	Size,++	-- * ENUM++	module Gpu.Vulkan.Device.Enum++	) where++import Prelude hiding (lookup)+import Gpu.Vulkan.Device.Internal+import Gpu.Vulkan.Device.Enum
+ src/Gpu/Vulkan/Device/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Device.Enum (module Gpu.Vulkan.Device.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Device.Enum
+ src/Gpu/Vulkan/Device/Internal.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Device.Internal (++	-- * CREATE++	create, D(..), CreateInfo(..),+	M.CreateFlags, M.QueueCreateInfo(..),++	-- ** Group++	group, Group, create', unsafeDestroy, lookup,++	-- * GET QUEUE AND WAIT IDLE++	getQueue, waitIdle,++	-- * SIZE++	M.Size++	) where++import Prelude hiding (lookup)+import Foreign.Storable.PeekPoke+import Control.Concurrent.STM+import Control.Concurrent.STM.TSem+import Control.Exception+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry+import Data.Map qualified as Map++import Gpu.Vulkan+import Gpu.Vulkan.Device.Type++import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.PhysicalDevice as PhysicalDevice+import qualified Gpu.Vulkan.Device.Middle as M+import qualified Gpu.Vulkan.QueueFamily.Middle as QueueFamily+import qualified Gpu.Vulkan.Queue as Queue++import Data.HeteroParList qualified as HeteroParList++create :: (+	WithPoked (TMaybe.M mn),+	HeteroParList.ToListWithCM' WithPoked TMaybe.M qcis,+	AllocationCallbacks.ToMiddle mac ) =>+	PhysicalDevice.P -> CreateInfo mn qcis ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . D s -> IO a) -> IO a+create pd (createInfoToMiddle -> ci) (AllocationCallbacks.toMiddle -> mac) f =+	bracket (M.create pd ci mac) (`M.destroy` mac) (f . D)++getQueue :: D sd -> QueueFamily.Index -> Queue.Index -> IO Queue.Q+getQueue (D d) (QueueFamily.Index qfi) qi = M.getQueue d qfi qi++waitIdle :: D s -> IO ()+waitIdle (D d) = M.waitIdle d++data CreateInfo mn qcis = CreateInfo {+	createInfoNext :: TMaybe.M mn,+	createInfoFlags :: M.CreateFlags,+	createInfoQueueCreateInfos :: HeteroParList.PL M.QueueCreateInfo qcis,+	createInfoEnabledLayerNames :: [LayerName],+	createInfoEnabledExtensionNames :: [PhysicalDevice.ExtensionName],+	createInfoEnabledFeatures :: Maybe PhysicalDevice.Features }++deriving instance (+	Show (TMaybe.M mn), Show (HeteroParList.PL M.QueueCreateInfo qcis) ) =>+	Show (CreateInfo mn qcis)++createInfoToMiddle :: CreateInfo mn qcis -> M.CreateInfo mn qcis+createInfoToMiddle CreateInfo {+	createInfoNext = nxt,+	createInfoFlags = flgs,+	createInfoQueueCreateInfos = qcis,+	createInfoEnabledLayerNames = ((\(LayerName ln) -> ln) <$>) -> elnms,+	createInfoEnabledExtensionNames =+		((\(PhysicalDevice.ExtensionName en) -> en) <$>) ->eenms,+	createInfoEnabledFeatures = mef } = M.CreateInfo {+	M.createInfoNext = nxt,+	M.createInfoFlags = flgs,+	M.createInfoQueueCreateInfos = qcis,+	M.createInfoEnabledLayerNames = elnms,+	M.createInfoEnabledExtensionNames = eenms,+	M.createInfoEnabledFeatures = mef }++data Group ma sd k = Group+	(TPMaybe.M (U2 AllocationCallbacks.A) ma) TSem (TVar (Map.Map k (D sd)))++group :: AllocationCallbacks.ToMiddle ma =>+	TPMaybe.M (U2 AllocationCallbacks.A) ma ->+	(forall sd . Group ma sd k -> IO a) -> IO a+group mac@(AllocationCallbacks.toMiddle -> mmac) f = do+	(sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty+	rtn <- f $ Group mac sem m+	((\(D d) -> M.destroy d mmac) `mapM_`) =<< atomically (readTVar m)+	pure rtn++create' :: (+	Ord k, WithPoked (TMaybe.M mn),+	HeteroParList.ToListWithCM' WithPoked TMaybe.M qcis,+	AllocationCallbacks.ToMiddle ma ) => PhysicalDevice.P ->+	Group ma sd k -> k -> CreateInfo mn qcis -> IO (Either String (D sd))+create' phd (Group+	(AllocationCallbacks.toMiddle -> mmac) sem ds) k+	(createInfoToMiddle -> ci) = do+	ok <- atomically do+		mx <- Map.lookup k <$> readTVar ds+		case mx of+			Nothing -> waitTSem sem >> pure True+			Just _ -> pure False+	if ok+	then do	d <- M.create phd ci mmac+		let	d' = D d+		atomically $ modifyTVar ds (Map.insert k d') >> signalTSem sem+		pure $ Right d'+	else pure . Left $ "Gpu.Vulkan.Device.create': The key already exist"++unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) =>+	Group ma sd k -> k -> IO (Either String ())+unsafeDestroy (Group+	(AllocationCallbacks.toMiddle -> ma) sem ds) k = do+	md <- atomically do+		mx <- Map.lookup k <$> readTVar ds+		case mx of+			Nothing -> pure Nothing+			Just _ -> waitTSem sem >> pure mx+	case md of+		Nothing -> pure $ Left "Gpu.Vulkan.Device.unsafaDestroy: No such key"+		Just (D d) -> do+			M.destroy d ma+			atomically do+				modifyTVar ds $ Map.delete k+				signalTSem sem+				pure $ Right ()++lookup :: Ord k => Group ma sd k -> k -> IO (Maybe (D sd))+lookup (Group _ _sem ds) k = atomically $ Map.lookup k <$> readTVar ds
+ src/Gpu/Vulkan/Device/Type.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Device.Type where++import qualified Gpu.Vulkan.Device.Middle as M++newtype D s = D M.D deriving Show
+ src/Gpu/Vulkan/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Enum (module Gpu.Vulkan.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Enum
+ src/Gpu/Vulkan/Exception.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Exception (++	MultiResult(..),++	module Gpu.Vulkan.Exception.Enum++	) where++import Gpu.Vulkan.Exception.Middle+import Gpu.Vulkan.Exception.Enum
+ src/Gpu/Vulkan/Exception/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Exception.Enum (module Gpu.Vulkan.Exception.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Exception.Enum
+ src/Gpu/Vulkan/Fence.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Fence (++	-- * CREATE++	create, F, CreateInfo(..),++	-- ** Group++	group, Group, create', unsafeDestroy, lookup,++	-- * WAIT FOR FENCES AND RESET FENCES++	waitForFs, resetFs,++	-- * ENUM++	module Gpu.Vulkan.Fence.Enum++	) where++import Prelude hiding (lookup)+import Gpu.Vulkan.Fence.Internal+import Gpu.Vulkan.Fence.Enum
+ src/Gpu/Vulkan/Fence/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Fence.Enum (module Gpu.Vulkan.Fence.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Fence.Enum
+ src/Gpu/Vulkan/Fence/Internal.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Fence.Internal (++	-- * CREATE++	create, F(..), M.CreateInfo(..),++	-- ** Group++	group, Group, create', unsafeDestroy, lookup,++	-- * WAIT FOR FENCES AND RESET FENCES++	waitForFs, resetFs++	) where++import Prelude hiding (lookup)+import Foreign.Storable.PeekPoke+import Control.Concurrent.STM+import Control.Concurrent.STM.TSem+import Control.Exception+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry+import Data.HeteroParList qualified as HeteroParList+import Data.Map qualified as Map+import Data.Word+import Data.Time++import Gpu.Vulkan.Fence.Type++import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.Fence.Middle as M++create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) =>+	Device.D sd -> M.CreateInfo mn ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . F s -> IO a) -> IO a+create (Device.D dvc) ci (AllocationCallbacks.toMiddle -> mac) f =+	bracket (M.create dvc ci mac) (\fnc -> M.destroy dvc fnc mac) (f . F)++waitForFs :: Device.D sd -> HeteroParList.PL F sfs -> Bool -> Maybe DiffTime -> IO ()+waitForFs (Device.D dvc) fs wa (maybe maxBound diffTimeToNanoseconds -> to) =+	M.waitForFs dvc (HeteroParList.toList (\(F f) -> f) fs) wa to++resetFs :: Device.D sd -> HeteroParList.PL F sfs -> IO ()+resetFs (Device.D dvc) = M.resetFs dvc . HeteroParList.toList \(F f) -> f++diffTimeToNanoseconds :: DiffTime -> Word64+diffTimeToNanoseconds = fromInteger . (`div` 1000) . diffTimeToPicoseconds++data Group sd ma sf k = Group (Device.D sd)+	(TPMaybe.M (U2 AllocationCallbacks.A) ma) TSem (TVar (Map.Map k (F sf)))++group :: AllocationCallbacks.ToMiddle ma =>+	Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma ->+	(forall sf . Group sd ma sf k -> IO a) -> IO a+group dvc@(Device.D mdvc) mac@(AllocationCallbacks.toMiddle -> mmac) f = do+	(sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty+	rtn <- f $ Group dvc mac sem m+	((\(F s) -> M.destroy mdvc s mmac) `mapM_`) =<< atomically (readTVar m)+	pure rtn++create' :: (+	Ord k, WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle ma) =>+	Group sd ma sf k -> k -> M.CreateInfo mn -> IO (Either String (F sf))+create' (Group (Device.D mdvc)+	(AllocationCallbacks.toMiddle -> mmac) sem sf) k ci = do+	ok <- atomically do+		mx <- Map.lookup k <$> readTVar sf+		case mx of+			Nothing -> waitTSem sem >> pure True+			Just _ -> pure False+	if ok+	then do	f <- M.create mdvc ci mmac+		let	f' = F f+		atomically $ modifyTVar sf (Map.insert k f') >> signalTSem sem+		pure $ Right f'+	else pure . Left $+		"Gpu.Vulkan.Fence.Internal.create': The key already exist"++unsafeDestroy :: (+	Ord k, AllocationCallbacks.ToMiddle ma) =>+	Group sd ma sf k -> k -> IO (Either String ())+unsafeDestroy (Group (Device.D mdvc)+	(AllocationCallbacks.toMiddle -> ma) sem fs) k = do+	mf <- atomically do+		mx <- Map.lookup k <$> readTVar fs+		case mx of+			Nothing -> pure Nothing+			Just _ -> waitTSem sem >> pure mx+	case mf of+		Nothing -> pure $ Left+			"Gpu.Vulkan.Fence.unsafeDestroy: No such key"+		Just (F f) -> do+			M.destroy mdvc f ma+			atomically do+				modifyTVar fs $ Map.delete k+				signalTSem sem+				pure $ Right ()++lookup :: Ord k => Group sd ma sf k -> k -> IO (Maybe (F sf))+lookup (Group _ _ _sem fs) k = atomically $ Map.lookup k <$> readTVar fs
+ src/Gpu/Vulkan/Fence/Type.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Fence.Type where++import qualified Gpu.Vulkan.Fence.Middle as M++newtype F sf = F M.F deriving Show
+ src/Gpu/Vulkan/Framebuffer.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Framebuffer (++	-- * CREATE++	create, unsafeRecreate, F, CreateInfo(..),++	-- ** Group++	group, Group, create', unsafeDestroy, lookup,++	-- * ENUM++	module Gpu.Vulkan.Framebuffer.Enum++	) where++import Prelude hiding (lookup)+import Foreign.Storable.PeekPoke+import Control.Concurrent.STM+import Control.Concurrent.STM.TSem+import Control.Exception+import Data.TypeLevel.Tuple.Uncurry+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.HeteroParList qualified as HeteroParList+import Data.Map qualified as Map+import Data.Word++import Gpu.Vulkan.Framebuffer.Enum+import Gpu.Vulkan.Framebuffer.Type++import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.RenderPass.Type as RenderPass+import qualified Gpu.Vulkan.ImageView as ImageView+import qualified Gpu.Vulkan.ImageView.Type as ImageView+import qualified Gpu.Vulkan.Framebuffer.Middle as M++data CreateInfo mn sr aargs = CreateInfo {+	createInfoNext :: TMaybe.M mn,+	createInfoFlags :: CreateFlags,+	createInfoRenderPass :: RenderPass.R sr,+	createInfoAttachments :: HeteroParList.PL (U3 ImageView.I) aargs,+	createInfoWidth :: Word32,+	createInfoHeight :: Word32,+	createInfoLayers :: Word32 }++type family MapThird (t :: [(j, k, l)]) where+	MapThird '[] = '[]+	MapThird ('(a, b, c) ': abcs) = c ': MapThird abcs++createInfoToMiddle :: CreateInfo n sr fmtmnsis -> M.CreateInfo n+createInfoToMiddle CreateInfo {+	createInfoNext = mnxt,+	createInfoFlags = flgs,+	createInfoRenderPass = RenderPass.R rp,+	createInfoAttachments = HeteroParList.toList (\(U3 (ImageView.I iv)) -> iv) -> ivs,+	createInfoWidth = w,+	createInfoHeight = h,+	createInfoLayers = lyrs } = M.CreateInfo {+		M.createInfoNext = mnxt,+		M.createInfoFlags = flgs,+		M.createInfoRenderPass = rp,+		M.createInfoAttachments = ivs,+		M.createInfoWidth = w,+		M.createInfoHeight = h,+		M.createInfoLayers = lyrs }++create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) =>+	Device.D sd -> CreateInfo mn sr aargs ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . F s -> IO a) -> IO a+create (Device.D dvc) ci+	(AllocationCallbacks.toMiddle -> macc) f = bracket+	(M.create dvc (createInfoToMiddle ci) macc)+	(\fb -> M.destroy dvc fb macc) (f . F)++unsafeRecreate :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) =>+	Device.D sd -> CreateInfo mn sr aargs ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	F sf -> IO ()+unsafeRecreate (Device.D dvc) ci+	(AllocationCallbacks.toMiddle -> macc) (F fb) =+	M.recreate dvc (createInfoToMiddle ci) macc macc fb++data Group sd ma sf k = Group (Device.D sd)+	(TPMaybe.M (U2 AllocationCallbacks.A) ma) TSem (TVar (Map.Map k (F sf)))++group :: AllocationCallbacks.ToMiddle ma =>+	Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma ->+	(forall sf . Group sd ma sf k -> IO a) -> IO a+group dvc@(Device.D mdvc) mac@(AllocationCallbacks.toMiddle -> mmac) f = do+	(sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty+	rtn <- f $ Group dvc mac sem m+	((\(F ff) -> M.destroy mdvc ff mmac) `mapM_`) =<< atomically (readTVar m)+	pure rtn++create' :: (+	Ord k, WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle ma) =>+	Group sd ma sf k -> k -> CreateInfo mn sr aargs -> IO (Either String (F sf))+create' (Group (Device.D mdvc)+	(AllocationCallbacks.toMiddle -> mmac) sem sf) k+	(createInfoToMiddle -> ci) = do+	ok <- atomically do+		mx <- Map.lookup k <$> readTVar sf+		case mx of+			Nothing -> waitTSem sem >> pure True+			Just _ -> pure False+	if ok+	then do	f <- M.create mdvc ci mmac+		let	f' = F f+		atomically $ modifyTVar sf (Map.insert k f') >> signalTSem sem+		pure $ Right f'+	else pure . Left $+		"Gpu.Vulkan.Framebuffer.create': The key already exist"++unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) =>+	Group sd ma sf k -> k -> IO (Either String ())+unsafeDestroy (Group (Device.D mdvc)+	(AllocationCallbacks.toMiddle -> ma) sem fs) k = do+	mf <- atomically do+		mx <- Map.lookup k <$> readTVar fs+		case mx of+			Nothing -> pure Nothing+			Just _ -> waitTSem sem >> pure mx+	case mf of+		Nothing -> pure $ Left+			"Gpu.Vulkan.Framebuffer.unsafeDestroy: No such key"+		Just (F f) -> do+			M.destroy mdvc f ma+			atomically do+				modifyTVar fs $ Map.delete k+				signalTSem sem+				pure $ Right ()++lookup :: Ord k => Group sd ma sf k -> k -> IO (Maybe (F sf))+lookup (Group _ _ _sem fs) k = atomically $ Map.lookup k <$> readTVar fs
+ src/Gpu/Vulkan/Framebuffer/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Framebuffer.Enum (module Gpu.Vulkan.Framebuffer.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Framebuffer.Enum
+ src/Gpu/Vulkan/Framebuffer/Type.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Framebuffer.Type where++import qualified Gpu.Vulkan.Framebuffer.Middle as M++newtype F s = F M.F
+ src/Gpu/Vulkan/Image.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Image (++	-- * CREATE++	create, unsafeRecreate, unsafeRecreate', I, Binded, CreateInfo(..),++	-- ** Manage Multiple Image++	Group, group, create', unsafeDestroy, lookup,++	-- * GET MEMORY REQUIREMENTS++	getMemoryRequirements, getMemoryRequirementsBinded,++	-- * MEMORY BARRIER++	MemoryBarrier(..), SubresourceRange(..), MemoryBarrierListToMiddle,++	-- * BLIT++	Blit(..), SubresourceLayers(..),++	-- * ENUM++	module Gpu.Vulkan.Image.Enum++	) where++import Prelude hiding (lookup)+import Gpu.Vulkan.Image.Internal+import Gpu.Vulkan.Image.Enum
+ src/Gpu/Vulkan/Image/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Image.Enum (module Gpu.Vulkan.Image.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Image.Enum
+ src/Gpu/Vulkan/Image/Internal.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Image.Internal (++	-- * CREATE++	create, unsafeRecreate, unsafeRecreate',+	I(..), Binded(..), CreateInfo(..),++	-- ** Manage Destruction++	Group, group, create', unsafeDestroy, lookup,++	-- * GET MEMORY REQUIREMENTS++	getMemoryRequirements, getMemoryRequirementsBinded,++	-- * MEMORY BARRIER++	MemoryBarrier(..), M.SubresourceRange(..),+	MemoryBarrierListToMiddle(..),++	-- * BLIT++	M.Blit(..), M.SubresourceLayers(..)++	) where++import Prelude hiding (lookup)+import GHC.TypeLits+import Foreign.Storable.PeekPoke+import Control.Exception+import Data.Kind+import Data.TypeLevel.Tuple.Uncurry+import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import qualified Data.HeteroParList as HeteroParList+import Data.HeteroParList (pattern (:**))+import Data.Word++import Gpu.Vulkan.Middle+import Gpu.Vulkan.Enum+import Gpu.Vulkan.Image.Type+import Gpu.Vulkan.Image.Enum hiding (Type)++import qualified Gpu.Vulkan.TypeEnum as T+import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.QueueFamily.Middle as QueueFamily+import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.Memory.Middle as Memory+import qualified Gpu.Vulkan.Image.Middle as M+import qualified Gpu.Vulkan.Sample.Enum as Sample+import qualified Gpu.Vulkan.Image.Enum as I++create :: (+	WithPoked (TMaybe.M mn), T.FormatToValue fmt,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd -> CreateInfo mn fmt ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . I s nm fmt -> IO a) -> IO a+create (Device.D mdvc) ci (AllocationCallbacks.toMiddle -> macd) f = bracket+	(M.create mdvc (createInfoToMiddle ci) macd)+	(\i -> M.destroy mdvc i macd)+	(f .I)++data Group sd ma s k nm fmt = Group+	(Device.D sd) (TPMaybe.M (U2 AllocationCallbacks.A) ma) (M.Group s k)++group :: AllocationCallbacks.ToMiddle mac =>+	Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . Group sd mac s k nm fmt -> IO a) -> IO a+group dvc@(Device.D mdvc) ma@(AllocationCallbacks.toMiddle -> mac) f =+	M.group mdvc mac (f . Group dvc ma)++create' :: (+	Ord k, WithPoked (TMaybe.M mn), T.FormatToValue fmt,+	AllocationCallbacks.ToMiddle mac ) =>+	Group sd mac sm k nm fmt -> k -> CreateInfo mn fmt ->+	IO (Either String (I sm nm fmt))+create' (Group (Device.D mdvc) (AllocationCallbacks.toMiddle -> macd) mngr) k ci =+	(I <$>) <$> M.create' mdvc mngr k (createInfoToMiddle ci) macd++unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle mac) =>+	Group sd mac sm k nm fmt -> k -> IO (Either String ())+unsafeDestroy (Group (Device.D mdvc) (AllocationCallbacks.toMiddle -> mac) mngr) k =+	M.destroy' mdvc mngr k mac++lookup :: Ord k => Group sd ma smng k nm fmt -> k -> IO (Maybe (I smng nm fmt))+lookup (Group _ _ mng) k = (I <$>) <$> M.lookup mng k++unsafeRecreate :: (+	WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac,+	T.FormatToValue fmt ) =>+	Device.D sd -> CreateInfo mn fmt ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	Binded sm si nm fmt -> IO ()+unsafeRecreate (Device.D mdvc) ci+	(AllocationCallbacks.toMiddle -> macc) (Binded i) =+	M.recreate mdvc (createInfoToMiddle ci) macc macc i++unsafeRecreate' :: (+	WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac,+	T.FormatToValue fmt ) =>+	Device.D sd -> CreateInfo mn fmt ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	Binded sm si nm fmt -> IO a -> IO ()+unsafeRecreate' (Device.D mdvc) ci+	(AllocationCallbacks.toMiddle -> macc) (Binded i) =+	M.recreate' mdvc (createInfoToMiddle ci) macc macc i++getMemoryRequirements :: Device.D sd -> I si nm fmt -> IO Memory.Requirements+getMemoryRequirements (Device.D dvc) (I img) =+	M.getMemoryRequirements dvc img++getMemoryRequirementsBinded :: Device.D sd -> Binded sm si nm fmt -> IO Memory.Requirements+getMemoryRequirementsBinded (Device.D dvc) (Binded img) =+	M.getMemoryRequirements dvc img++data MemoryBarrier mn sm si nm fmt = MemoryBarrier {+	memoryBarrierNext :: TMaybe.M mn,+	memoryBarrierSrcAccessMask :: AccessFlags,+	memoryBarrierDstAccessMask :: AccessFlags,+	memoryBarrierOldLayout :: Layout,+	memoryBarrierNewLayout :: Layout,+	memoryBarrierSrcQueueFamilyIndex :: QueueFamily.Index,+	memoryBarrierDstQueueFamilyIndex :: QueueFamily.Index,+	memoryBarrierImage :: Binded sm si nm fmt,+	memoryBarrierSubresourceRange :: M.SubresourceRange }++memoryBarrierToMiddle :: MemoryBarrier n si sm nm fmt -> M.MemoryBarrier n+memoryBarrierToMiddle MemoryBarrier {+	memoryBarrierNext = mnxt,+	memoryBarrierSrcAccessMask = sam,+	memoryBarrierDstAccessMask = dam,+	memoryBarrierOldLayout = olyt,+	memoryBarrierNewLayout = nlyt,+	memoryBarrierSrcQueueFamilyIndex = sqfi,+	memoryBarrierDstQueueFamilyIndex = dqfi,+	memoryBarrierImage = Binded img,+	memoryBarrierSubresourceRange = srr } = M.MemoryBarrier {+	M.memoryBarrierNext = mnxt,+	M.memoryBarrierSrcAccessMask = sam,+	M.memoryBarrierDstAccessMask = dam,+	M.memoryBarrierOldLayout = olyt,+	M.memoryBarrierNewLayout = nlyt,+	M.memoryBarrierSrcQueueFamilyIndex = sqfi,+	M.memoryBarrierDstQueueFamilyIndex = dqfi,+	M.memoryBarrierImage = img,+	M.memoryBarrierSubresourceRange = srr }++class MemoryBarrierListToMiddle+	(mbargs :: [(Maybe Type, Type, Type, Symbol, T.Format)])  where+	memoryBarrierListToMiddle ::+		HeteroParList.PL (U5 MemoryBarrier) mbargs ->+		HeteroParList.PL M.MemoryBarrier (TMapIndex.M0_5 mbargs)++instance MemoryBarrierListToMiddle '[] where+	memoryBarrierListToMiddle HeteroParList.Nil = HeteroParList.Nil++instance  MemoryBarrierListToMiddle mbargs =>+	MemoryBarrierListToMiddle ('(mn, si, sm, nm, fmt) ': mbargs) where+	memoryBarrierListToMiddle (U5 mb :** mbs) =+		memoryBarrierToMiddle mb :** memoryBarrierListToMiddle mbs++data CreateInfo mn (fmt :: T.Format) = CreateInfo {+	createInfoNext :: TMaybe.M mn,+	createInfoFlags :: CreateFlags,+	createInfoImageType :: I.Type,+	createInfoExtent :: Extent3d,+	createInfoMipLevels :: Word32,+	createInfoArrayLayers :: Word32,+	createInfoSamples :: Sample.CountFlagBits,+	createInfoTiling :: Tiling,+	createInfoUsage :: UsageFlags,+	createInfoSharingMode :: SharingMode,+	createInfoQueueFamilyIndices :: [Word32],+	createInfoInitialLayout :: Layout }++deriving instance Show (TMaybe.M mn) => Show (CreateInfo mn fmt)++createInfoToMiddle :: forall n fmt .+	T.FormatToValue fmt => CreateInfo n fmt -> M.CreateInfo n+createInfoToMiddle CreateInfo {+	createInfoNext = mnxt,+	createInfoFlags = flgs,+	createInfoImageType = itp,+	createInfoExtent = ext,+	createInfoMipLevels = mls,+	createInfoArrayLayers = als,+	createInfoSamples = smps,+	createInfoTiling = tl,+	createInfoUsage = usg,+	createInfoSharingMode = sm,+	createInfoQueueFamilyIndices = qfis,+	createInfoInitialLayout =ilyt } = M.CreateInfo {+	M.createInfoNext = mnxt,+	M.createInfoFlags = flgs,+	M.createInfoImageType = itp,+	M.createInfoFormat = T.formatToValue @fmt,+	M.createInfoExtent = ext,+	M.createInfoMipLevels = mls,+	M.createInfoArrayLayers = als,+	M.createInfoSamples = smps,+	M.createInfoTiling = tl,+	M.createInfoUsage = usg,+	M.createInfoSharingMode = sm,+	M.createInfoQueueFamilyIndices = qfis,+	M.createInfoInitialLayout = ilyt }
+ src/Gpu/Vulkan/Image/Type.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Image.Type where++import GHC.TypeLits++import qualified Gpu.Vulkan.TypeEnum as T+import qualified Gpu.Vulkan.Image.Middle as M++newtype I s (nm :: Symbol) (fmt :: T.Format) = I M.I++newtype Binded sm si (nm :: Symbol) (fmt :: T.Format) = Binded M.I
+ src/Gpu/Vulkan/ImageView.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.ImageView (++	-- * CREATE++	create, unsafeRecreate, unsafeRecreate', I, CreateInfo(..),++	-- ** Manage Multiple Image View++	group, create', unsafeDestroy, lookup, Group,+	+	-- * ENUM++	module Gpu.Vulkan.ImageView.Enum++	) where++import Prelude hiding (lookup)+import GHC.TypeLits+import Foreign.Storable.PeekPoke+import Control.Exception+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry++import Gpu.Vulkan.ImageView.Type+import Gpu.Vulkan.ImageView.Enum++import qualified Gpu.Vulkan.TypeEnum as T+import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.Component as Component+import qualified Gpu.Vulkan.Image.Type as Image+import qualified Gpu.Vulkan.Image.Middle as Image.M+import qualified Gpu.Vulkan.ImageView.Middle as M++data CreateInfo n sm si nm ifmt (ivfmt :: T.Format) = CreateInfo {+	createInfoNext :: TMaybe.M n,+	createInfoFlags :: CreateFlags,+	createInfoImage :: Image.Binded sm si nm ifmt,+	createInfoViewType :: Type,+	createInfoComponents :: Component.Mapping,+	createInfoSubresourceRange :: Image.M.SubresourceRange }++createInfoToMiddle :: forall n si sm nm ifmt ivfmt . T.FormatToValue ivfmt =>+	CreateInfo n si sm nm ifmt ivfmt -> M.CreateInfo n+createInfoToMiddle CreateInfo {+	createInfoNext = mnxt,+	createInfoFlags = flgs,+	createInfoImage = Image.Binded img,+	createInfoViewType = tp,+	createInfoComponents = cps,+	createInfoSubresourceRange = srr } = M.CreateInfo {+	M.createInfoNext = mnxt,+	M.createInfoFlags = flgs,+	M.createInfoImage = img,+	M.createInfoViewType = tp,+	M.createInfoFormat = fmt,+	M.createInfoComponents = cps,+	M.createInfoSubresourceRange = srr }+	where fmt = T.formatToValue @ivfmt++create :: (+	WithPoked (TMaybe.M mn), T.FormatToValue ivfmt,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd -> CreateInfo mn sm si nm ifmt ivfmt ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . I nm ivfmt s -> IO a) -> IO a+create (Device.D d) ci (AllocationCallbacks.toMiddle -> mac) f = bracket+	(M.create d (createInfoToMiddle ci) mac)+	(\i -> M.destroy d i mac) (f . I)++group ::+	AllocationCallbacks.ToMiddle ma =>+	Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma ->+	(forall s . Group sd ma s k nm ivfmt -> IO a) -> IO a+group dvc@(Device.D d) ma@(AllocationCallbacks.toMiddle -> mac) f =+	M.group d mac $ f . Group dvc ma++data Group sd ma s k (nm :: Symbol) (ivfmt :: T.Format) = Group+	(Device.D sd) (TPMaybe.M (U2 AllocationCallbacks.A) ma) (M.Group s k)++create' :: (+	Ord k, WithPoked (TMaybe.M mn), T.FormatToValue ivfmt,+	AllocationCallbacks.ToMiddle ma ) =>+	Group sd ma smng k nm ivfmt -> k ->+	CreateInfo mn sm si nm ifmt ivfmt ->+	IO (Either String (I nm ivfmt smng))+create' (Group (Device.D d)+	(AllocationCallbacks.toMiddle -> mac) mng) k ci =+	(I <$>) <$> M.create' d mng k (createInfoToMiddle ci) mac++unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) =>+	Group sd ma sm k nm ivfmt  -> k -> IO (Either String ())+unsafeDestroy (Group (Device.D d)+	(AllocationCallbacks.toMiddle -> mac) mng) k =+	M.destroy' d mng k mac++lookup :: Ord k => Group sd ma smng k nm ivfmt -> k -> IO (Maybe (I nm ivfmt smng))+lookup (Group _ _ mng) k = (I <$>) <$> M.lookup mng k++unsafeRecreate :: (+	WithPoked (TMaybe.M mn), T.FormatToValue ivfmt,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd -> CreateInfo mn sm si nm ifmt ivfmt ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac -> I nm ivfmt siv -> IO ()+unsafeRecreate (Device.D d) ci+	(AllocationCallbacks.toMiddle -> mac) (I i) =+	M.recreate d (createInfoToMiddle ci) mac mac i++unsafeRecreate' :: (+	WithPoked (TMaybe.M mn), T.FormatToValue ivfmt,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd -> CreateInfo mn sm si nm ifmt ivfmt ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac -> I nm ivfmt siv -> IO a -> IO ()+unsafeRecreate' (Device.D d) ci+	(AllocationCallbacks.toMiddle -> mac) (I i) =+	M.recreate' d (createInfoToMiddle ci) mac mac i
+ src/Gpu/Vulkan/ImageView/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.ImageView.Enum (module Gpu.Vulkan.ImageView.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.ImageView.Enum
+ src/Gpu/Vulkan/ImageView/Type.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE KindSignatures #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.ImageView.Type where++import GHC.TypeLits++import Gpu.Vulkan.TypeEnum as T+import Gpu.Vulkan.ImageView.Middle qualified as M++newtype I (nm :: Symbol) (fmt :: T.Format) si = I M.I deriving Show
+ src/Gpu/Vulkan/Instance.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Instance (++	-- * CREATE++	create, I, CreateInfo(..), ExtensionName(..),++	-- * ENUMERATE++	enumerateLayerProperties,+	enumerateExtensionProperties, ExtensionProperties(..),++	) where++import Gpu.Vulkan.Instance.Internal
+ src/Gpu/Vulkan/Instance/Internal.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Instance.Internal (++	-- * CREATE++	create, I(..), CreateInfo(..), ExtensionName(..),++	-- * ENUMERATE++	enumerateLayerProperties,+	enumerateExtensionProperties, ExtensionProperties(..),++	) where++import Foreign.Storable.PeekPoke+import Control.Exception+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry+import Data.Default++import Gpu.Vulkan.Internal+import Gpu.Vulkan.Instance.Type++import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import Gpu.Vulkan.Instance.Enum+import qualified Gpu.Vulkan.Instance.Middle as M++import Data.Text qualified as T+import Gpu.Vulkan.Middle qualified as M++create :: (+	WithPoked (TMaybe.M mn), WithPoked (TMaybe.M ai),+	AllocationCallbacks.ToMiddle mac ) =>+	CreateInfo mn ai ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . I s -> IO a) -> IO a+create (createInfoToMiddle -> ci) (AllocationCallbacks.toMiddle -> mac) f =+	bracket (M.create ci mac) (`M.destroy` mac) (f . I)++data CreateInfo mn ai = CreateInfo {+	createInfoNext :: TMaybe.M mn,+	createInfoFlags :: CreateFlags,+	createInfoApplicationInfo :: Maybe (ApplicationInfo ai),+	createInfoEnabledLayerNames :: [LayerName],+	createInfoEnabledExtensionNames :: [ExtensionName] }++newtype ExtensionName = ExtensionName { unExtensionName :: T.Text }+	deriving (Show, Eq)++deriving instance (Show (TMaybe.M mn), Show (TMaybe.M ai)) =>+	Show (CreateInfo mn ai)++instance Default (CreateInfo 'Nothing a) where+	def = CreateInfo {+		createInfoNext = TMaybe.N,+		createInfoFlags = CreateFlagsZero,+		createInfoApplicationInfo = Nothing,+		createInfoEnabledLayerNames = [],+		createInfoEnabledExtensionNames = [] }++createInfoToMiddle :: CreateInfo mn ai -> M.CreateInfo mn ai+createInfoToMiddle CreateInfo {+	createInfoNext = nxt,+	createInfoFlags = flgs,+	createInfoApplicationInfo = ai,+	createInfoEnabledLayerNames = lns,+	createInfoEnabledExtensionNames = ens } = M.CreateInfo {+	M.createInfoNext = nxt,+	M.createInfoFlags = flgs,+	M.createInfoApplicationInfo = ai,+	M.createInfoEnabledLayerNames = unLayerName <$> lns,+	M.createInfoEnabledExtensionNames = unExtensionName <$> ens }++enumerateLayerProperties :: IO [LayerProperties]+enumerateLayerProperties =+	(layerPropertiesFromMiddle <$>) <$> M.enumerateLayerProperties++enumerateExtensionProperties ::+	Maybe LayerName -> IO [ExtensionProperties]+enumerateExtensionProperties (((\(LayerName ln) -> ln) <$>) -> mln) =+	(extensionPropertiesFromMiddle <$>)+		<$> M.enumerateExtensionProperties mln++data ExtensionProperties = ExtensionProperties {+	extensionPropertiesExtensionName :: ExtensionName,+	extensionPropertiesSpecVersion :: M.ApiVersion }+	deriving Show++extensionPropertiesFromMiddle :: M.ExtensionProperties -> ExtensionProperties+extensionPropertiesFromMiddle M.ExtensionProperties {+	M.extensionPropertiesExtensionName = en,+	M.extensionPropertiesSpecVersion = sv } = ExtensionProperties {+	extensionPropertiesExtensionName = ExtensionName en,+	extensionPropertiesSpecVersion = sv }
+ src/Gpu/Vulkan/Instance/Type.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Instance.Type (I(..)) where++import qualified Gpu.Vulkan.Instance.Middle as M++newtype I s = I { unI :: M.I } deriving Show
+ src/Gpu/Vulkan/Internal.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase, OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Internal (++	-- * INFO++	-- ** ApplicationINfo++	M.ApplicationInfo(..),+	M.ApiVersion, M.makeApiVersion, M.apiVersion_1_0, M.apiVersion_1_1,++	-- ** SubmitInfo++	SubmitInfo(..),+	SubmitInfoListToMiddle(..), SemaphorePipelineStageFlags(..),++	-- * PROPERTIES++	LayerProperties(..), layerPropertiesFromMiddle,+	M.FormatProperties(..),++	-- * NAME++	LayerName(..), layerKhronosValidation,++	-- * PIPELINE VALUES++	-- ** ViewPort++	M.Viewport, pattern M.Viewport,+	M.viewportX, M.viewportY, M.viewportWidth, M.viewportHeight,+	M.viewportMinDepth, M.viewportMaxDepth,++	-- ** StencilOpState++	M.StencilOpState(..),++	-- ** ClearValue++	M.ClearValue(..), M.ClearValueListToCore,++	-- *** ClearType++	M.ClearType(..), M.ClearColorType(..),++	-- *** ClearColorValue++	-- *** ClearDepthStencilValue++	M.ClearDepthStencilValue, pattern M.ClearDepthStencilValue,+	M.clearDepthStencilValueDepth, M.clearDepthStencilValueStencil,++	-- * RECT, OFFSET AND EXTENT++	-- ** Rect++	M.Rect2d, pattern M.Rect2d, M.rect2dExtent, M.rect2dOffset,++	-- ** Offset++	M.Offset2d, pattern M.Offset2d, M.offset2dX, M.offset2dY,+	M.Offset3d, pattern M.Offset3d, M.offset3dX, M.offset3dY, M.offset3dZ,++	-- ** Extent++	M.Extent2d, pattern M.Extent2d,+	M.extent2dWidth, M.extent2dHeight,++	M.Extent3d, pattern M.Extent3d,+	M.extent3dWidth, M.extent3dHeight, M.extent3dDepth,++	-- * OTHERS++	M.Size(..)++	) where++import Foreign.Storable.PeekPoke+import Data.Kind+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.Tuple.Uncurry+import Data.HeteroParList qualified as HeteroParList+import Data.HeteroParList (pattern (:**))+import Data.Text qualified as T++import qualified Gpu.Vulkan.Middle as M+import qualified Gpu.Vulkan.Semaphore.Type as Semaphore+import qualified Gpu.Vulkan.Semaphore.Middle as Semaphore.M+import qualified Gpu.Vulkan.CommandBuffer.Type as CommandBuffer+import qualified Gpu.Vulkan.Pipeline.Enum as Pipeline++data SubmitInfo n sss ss ssss = SubmitInfo {+	submitInfoNext :: TMaybe.M n,+	submitInfoWaitSemaphoreDstStageMasks ::+		HeteroParList.PL SemaphorePipelineStageFlags sss,+	submitInfoCommandBuffers :: HeteroParList.PL CommandBuffer.C ss,+	submitInfoSignalSemaphores ::+		HeteroParList.PL Semaphore.S ssss }++class M.SubmitInfoListToCore (MiddleNextList ns3s2s4) => SubmitInfoListToMiddle+	(ns3s2s4 :: [(Maybe Type, [Type], [Type], [Type])]) where+	type MiddleNextList ns3s2s4 :: [Maybe Type]+	submitInfoListToMiddle ::+		HeteroParList.PL (U4 SubmitInfo) ns3s2s4 ->+		HeteroParList.PL M.SubmitInfo (MiddleNextList ns3s2s4)++instance SubmitInfoListToMiddle '[] where+	type MiddleNextList '[] = '[]+	submitInfoListToMiddle HeteroParList.Nil = HeteroParList.Nil++instance (+	WithPoked (TMaybe.M n),+	SubmitInfoListToMiddle nssvsss ) =>+	SubmitInfoListToMiddle ('(n, sss, svss, ssss) ': nssvsss) where+	type MiddleNextList ('(n, sss, svss, ssss) ': nssvsss) =+		n ': MiddleNextList nssvsss+	submitInfoListToMiddle (U4 si :** sis) =+		submitInfoToMiddle si :** submitInfoListToMiddle sis++submitInfoToMiddle ::+	SubmitInfo n sss svss ssss -> M.SubmitInfo n+submitInfoToMiddle SubmitInfo {+	submitInfoNext = mnxt,+	submitInfoWaitSemaphoreDstStageMasks =+		semaphorePipelineStageFlagsToMiddle -> wsdsms,+	submitInfoCommandBuffers = HeteroParList.toList (\x -> CommandBuffer.unC x) -> cbs,+	submitInfoSignalSemaphores =+		HeteroParList.toList (\(Semaphore.S s) -> s) -> ssmprs+	} = M.SubmitInfo {+	M.submitInfoNext = mnxt,+	M.submitInfoWaitSemaphoreDstStageMasks = wsdsms,+	M.submitInfoCommandBuffers = cbs,+	M.submitInfoSignalSemaphores = ssmprs }++data SemaphorePipelineStageFlags ss =+	SemaphorePipelineStageFlags (Semaphore.S ss) Pipeline.StageFlags+	deriving Show++-- deriving instance (Show n, Show (HeteroParList SemaphorePipelineStageFlags sss)) =>+--	Show (SubmitInfo n sss s vs)++-- deriving instance Show (HeteroParList Semaphore.S ss)++semaphorePipelineStageFlagsToMiddle ::+	HeteroParList.PL SemaphorePipelineStageFlags sss ->+	[(Semaphore.M.S, Pipeline.StageFlags)]+semaphorePipelineStageFlagsToMiddle = HeteroParList.toList+	\(SemaphorePipelineStageFlags (Semaphore.S s) psfs) -> (s, psfs)++class SemaphorePipelineStageFlagsFromMiddle sss where+	semaphorePipelineStageFlagsFromMiddle ::+		[(Semaphore.M.S, Pipeline.StageFlags)] ->+		HeteroParList.PL SemaphorePipelineStageFlags sss++instance SemaphorePipelineStageFlagsFromMiddle '[] where+	semaphorePipelineStageFlagsFromMiddle = \case+		[] -> HeteroParList.Nil+		_ -> error $+			"semaphorePipelineStageFlagsFromMiddle @'[] xs: " +++			"xs should be null"++instance SemaphorePipelineStageFlagsFromMiddle sss =>+	SemaphorePipelineStageFlagsFromMiddle (ss ': sss) where+	semaphorePipelineStageFlagsFromMiddle = \case+		(s, psfs) : spsfss ->+			SemaphorePipelineStageFlags (Semaphore.S s) psfs :**+			semaphorePipelineStageFlagsFromMiddle spsfss+		[] -> error $+			"semaphorePipelineStageFlagsFromMiddle " +++			"@(ss ': sss) xs: xs should not be null"++data LayerProperties = LayerProperties {+	layerPropertiesLayerName :: LayerName,+	layerPropertiesSpecVersion :: M.ApiVersion,+	layerPropertiesImplementationVersion :: M.ApiVersion,+	layerPropertiesDescription :: T.Text }+	deriving Show++layerPropertiesFromMiddle :: M.LayerProperties -> LayerProperties+layerPropertiesFromMiddle M.LayerProperties {+	M.layerPropertiesLayerName = ln,+	M.layerPropertiesSpecVersion = sv,+	M.layerPropertiesImplementationVersion = iv,+	M.layerPropertiesDescription = dsc } = LayerProperties {+	layerPropertiesLayerName = LayerName ln,+	layerPropertiesSpecVersion = sv,+	layerPropertiesImplementationVersion = iv,+	layerPropertiesDescription = dsc }++newtype LayerName = LayerName { unLayerName :: T.Text } deriving (Show, Eq)++layerKhronosValidation :: LayerName+layerKhronosValidation = LayerName "VK_LAYER_KHRONOS_validation"
+ src/Gpu/Vulkan/Memory.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Memory (++	-- * ALLOCATE AND BIND++	allocateBind, unsafeReallocateBind, unsafeReallocateBind',++	-- ** Destruction Group++	Group, group, allocateBind', unsafeFree, lookup,++	-- ** MEMORY++	M, getBinded, ImageBuffer(..), ImageBufferBinded(..), ImageBufferArg(..),++	-- ** ALLOCATE INFO++	AllocateInfo(..), M.MType(..), M.TypeBits, M.TypeIndex, M.elemTypeIndex,++	-- ** BINDABLE AND REBINDABLE++	Bindable, Rebindable,++	-- * GET REQUREMENTS++	getRequirementsList, M.Requirements(..),++	-- * READ AND WRITE++	read, write, OffsetSize,++	-- * BARRIER++	M.Barrier(..),++	-- * ENUM++	module Gpu.Vulkan.Memory.Enum++	) where++import Prelude hiding (map, read, lookup)++import Foreign.Ptr+import Foreign.Storable.PeekPoke+import Control.Concurrent.STM+import Control.Exception hiding (try)+import Gpu.Vulkan.Object qualified as VObj+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry+import Data.Maybe+import Data.Map qualified as Map+import Data.HeteroParList qualified as HeteroParList+import Data.IORef++import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.Device.Middle as Device.M+import qualified Gpu.Vulkan.Memory.Middle as M+import Gpu.Vulkan.Memory.Enum++import Gpu.Vulkan.Memory.Bind+import Gpu.Vulkan.Memory.OffsetSize+import Gpu.Vulkan.Memory.Type+import Gpu.Vulkan.Memory.ImageBuffer++import Control.Monad+import Debug++-- ALLOCATE AND BIND++-- Allocate Bind++allocateBind :: (+	WithPoked (TMaybe.M mn), Bindable ibargs,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd -> HeteroParList.PL (U2 ImageBuffer) ibargs ->+	AllocateInfo mn -> TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . HeteroParList.PL (U2 (ImageBufferBinded s)) ibargs ->+		M s ibargs -> IO a) -> IO a+allocateBind dv ibs ai mac f =+	allocate dv ibs ai mac \m -> (`f` m) =<< bindAll dv ibs m 0++allocate :: (+	WithPoked (TMaybe.M n), Alignments ibargs,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd -> HeteroParList.PL (U2 ImageBuffer) ibargs ->+	AllocateInfo n -> TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . M s ibargs -> IO a) -> IO a+allocate dv@(Device.D mdv) ibs ai+	(AllocationCallbacks.toMiddle -> mac) f = bracket+	do	mai <- allocateInfoToMiddle dv ibs ai+		M.allocate mdv mai mac+	(\m -> M.free mdv m mac)+	\m -> f =<< newM ibs m++group :: AllocationCallbacks.ToMiddle ma =>+	Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma ->+	(forall s . Group sd ma s k ibargs -> IO a) -> IO a+group dvc@(Device.D mdvc) ma@(AllocationCallbacks.toMiddle -> mac) f =+	M.group mdvc mac \mmng -> do+		ibargs <- atomically $ newTVar Map.empty+		f $ Group dvc ma ibargs mmng++allocateBind' :: (+	Ord k,+	WithPoked (TMaybe.M mn), Bindable ibargs,+	AllocationCallbacks.ToMiddle ma ) =>+	Group sd ma sm k ibargs -> k ->+	HeteroParList.PL (U2 ImageBuffer) ibargs -> AllocateInfo mn ->+	IO (Either String (+		HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs,+		M sm ibargs))+allocateBind' (Group dv mac mib mng) k ibs ai = do+	allocate' dv mng k ibs ai mac >>= \case+		Left msg -> pure $ Left msg+		Right m -> do+			rtn@(_, M iibs _) <- (, m) <$> bindAll dv ibs m 0+			atomically $ modifyTVar mib (Map.insert k iibs)+			pure $ Right rtn++allocate' :: (+	Ord k,+	WithPoked (TMaybe.M n), Alignments ibargs,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd -> M.Group sm k -> k ->+	HeteroParList.PL (U2 ImageBuffer) ibargs ->+	AllocateInfo n -> TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	IO (Either String (M sm ibargs))+allocate' dv@(Device.D mdv) mng k ibs ai (AllocationCallbacks.toMiddle -> mac) = do+	mai <- allocateInfoToMiddle dv ibs ai+	(newM ibs `mapM`) =<< M.allocate' mdv mng k mai mac++unsafeFree :: (Ord k, AllocationCallbacks.ToMiddle ma) =>+	Group sd ma smng k ibargs -> k -> IO (Either String ())+unsafeFree (Group (Device.D mdv) (AllocationCallbacks.toMiddle -> mac) _ mng) k =+	M.free' mdv mng k mac++data Group sd ma s k ibargs = Group (Device.D sd)+	(TPMaybe.M (U2 AllocationCallbacks.A) ma)+	(TVar (Map.Map k (IORef (HeteroParList.PL (U2 ImageBuffer) ibargs))))+	(M.Group s k)++lookup :: Ord k =>+	Group sd ma sm k ibargs -> k -> IO (Maybe (M s ibargs))+lookup (Group _ _ ibargss mmng) k = do+	mibargs <- atomically $ Map.lookup k <$> readTVar ibargss+	mmem <- M.lookup mmng k+	pure $ M <$> mibargs <*> mmem++-- Reallocate Bind++unsafeReallocateBind :: (+	WithPoked (TMaybe.M mn), Rebindable ibargs,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd -> HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs ->+	AllocateInfo mn -> TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	M sm ibargs -> IO ()+unsafeReallocateBind dv ibs ai mac m =+	reallocate dv ibs ai mac m >> rebindAll dv ibs m 0++unsafeReallocateBind' :: (+	WithPoked (TMaybe.M mn), Rebindable ibargs,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd -> HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs ->+	AllocateInfo mn -> TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	M sm ibargs -> IO a -> IO ()+unsafeReallocateBind' dv ibs ai mac m act =+	reallocate' dv ibs ai mac m $ rebindAll dv ibs m 0 >> act++reallocate :: (+	WithPoked (TMaybe.M n), Alignments ibargs,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd -> HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs ->+	AllocateInfo n -> TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	M sm ibargs -> IO ()+reallocate dv@(Device.D mdv) ibs ai (AllocationCallbacks.toMiddle -> mac) m = do+	mai <- reallocateInfoToMiddle dv ibs ai+	(_, mm) <- readM m+	M.reallocate mdv mai mac mm+	writeMBinded m ibs++reallocate' :: (+	WithPoked (TMaybe.M n), Alignments ibargs,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd -> HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs ->+	AllocateInfo n -> TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	M sm ibargs -> IO a -> IO ()+reallocate' dv@(Device.D mdv) ibs ai (AllocationCallbacks.toMiddle -> mac) m act = do+	mai <- reallocateInfoToMiddle dv ibs ai+	(_, mm) <- readM m+	M.reallocate' mdv mai mac mm $ writeMBinded m ibs >> act++-- Allocate Info++data AllocateInfo mn = AllocateInfo {+	allocateInfoNext :: TMaybe.M mn,+	allocateInfoMemoryTypeIndex :: M.TypeIndex }++deriving instance Show (TMaybe.M mn) => Show (AllocateInfo mn)+deriving instance Eq (TMaybe.M mn) => Eq (AllocateInfo mn)++allocateInfoToMiddle :: forall sd ibargs mn . Alignments ibargs =>+	Device.D sd -> HeteroParList.PL (U2 ImageBuffer) ibargs ->+	AllocateInfo mn -> IO (M.AllocateInfo mn)+allocateInfoToMiddle dv ibs AllocateInfo {+	allocateInfoNext = mnxt,+	allocateInfoMemoryTypeIndex = mti } = do+	reqss <- getRequirementsList dv ibs+	pure M.AllocateInfo {+		M.allocateInfoNext = mnxt,+		M.allocateInfoAllocationSize = memoryRequirementsListToSize+			0 (alignments @ibargs) reqss,+		M.allocateInfoMemoryTypeIndex = mti }++reallocateInfoToMiddle :: forall sd sm ibargs mn . Alignments ibargs =>+	Device.D sd -> HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs ->+	AllocateInfo mn -> IO (M.AllocateInfo mn)+reallocateInfoToMiddle dv ibs AllocateInfo {+	allocateInfoNext = mnxt,+	allocateInfoMemoryTypeIndex = mti } = do+	reqss <- getRequirementsListBinded dv ibs+	pure M.AllocateInfo {+		M.allocateInfoNext = mnxt,+		M.allocateInfoAllocationSize = memoryRequirementsListToSize+			0 (alignments @ibargs) reqss,+		M.allocateInfoMemoryTypeIndex = mti }++memoryRequirementsListToSize ::+	Device.M.Size -> [Maybe Device.M.Size] -> [M.Requirements] -> Device.M.Size+memoryRequirementsListToSize sz0 _ [] = sz0+memoryRequirementsListToSize sz0 [] _ = sz0+memoryRequirementsListToSize sz0 (malgn : malgns) (reqs : reqss) =+	memoryRequirementsListToSize+		(((sz0 - 1) `div` algn + 1) * algn + sz) malgns reqss+	where+	sz = M.requirementsSize reqs+	algn = (fromMaybe 1 malgn) `lcm`+		M.requirementsAlignment reqs++-- READ AND WRITE++read :: forall nm obj i v sd sm ibargs .+	(VObj.Store v obj, OffsetSize nm obj ibargs i) =>+	Device.D sd -> M sm ibargs -> M.MapFlags -> IO v+read dv m flgs = bracket+	(map @nm @obj @i dv m flgs) (const $ unmap dv m)+	\(ptr :: Ptr (VObj.TypeOf obj)) ->+		VObj.load @_ @obj ptr =<< objectLength @nm @obj m++write :: forall nm obj i sd sm ibargs v .+	(VObj.Store v obj, OffsetSize nm obj ibargs i) =>+	Device.D sd -> M sm ibargs -> M.MapFlags -> v -> IO ()+write dv m flgs v = bracket+	(map @nm @obj @i dv m flgs) (const $ unmap dv m)+	\(ptr :: Ptr (VObj.TypeOf obj)) -> do+		ln <- objectLength @nm @obj m+		VObj.store @_ @obj ptr ln v++map :: forall nm obj i sd sm ibargs . OffsetSize nm obj ibargs i =>+	Device.D sd -> M sm ibargs -> M.MapFlags ->+	IO (Ptr (VObj.TypeOf obj))+map dv@(Device.D mdv) m flgs = readM m >>= \(_, mm) -> do+	(ost, sz) <- offsetSize @nm @obj @_ @i dv m 0+	when debug $ print (ost, sz)+	M.map mdv mm ost sz flgs++unmap :: Device.D sd -> M sm ibargs -> IO ()+unmap (Device.D mdv) m = M.unmap mdv . snd =<< readM m
+ src/Gpu/Vulkan/Memory/Bind.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Memory.Bind (++	-- * BIND AND REBIND++	Bindable, Rebindable, BindAll(..), RebindAll(..)++	) where++import Data.TypeLevel.Tuple.Uncurry+import Data.HeteroParList qualified as HeteroParList+import Data.HeteroParList (pattern (:**))++import Gpu.Vulkan.Device.Type qualified as Device+import Gpu.Vulkan.Device.Middle qualified as Device.M+import Gpu.Vulkan.Memory.ImageBuffer++import Gpu.Vulkan.Buffer.Type qualified as Buffer+import Gpu.Vulkan.Buffer.Middle qualified as Buffer.M++import Gpu.Vulkan.Image.Type qualified as Image+import Gpu.Vulkan.Image.Middle qualified as Image.M++import Gpu.Vulkan.Memory.Type++class (BindAll ibargs ibargs, Alignments ibargs) => Bindable ibargs+instance (BindAll ibargs ibargs , Alignments ibargs) => Bindable ibargs++class BindAll ibargs mibargs where+	bindAll :: Device.D sd -> HeteroParList.PL (U2 ImageBuffer) ibargs ->+		M sm mibargs -> Device.M.Size ->+		IO (HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs)++instance BindAll '[] mibargs where bindAll _ _ _ _ = pure HeteroParList.Nil++instance BindAll ibargs mibargs =>+	BindAll ('(si, ('ImageArg nm fmt)) ': ibargs) mibargs where+	bindAll dv@(Device.D mdv) (U2 ii@(Image (Image.I i)) :** ibs) m ost = do+		(_, mm) <- readM m+		(ost', sz) <- adjustOffsetSize dv ii ost+		Image.M.bindMemory mdv i mm ost'+		(U2 (ImageBinded $ Image.Binded i) :**)+			<$> bindAll dv ibs m (ost' + sz)++instance BindAll ibargs mibargs =>+	BindAll ('(sb, ('BufferArg nm objs)) ': ibargs) mibargs where+	bindAll dv@(Device.D mdv)+		(U2 bb@(Buffer (Buffer.B lns b)) :** ibs) m ost  = do+		(_, mm) <- readM m+		(ost', sz) <- adjustOffsetSize dv bb ost+		Buffer.M.bindMemory mdv b mm ost'+		(U2 (BufferBinded $ Buffer.Binded lns b) :**)+			<$> bindAll dv ibs m (ost' + sz)++class (RebindAll ibargs ibargs, Alignments ibargs) => Rebindable ibargs+instance (RebindAll ibargs ibargs, Alignments ibargs) => Rebindable ibargs++class RebindAll ibargs mibargs where+	rebindAll :: Device.D sd ->+		HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs ->+		M sm mibargs -> Device.M.Size -> IO ()++instance RebindAll '[] mibargs where rebindAll _ _ _ _ = pure ()++instance RebindAll ibargs mibargs =>+	RebindAll ('(si, 'ImageArg nm fmt) ': ibargs) mibargs where+	rebindAll dv@(Device.D mdv)+		(U2 ii@(ImageBinded (Image.Binded i)) :** ibs) m ost = do+		(_, mm) <- readM m+		(ost', sz) <- adjustOffsetSizeBinded dv ii ost+		Image.M.bindMemory mdv i mm ost'+		rebindAll dv ibs m $ ost' + sz++instance RebindAll ibargs mibargs =>+	RebindAll ('(sb, 'BufferArg nm objs) ': ibargs) mibargs where+	rebindAll dv@(Device.D mdv)+		(U2 bb@(BufferBinded (Buffer.Binded _lns b)) :** ibs) m ost = do+		(_, mm) <- readM m+		(ost', sz) <- adjustOffsetSizeBinded dv bb ost+		Buffer.M.bindMemory mdv b mm ost'+		rebindAll dv ibs m $ ost' + sz
+ src/Gpu/Vulkan/Memory/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Memory.Enum (module Gpu.Vulkan.Memory.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Memory.Enum
+ src/Gpu/Vulkan/Memory/ImageBuffer.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Memory.ImageBuffer (++	-- * IMAGE BUFFER++	ImageBuffer(..), ImageBufferBinded(..), ImageBufferArg(..),++	-- * GET REQUIREMENTS LIST++	getRequirementsList, getRequirementsListBinded,++	-- * ADJUST OFFSET AND GET SIZE++	adjustOffsetSize, adjustOffsetSizeBinded,++	-- * FOR BIND++	Alignments(..),++	-- * FOR READ AND WRITE++	ObjectLength(..)++	) where++import Prelude hiding (map, read)+import GHC.TypeLits+import Data.Kind+import Data.TypeLevel.Tuple.Uncurry+import Gpu.Vulkan.Object qualified as VObj+import Data.HeteroParList qualified as HeteroParList+import Data.HeteroParList (pattern (:**))++import qualified Gpu.Vulkan.Image.Type as Image+import qualified Gpu.Vulkan.Buffer.Type as Buffer++import qualified Gpu.Vulkan.TypeEnum as T++import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.Device.Middle as Device.M++import qualified Gpu.Vulkan.Image.Middle as Image.M+import qualified Gpu.Vulkan.Buffer.Middle as Buffer.M+import qualified Gpu.Vulkan.Memory.Middle as Memory.M++-- IMAGE BUFFER++data ImageBuffer s (ibarg :: ImageBufferArg) where+	Image :: Image.I si nm fmt -> ImageBuffer si ('ImageArg nm fmt)+	Buffer :: Buffer.B sb nm objs -> ImageBuffer sb ('BufferArg nm objs)++deriving instance Show (HeteroParList.PL VObj.Length objs) =>+	Show (ImageBuffer sib ('BufferArg nm objs))++data ImageBufferBinded sm sib (ibarg :: ImageBufferArg) where+	ImageBinded :: Image.Binded sm si nm fmt ->+		ImageBufferBinded sm si ('ImageArg nm fmt)+	BufferBinded :: Buffer.Binded sm sb nm objs ->+		ImageBufferBinded sm sb ('BufferArg nm objs)++deriving instance Show (HeteroParList.PL VObj.Length objs) =>+	Show (ImageBufferBinded sm sib ('BufferArg nm objs))++data ImageBufferArg = ImageArg Symbol T.Format | BufferArg Symbol [VObj.O]++-- GET REQUIREMENTS LIST++getRequirementsList :: Device.D sd ->+	HeteroParList.PL (U2 ImageBuffer) ibargs -> IO [Memory.M.Requirements]+getRequirementsList dv =+	HeteroParList.toListM \(U2 bi) -> getMemoryRequirements dv bi++getRequirementsListBinded ::+	Device.D sd -> HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs ->+	IO [Memory.M.Requirements]+getRequirementsListBinded dv =+	HeteroParList.toListM \(U2 bi) -> getMemoryRequirementsBinded dv bi++getMemoryRequirements ::+	Device.D sd -> ImageBuffer sib fos -> IO Memory.M.Requirements+getMemoryRequirements (Device.D dv) = \case+	Buffer (Buffer.B _ b) -> Buffer.M.getMemoryRequirements dv b+	Image (Image.I i) -> Image.M.getMemoryRequirements dv i++getMemoryRequirementsBinded ::+	Device.D sd -> ImageBufferBinded sm sib fos -> IO Memory.M.Requirements+getMemoryRequirementsBinded (Device.D dv) = \case+	BufferBinded (Buffer.Binded _ b) -> Buffer.M.getMemoryRequirements dv b+	ImageBinded (Image.Binded i) -> Image.M.getMemoryRequirements dv i++-- ADJUST OFFSET AND GET SIZE++adjustOffsetSize :: Device.D sd -> ImageBuffer sib ibarg -> Device.M.Size ->+	IO (Device.M.Size, Device.M.Size)+adjustOffsetSize dv ib ost = (<$> getMemoryRequirements dv ib) \rs -> (+	adjust (Memory.M.requirementsAlignment rs) ost,+	Memory.M.requirementsSize rs )++adjustOffsetSizeBinded :: Device.D sd -> ImageBufferBinded sm sib ibarg ->+	Device.M.Size -> IO (Device.M.Size, Device.M.Size)+adjustOffsetSizeBinded dv ib ost =+	(<$> getMemoryRequirementsBinded dv ib) \rs -> (+		adjust (Memory.M.requirementsAlignment rs) ost,+		Memory.M.requirementsSize rs )++adjust :: Device.M.Size -> Device.M.Size -> Device.M.Size+adjust algn ost = ((ost - 1) `div` algn + 1) * algn++-- ALIGNMENTS++class Alignments (ibs :: [(Type, ImageBufferArg)]) where+	alignments :: [Maybe Device.M.Size]++instance Alignments '[] where alignments = []++instance Alignments ibs => Alignments ('(_s, 'ImageArg _nm _fmt) ': ibs) where+	alignments = Nothing : alignments @ibs++instance (VObj.WholeAlign objs, Alignments ibs) =>+	Alignments ('(_s, 'BufferArg _nm objs) ': ibs) where+	alignments = Just (VObj.wholeAlign @objs) : alignments @ibs++-- OBJECT LENGTH++class ObjectLength (nm :: Symbol) (obj :: VObj.O) ibargs where+	objectLength' :: HeteroParList.PL (U2 ImageBuffer) ibargs ->+		VObj.Length obj++instance VObj.LengthOf obj objs =>+	ObjectLength nm obj ('(sib, 'BufferArg nm objs) ': ibargs) where+	objectLength' (U2 (Buffer (Buffer.B lns _)) :** _) =+		VObj.lengthOf @obj lns++instance {-# OVERLAPPABLE #-} ObjectLength nm obj ibargs =>+	ObjectLength nm obj (ibarg ': ibargs) where+	objectLength' (_ :** lns) = objectLength' @nm @obj lns
+ src/Gpu/Vulkan/Memory/OffsetSize.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, TupleSections #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Memory.OffsetSize (++	-- * OFFSET SIZE++	offsetSize, OffsetSize,++	) where++import Prelude hiding (map, read)+import GHC.TypeLits+import Gpu.Vulkan.Object qualified as VObj+import Data.TypeLevel.Tuple.Uncurry+import qualified Data.HeteroParList as HeteroParList+import Data.HeteroParList (pattern (:**))++import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.Device.Middle as Device.M+import qualified Gpu.Vulkan.Buffer.Type as Buffer++import Gpu.Vulkan.Memory.Type+import Gpu.Vulkan.Memory.ImageBuffer++offsetSize :: forall nm obj ibargs i sd sm . OffsetSize nm obj ibargs i =>+	Device.D sd -> M sm ibargs -> Device.M.Size ->+	IO (Device.M.Size, Device.M.Size)+offsetSize dvc m ost =+	readM m >>= \(ibs, _mm) -> offsetSize' @nm @obj @ibargs @i dvc ibs ost++class ObjectLength nm obj ibargs =>+	OffsetSize (nm :: Symbol) (obj :: VObj.O) ibargs (i :: Nat) where+	offsetSize' ::+		Device.D sd -> HeteroParList.PL (U2 ImageBuffer) ibargs ->+		Device.M.Size -> IO (Device.M.Size, Device.M.Size)++instance (VObj.OffsetRange obj objs i, VObj.LengthOf obj objs) =>+	OffsetSize nm obj ('(sib, 'BufferArg nm objs) ': ibargs) i where+	offsetSize' dvc ((U2 ib@(Buffer (Buffer.B lns _))) :** _ibs) ost =+		(<$> adjustOffsetSize dvc ib ost) \(ost', _sz) ->+		VObj.offsetSize @obj @_ @i ost' lns++instance {-# OVERLAPPABLE #-}+	OffsetSize nm obj ibargs i =>+	OffsetSize nm obj ('(sib, ib) ': ibargs) i where+	offsetSize' dvc (U2 ib :** ibs) ost =+		adjustOffsetSize dvc ib ost >>=+		offsetSize' @nm @obj @_ @i dvc ibs . uncurry (+)
+ src/Gpu/Vulkan/Memory/Type.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, TupleSections #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Memory.Type (++	-- * TYPE++	M(..),++	-- * NEW, READ AND WRITE++	newM, readM, writeMBinded,++	getBinded,++	-- * OBJECT LENGTH++	objectLength++	) where++import Data.Kind+import Data.TypeLevel.Tuple.Uncurry+import Data.HeteroParList qualified as HeteroParList+import Data.IORef++import Gpu.Vulkan.Object qualified as VObj+import Gpu.Vulkan.Buffer.Type qualified as B+import Gpu.Vulkan.Image.Type qualified as I++import Gpu.Vulkan.Memory.ImageBuffer+import Gpu.Vulkan.Memory.Middle qualified as M++-- MEMORY++data M s (ibargs :: [(Type, ImageBufferArg)]) =+	M (IORef (HeteroParList.PL (U2 ImageBuffer) ibargs)) M.M++-- NEW, READ AND WRITE++newM :: HeteroParList.PL (U2 ImageBuffer) ibargs -> M.M -> IO (M s ibargs)+newM ibs mm = (`M` mm) <$> newIORef ibs++getBinded :: M s ibargs -> IO (HeteroParList.PL (U2 (ImageBufferBinded s)) ibargs)+getBinded m = HeteroParList.map toBinded . fst <$> readM m+	where+	toBinded :: U2 ImageBuffer ibarg -> U2 (ImageBufferBinded sm) ibarg+	toBinded (U2 (Image (I.I i))) = U2 . ImageBinded $ I.Binded i+	toBinded (U2 (Buffer (B.B x b))) = U2 . BufferBinded $ B.Binded x b++readM :: M s ibargs -> IO (HeteroParList.PL (U2 ImageBuffer) ibargs, M.M)+readM (M ib m) = (, m) <$> readIORef ib++writeMBinded :: M s ibargs ->+	HeteroParList.PL (U2 (ImageBufferBinded sm)) ibargs -> IO ()+writeMBinded (M rib _r) ibs =+	writeIORef rib (HeteroParList.map fromBinded ibs)+	where+	fromBinded :: U2 (ImageBufferBinded sm) ibarg -> U2 ImageBuffer ibarg+	fromBinded (U2 (ImageBinded (I.Binded i))) = U2 . Image $ I.I i+	fromBinded (U2 (BufferBinded (B.Binded x b))) = U2 . Buffer $ B.B x b++-- OBJECT LENGTH++objectLength :: forall nm obj ibargs sm . ObjectLength nm obj ibargs =>+	M sm ibargs -> IO (VObj.Length obj)+objectLength m = (<$> readM m) \(ibs, _m) -> objectLength' @nm @obj @ibargs ibs
+ src/Gpu/Vulkan/Object.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE GADTs, TypeFamilies #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Object (++	-- * OBJECT++	O(..),++	-- ** Synonyms++	Static, Dynamic,++	-- *** static++	Atom, List, Image,+	AtomNoName, ListNoName, ImageNoName,+	AtomMaybeName, ListMaybeName, ImageMaybeName,++	-- *** dynamic++	DynAtomNew, DynList, DynImage,+	DynAtomNoName, DynListNoName, DynImageNoName,+	DynAtomMaybeName, DynListMaybeName, DynImageMaybeName,++	-- ** Type Of Object++	TypeOf,++	-- * OBJECT LENGTH++	Length,++	-- ** Synonyms++	pattern LengthAtom,+	pattern LengthList,+	pattern LengthImage,+	pattern LengthDynAtom,+	pattern LengthDynList,+	pattern LengthDynImage,++	pattern LengthList',++	-- ** Find Length++	LengthOf(..),++	-- * ONLY DYNAMIC LENGTHS++	OnlyDynamicLengths(..),++	-- * STORE++	Store(..),++	-- * SIZE, ALIGNMENT AND OFFSET++	-- ** Whole Size++	wholeSize, WholeAlign(..),++	-- ** Offset Range++	offsetRange, offsetSize, OffsetRange,++	-- ** Offset Of List++	offsetOfList, OffsetOfList(..),++	-- ** Size AlignmentList++	SizeAlignmentList(..), SizeAlignment(..),++	) where++import Prelude hiding (length)++import GHC.TypeLits (Symbol)+import GHC.TypeNats+import Foreign.Ptr+import Data.Proxy+import Data.HeteroParList qualified as HeteroParList+import Data.HeteroParList (pattern (:**))++import Data.Maybe+import Data.Word++import Foreign.Storable (Storable)+import Gpu.Vulkan.Object.Base qualified as K+import Gpu.Vulkan.Device.Middle.Internal qualified as Device.M++-- OBJECT++data O = Static_ K.O | Dynamic Nat K.O++type Static algn mnm ot v = 'Static_ ('K.O algn mnm ot v)+type Dynamic n algn mnm ot v = 'Dynamic n ('K.O algn mnm ot v)++type Atom algn v nm = AtomMaybeName algn v ('Just nm)+type List algn v nm = ListMaybeName algn v ('Just nm)+type Image algn v nm = ImageMaybeName algn v ('Just nm)++type AtomNoName algn v = AtomMaybeName algn v 'Nothing+type ListNoName algn v = ListMaybeName algn v 'Nothing+type ImageNoName algn v = ImageMaybeName algn v 'Nothing++type AtomMaybeName algn v mnm = Static_ (K.AtomMaybeName algn v mnm)+type ListMaybeName algn v mnm = Static_ (K.ListMaybeName algn v mnm)+type ImageMaybeName algn v mnm = Static_ (K.ImageMaybeName algn v mnm)++type DynAtomNew n algn v nm = 'Dynamic n (K.AtomNew algn v nm)+type DynList n algn v nm = 'Dynamic n (K.List algn v nm)+type DynImage n algn v nm = 'Dynamic n (K.Image algn v nm)++type DynAtomNoName n algn v = 'Dynamic n (K.AtomNoName algn v)+type DynListNoName n algn v = 'Dynamic n (K.ListNoName algn v)+type DynImageNoName n algn v = 'Dynamic n (K.ImageNoName algn v)++type DynAtomMaybeName n algn v mnm = 'Dynamic n (K.AtomMaybeName algn v mnm)+type DynListMaybeName n algn v mnm = 'Dynamic n (K.ListMaybeName algn v mnm)+type DynImageMaybeName n algn v mnm = 'Dynamic n (K.ImageMaybeName algn v mnm)++type family TypeOf obj where+	TypeOf (Static_ kobj) = K.TypeOf kobj+	TypeOf ('Dynamic n kobj) = K.TypeOf kobj++-- OBJECT LENGTH++data Length obj where+	LengthStatic :: K.Length kobj -> Length ('Static_ kobj)+	LengthDynamic ::+		K.Length kobj -> Length ('Dynamic n kobj)++deriving instance Eq (Length obj)+deriving instance Show (Length obj)++pattern LengthAtom :: Length ('Static_ (K.AtomMaybeName algn v mnm))+pattern LengthAtom <- LengthStatic K.LengthAtom where+	LengthAtom = LengthStatic K.LengthAtom++{-# COMPLETE LengthList #-}+{-# COMPLETE LengthList' #-}++pattern LengthList :: Device.M.Size ->+	Length ('Static_ (K.ListMaybeName algn v mnm))+pattern LengthList n <- LengthStatic (K.LengthList n) where+	LengthList n = LengthStatic (K.LengthList n)++pattern LengthList' :: Word64 -> Length ('Static_ (K.ListMaybeName algn v nm))+pattern LengthList' n <- LengthStatic (K.LengthList (Device.M.Size n)) where+	LengthList' n = LengthStatic (K.LengthList (Device.M.Size n))++{-# COMPLETE LengthImage #-}++pattern LengthImage ::+	Device.M.Size -> Device.M.Size -> Device.M.Size -> Device.M.Size ->+	Length ('Static_ (K.ImageMaybeName algn v mnm))+pattern LengthImage kr kw kh kd <- (LengthStatic (K.LengthImage kr kw kh kd))+	where LengthImage kr kw kh kd = LengthStatic (K.LengthImage kr kw kh kd)++pattern LengthDynAtom :: Length ('Dynamic n (K.Atom algn v nm))+pattern LengthDynAtom <- LengthDynamic K.LengthAtom where+	LengthDynAtom = LengthDynamic K.LengthAtom++pattern LengthDynList :: Device.M.Size -> Length ('Dynamic n (K.List algn v nm))+pattern LengthDynList n <- LengthDynamic (K.LengthList n) where+	LengthDynList n = LengthDynamic (K.LengthList n)++pattern LengthDynImage ::+	Device.M.Size -> Device.M.Size -> Device.M.Size -> Device.M.Size -> Length ('Dynamic n (K.Image algn v nm))+pattern LengthDynImage kr kw kh kd <- (LengthDynamic (K.LengthImage kr kw kh kd))+	where LengthDynImage kr kw kh kd = LengthDynamic (K.LengthImage kr kw kh kd)++class LengthOf (obj :: O) (objs :: [O]) where+	lengthOf :: HeteroParList.PL Length objs -> Length obj++instance LengthOf obj (obj ': objs) where lengthOf (ln :** _) = ln++instance {-# OVERLAPPABLE #-} LengthOf obj objs =>+	LengthOf obj (obj' ': objs) where+	lengthOf (_ :** lns) = lengthOf @obj lns++-- ONLY DYNAMIC LENGTH++class OnlyDynamicLengths (objs :: [O]) where+	type OnlyDynamics objs :: [K.O]+	onlyDynamicLength ::+		HeteroParList.PL Length objs ->+		HeteroParList.PL K.Length (OnlyDynamics objs)++instance OnlyDynamicLengths '[] where+	type OnlyDynamics '[] = '[]+	onlyDynamicLength HeteroParList.Nil = HeteroParList.Nil++instance OnlyDynamicLengths objs => OnlyDynamicLengths ('Static_ _o ': objs) where+	type OnlyDynamics ('Static_ _o ': objs) = OnlyDynamics objs+	onlyDynamicLength (LengthStatic _ :** lns) = onlyDynamicLength lns++instance OnlyDynamicLengths objs => OnlyDynamicLengths ('Dynamic _n o ': objs) where+	type OnlyDynamics ('Dynamic _n o ': objs) = o ': OnlyDynamics objs+	onlyDynamicLength (LengthDynamic ln :** lns) =+		ln :** onlyDynamicLength lns++-- STORE++class Store v obj where+	store :: Ptr (TypeOf obj) -> Length obj -> v -> IO ()+	load :: Ptr (TypeOf obj) -> Length obj -> IO v+	length :: v -> Length obj++instance K.Store v bobj => Store v (Static_ bobj) where+	store p (LengthStatic kln) = K.store p kln+	load p (LengthStatic kln) = K.load p kln+	length = LengthStatic . K.length++instance (KnownNat n, K.Store v bobj) => Store [Maybe v] ('Dynamic n bobj) where+	store p0 (LengthDynamic kln) =+		go p0 (natVal (Proxy :: Proxy n))+		where+		go _ _ [] = pure ()+		go _ n _ | n < 1 = pure ()+		go p n (Just x : xs) = do+			K.store p kln x >> go (nextObject p kln) (n - 1) xs+		go p n (Nothing : xs) = do+			go (nextObject p kln) (n - 1) xs+	load p0 (LengthDynamic kln) = go p0 (natVal (Proxy :: Proxy n))+		where+		go _ n | n < 1 = pure []+		go p n = (:) <$> (Just <$> K.load p kln) <*> go (nextObject p kln) (n - 1)+	length = LengthDynamic . K.length . fromJust . head++nextObject :: forall kobj . K.SizeAlignment kobj =>+	Ptr (K.TypeOf kobj) -> K.Length kobj -> Ptr (K.TypeOf kobj)+nextObject p ln = p `plusPtr` fromIntegral n+	where+	n = ((K.size ln - 1) `div` algn + 1) * algn+	algn = K.alignment @kobj++-- SIZE, ALIGNMENT AND OFFSET++-- WholeSize++wholeSize :: SizeAlignmentList objs =>+	HeteroParList.PL Length objs -> Size+wholeSize = wholeSizeFromSzAlgns 0 . sizeAlignmentList++wholeSizeFromSzAlgns ::+	Size -> HeteroParList.PL SizeAlignmentOf objs -> Size+wholeSizeFromSzAlgns sz0 HeteroParList.Nil = sz0+wholeSizeFromSzAlgns sz0 (SizeAlignmentOf dn sz algn :** saoo) =+	wholeSizeFromSzAlgns (adjust algn sz0 + dn * sz) saoo++class WholeAlign (objs :: [O]) where wholeAlign :: Size++instance WholeAlign '[] where wholeAlign = 1++instance (SizeAlignment obj, WholeAlign objs) =>+	WholeAlign (obj ': objs) where+	wholeAlign = alignment @obj `lcm` wholeAlign @objs++-- OffsetRange++offsetRange :: forall obj objs i . OffsetRange obj objs i => Device.M.Size ->+	HeteroParList.PL Length objs -> (Device.M.Size, Device.M.Size)+offsetRange ost0 lns = offsetRangeFromSzAlgns' @obj @_ @i ost0 $ sizeAlignmentList lns++offsetSize :: forall obj objs i . OffsetRange obj objs i => Device.M.Size ->+	HeteroParList.PL Length objs -> (Device.M.Size, Device.M.Size)+offsetSize ost0 lns = offsetSizeFromSzAlgns' @obj @_ @i ost0 $ sizeAlignmentList lns++class (SizeAlignmentList vs, HeteroParList.TypeIndex v vs) =>+	OffsetRange (v :: O) (vs :: [O]) (i :: Nat) where+	offsetRangeFromSzAlgns' ::+		Device.M.Size -> HeteroParList.PL SizeAlignmentOf vs ->+		(Device.M.Size, Device.M.Size)+	offsetSizeFromSzAlgns' ::+		Device.M.Size -> HeteroParList.PL SizeAlignmentOf vs ->+		(Device.M.Size, Device.M.Size)++instance (SizeAlignment v, SizeAlignmentList vs) =>+	OffsetRange v (v ': vs) 0 where+	offsetRangeFromSzAlgns' ost (SizeAlignmentOf _dn sz algn :** _) =+		(adjust algn ost, sz)+	offsetSizeFromSzAlgns' ost (SizeAlignmentOf dn sz algn :** _) =+		(adjust algn ost, dn * sz)++instance {-# OVERLAPPABLE #-}+	(SizeAlignment v, OffsetRange v vs (i - 1)) =>+	OffsetRange v (v ': vs) i where+	offsetRangeFromSzAlgns' ost (SizeAlignmentOf dn sz algn :** sas) =+		offsetRangeFromSzAlgns' @v @vs @(i - 1) (adjust algn ost + dn * sz) sas+	offsetSizeFromSzAlgns' ost (SizeAlignmentOf dn sz algn :** sas) =+		offsetSizeFromSzAlgns' @v @vs @(i - 1) (adjust algn ost + dn * sz) sas++instance {-# OVERLAPPABLE #-} (SizeAlignment v', OffsetRange v vs i) =>+	OffsetRange v (v' ': vs) i where+	offsetRangeFromSzAlgns' ost (SizeAlignmentOf dn sz algn :** sas) =+		offsetRangeFromSzAlgns' @v @vs @i (adjust algn ost + dn * sz) sas+	offsetSizeFromSzAlgns' ost (SizeAlignmentOf dn sz algn :** sas) =+		offsetSizeFromSzAlgns' @v @vs @i (adjust algn ost + dn * sz) sas++-- OffsetOfList++offsetOfList :: forall v onm vs . OffsetOfList v onm vs =>+	HeteroParList.PL Length vs -> (Device.M.Size, Device.M.Size)+offsetOfList = offsetRangeListFromSzAlgns @v @onm 0 . sizeAlignmentList++class SizeAlignmentList objs =>+	OffsetOfList v (nm :: Symbol) (objs :: [O]) where+	offsetRangeListFromSzAlgns ::+		Device.M.Size -> HeteroParList.PL SizeAlignmentOf objs ->+		(Device.M.Size, Device.M.Size)++instance (Storable v, KnownNat oalgn, SizeAlignmentList objs) =>+	OffsetOfList v nm (List oalgn v nm ': objs) where+	offsetRangeListFromSzAlgns ost (SizeAlignmentOf _ sz algn :** _) =+		(adjust algn ost, sz)++instance {-# OVERLAPPABLE #-} (SizeAlignment obj, OffsetOfList v nm objs) =>+	OffsetOfList v nm (obj ': objs) where+	offsetRangeListFromSzAlgns ost (SizeAlignmentOf dn sz algn :** sas) =+		offsetRangeListFromSzAlgns+			@v @nm @objs (adjust algn ost + dn * sz) sas++adjust :: Device.M.Size -> Device.M.Size -> Device.M.Size+adjust algn ost = ((ost - 1) `div` algn + 1) * algn++-- SizeAlignmentList++data SizeAlignmentOf (obj :: O) = SizeAlignmentOf DynNum Size ObjAlignment+	deriving Show++type DynNum = Device.M.Size+type Size = Device.M.Size+type ObjAlignment = Device.M.Size++class SizeAlignmentList objs where+	sizeAlignmentList :: HeteroParList.PL Length objs ->+		HeteroParList.PL SizeAlignmentOf objs++instance SizeAlignmentList '[] where+	sizeAlignmentList HeteroParList.Nil = HeteroParList.Nil++instance (SizeAlignment obj, SizeAlignmentList objs) =>+	SizeAlignmentList (obj ': objs) where+	sizeAlignmentList (ln :** lns) =+		SizeAlignmentOf+			(dynNum @obj) (size ln) (alignment @obj) :**+		sizeAlignmentList lns++-- SizeAlignment++class SizeAlignment obj where+	dynNum :: Device.M.Size+	size :: Length obj -> Device.M.Size+	alignment :: Device.M.Size++instance K.SizeAlignment kobj => SizeAlignment (Static_ kobj) where+	dynNum = 1+	size (LengthStatic kln) = K.size kln+	alignment = K.alignment @kobj++instance (KnownNat n, K.SizeAlignment kobj) =>+	SizeAlignment ('Dynamic n kobj) where+	dynNum = fromIntegral $ natVal (Proxy :: Proxy n)+	size (LengthDynamic kln) = K.size kln+	alignment = K.alignment @kobj
+ src/Gpu/Vulkan/Object/Base.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE GADTs, TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Object.Base (++	-- * OBJECT++	O(..), IsImage(..),++	-- ** Synonyms++	Atom, AtomNew, List, Image,+	AtomNoName, ListNoName, ImageNoName,+	AtomMaybeName, ListMaybeName, ImageMaybeName,++	-- ** Type Of Object++	TypeOf,++	-- * OBJECT LENGTH++	Length(..), renameLength,++	-- * STORE OBJECT++	Store(..),++	-- * SIZE AND ALIGNMENT++	SizeAlignment(..)++	) where++import GHC.TypeLits+import Foreign.Ptr+import Foreign.Marshal.Array+import Foreign.Storable qualified as S+import Data.Kind+import Data.Foldable+import Data.Traversable+import Data.MonoTraversable+import Data.Proxy+import Data.Default++import qualified Data.Sequences as Seq++import Gpu.Vulkan.TypeEnum qualified as T++import Gpu.Vulkan.Device.Middle qualified as Device.M++-- OBJECT++data O = O Alignment (Maybe Symbol) ObjectType Type++type Alignment = Nat++data ObjectType = AtomT | ListT | ImageT deriving Show++class (S.Storable (ImagePixel img), T.FormatToValue (ImageFormat img)) =>+	IsImage img where+	type ImagePixel img+	type ImageFormat img :: T.Format+	imageRow :: img -> Device.M.Size+	imageWidth :: img -> Device.M.Size+	imageHeight :: img -> Device.M.Size+	imageDepth :: img -> Device.M.Size+	imageBody :: img -> [[ImagePixel img]]+	imageMake :: Device.M.Size -> Device.M.Size -> Device.M.Size ->+		[[ImagePixel img]] -> img++-- Synonyms++type Atom algn t mnm = AtomMaybeName algn t mnm+type AtomNew algn t nm = AtomMaybeName algn t ('Just nm)+type List algn t nm = ListMaybeName algn t ('Just nm)+type Image algn t nm = ImageMaybeName algn t ('Just nm)++type AtomNoName al t = AtomMaybeName al t 'Nothing+type ListNoName al t = ListMaybeName al t 'Nothing+type ImageNoName al t = ImageMaybeName al t 'Nothing++type AtomMaybeName al t mnm = 'O al mnm AtomT t+type ListMaybeName al t mnm = 'O al mnm ListT t+type ImageMaybeName al t mnm = 'O al mnm ImageT t++-- Type of Object++type family TypeOf obj where+	TypeOf ((Atom _algn t _nm)) = t+	TypeOf ((List _algn t _nm)) = t++-- OBJECT LENGTH++data Length (obj :: O) where+	LengthAtom :: Length (Atom algn t nm)+	LengthList :: Device.M.Size -> Length ('O algn mnm ListT t)+	LengthImage :: {+		lengthImageRow :: Device.M.Size,+		lengthImageWidth :: Device.M.Size,+		lengthImageHeight :: Device.M.Size,+		lengthImageDepth :: Device.M.Size } ->+		Length ('O algn mnm ImageT t)++deriving instance Eq (Length obj)+deriving instance Show (Length obj)++instance Default (Length (Atom algn t mnm)) where def = LengthAtom+instance Default (Length (List algn t nm)) where def = LengthList 0+instance Default (Length (Image algn t nm)) where def = LengthImage 0 0 0 0++renameLength :: Length ('O algn mnm ot t) -> Length ('O algn mnm' ot t)+renameLength LengthAtom = LengthAtom+renameLength (LengthList n) = LengthList n+renameLength (LengthImage r w h d) = LengthImage r w h d++-- STORE OBJECT++class SizeAlignment obj => Store v (obj :: O) where+	store :: Ptr (TypeOf obj) -> Length obj -> v -> IO ()+	load :: Ptr (TypeOf obj) -> Length obj -> IO v+	length :: v -> Length obj++instance (S.Storable t, KnownNat algn) => Store t ((Atom algn t _nm)) where+	store p (LengthAtom) x = S.poke p x+	load p (LengthAtom) = S.peek p+	length _ = LengthAtom++instance (KnownNat algn, Seq.IsSequence v, S.Storable t, Element v ~ t) =>+	Store v ((List algn t _nm)) where+	store p ((LengthList (fromIntegral -> n))) xs =+		pokeArray p . take n $ otoList xs+	load p (LengthList (fromIntegral -> n)) = Seq.fromList <$> peekArray n p+	length = LengthList . fromIntegral . olength++instance (KnownNat algn, IsImage img) =>+	Store img ((Image algn img nm)) where+	store p0 (LengthImage (fromIntegral -> r) (fromIntegral -> w) _ _) img =+		for_ (zip (iterate (`plusPtr` s) p0) $ imageBody img)+			\(p, take w -> rw) -> pokeArray (castPtr p) rw+		where s = r * S.sizeOf @(ImagePixel img) undefined+	load p0 (LengthImage (fromIntegral -> r)+		w_@(fromIntegral -> w) h_@(fromIntegral -> h)+		d_@(fromIntegral -> d)) =+		imageMake w_ h_ d_+			<$> for (take (h * d) $ iterate (`plusPtr` s) p0) \p ->+				peekArray w (castPtr p)+		where s = r * (S.sizeOf @(ImagePixel img) undefined)+	length img = LengthImage+		(imageRow img) (imageWidth img) (imageHeight img)+		(imageDepth img)++-- SIZE AND ALIGNMENT++class SizeAlignment obj where+	size :: Length obj -> Device.M.Size+	alignment :: Device.M.Size++instance (KnownNat algn, S.Storable t) =>+	SizeAlignment ((AtomMaybeName algn t _nm)) where+	size (LengthAtom) =+		applyAlign algn . fromIntegral $ S.sizeOf @t undefined+		where algn = alignment @((AtomMaybeName algn t _nm))+	alignment = fromIntegral (natVal (Proxy :: Proxy algn)) `lcm`+		fromIntegral (S.alignment @t undefined)++instance (KnownNat algn, S.Storable t) => SizeAlignment (ListMaybeName algn t _nm) where+	size (LengthList n) = applyAlign algn' $ n * applyAlign algn sz+		where+		sz = fromIntegral $ S.sizeOf @t undefined+		algn = fromIntegral $ S.alignment @t undefined+		algn' = alignment @((ListMaybeName algn t _nm))+	alignment = fromIntegral (natVal (Proxy :: Proxy algn)) `lcm`+		fromIntegral (S.alignment @t undefined)++instance (KnownNat algn, S.Storable (ImagePixel img)) =>+	SizeAlignment ((ImageMaybeName algn img nm)) where+	size (LengthImage r _w h d) = r * h * d * applyAlign algn sz+		where+		sz = fromIntegral $ S.sizeOf @(ImagePixel img) undefined+		algn = alignment @((ImageMaybeName algn img nm))+	alignment =fromIntegral (natVal (Proxy :: Proxy algn)) `lcm`+		fromIntegral (S.alignment @(ImagePixel img) undefined)++applyAlign :: Integral n => n -> n -> n+applyAlign algn ofst = ((ofst - 1) `div` algn + 1) * algn
+ src/Gpu/Vulkan/Object/NoAlignment.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Object.NoAlignment (+	Atom, List, Image,+	AtomNoName, ListNoName, ImageNoName,+	AtomMaybeName, ListMaybeName, ImageMaybeName ) where++import Gpu.Vulkan.Object qualified as Vk.Obj++type Atom v nm = Vk.Obj.Atom 1 v nm+type List v nm = Vk.Obj.List 1 v nm+type Image v nm = Vk.Obj.Image 1 v nm++type AtomNoName v = Vk.Obj.AtomNoName 1 v+type ListNoName v = Vk.Obj.ListNoName 1 v+type ImageNoName v = Vk.Obj.ImageNoName 1 v++type AtomMaybeName v mnm = Vk.Obj.AtomMaybeName 1 v mnm+type ListMaybeName v mnm = Vk.Obj.ListMaybeName 1 v mnm+type ImageMaybeName v mnm = Vk.Obj.ImageMaybeName 1 v mnm
+ src/Gpu/Vulkan/PhysicalDevice.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.PhysicalDevice (++	-- * ENUMERATE++	enumerate, M.P,++	-- * PHYSICAL DEVICE PROPERTIES AND FEATURES++	M.getProperties, M.Properties(..), M.getFeatures,++	-- ** Get Properties 2++	getProperties2ExtensionName,+	M.getFeatures2, M.Features2(..),++	-- * OTHER PROPERTIES++	M.getMemoryProperties, M.MemoryProperties(..),+	M.getQueueFamilyProperties, M.getFormatProperties,+	enumerateExtensionProperties,+	ExtensionProperties(..), ExtensionName(..),++	-- * OTHER FEATURES++	M.ShaderDrawParametersFeatures(..),++	-- * EXTENSIONS++	maintenance3ExtensionName,++	-- * ENUM AND STRUCT++	module Gpu.Vulkan.PhysicalDevice.Enum,++	Limits(..), Features(..),+	DescriptorIndexingFeatures(..), DescriptorIndexingFeaturesNoNext(..)++	) where++import Gpu.Vulkan.Internal+import Gpu.Vulkan.Instance.Internal qualified as Instance+import Gpu.Vulkan.Instance.Type qualified as Instance.T+import Gpu.Vulkan.PhysicalDevice.Middle qualified as M+import Gpu.Vulkan.PhysicalDevice.Enum+import Gpu.Vulkan.PhysicalDevice.Struct++import Gpu.Vulkan.Middle qualified as M+import Data.Text qualified as T++enumerate :: Instance.T.I s -> IO [M.P]+enumerate (Instance.T.I i) = M.enumerate i++enumerateExtensionProperties ::+	M.P -> Maybe LayerName -> IO [ExtensionProperties]+enumerateExtensionProperties p (((\(LayerName ln) -> ln) <$>) -> mlnm) =+	(extensionPropertiesFromMiddle <$>)+		<$> M.enumerateExtensionProperties p mlnm++data ExtensionProperties = ExtensionProperties {+	extensionPropertiesExtensionName :: ExtensionName,+	extensionPropertiesSpecVersion :: M.ApiVersion }+	deriving Show++extensionPropertiesFromMiddle :: M.ExtensionProperties -> ExtensionProperties+extensionPropertiesFromMiddle M.ExtensionProperties {+	M.extensionPropertiesExtensionName = en,+	M.extensionPropertiesSpecVersion = sv } = ExtensionProperties {+	extensionPropertiesExtensionName = ExtensionName en,+	extensionPropertiesSpecVersion = sv }++newtype ExtensionName = ExtensionName { unExtensionName :: T.Text }+	deriving (Show, Eq)++maintenance3ExtensionName :: ExtensionName+maintenance3ExtensionName = ExtensionName M.maintenance3ExtensionName++getProperties2ExtensionName :: Instance.ExtensionName+getProperties2ExtensionName = Instance.ExtensionName M.getProperties2ExtensionName
+ src/Gpu/Vulkan/PhysicalDevice/Enum.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.PhysicalDevice.Enum (+	module Gpu.Vulkan.PhysicalDevice.Enum ) where++import "gpu-vulkan-middle" Gpu.Vulkan.PhysicalDevice.Enum
+ src/Gpu/Vulkan/PhysicalDevice/Struct.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.PhysicalDevice.Struct (+	module Gpu.Vulkan.PhysicalDevice.Struct ) where++import "gpu-vulkan-middle" Gpu.Vulkan.PhysicalDevice.Struct
+ src/Gpu/Vulkan/Pipeline.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline (module Gpu.Vulkan.Pipeline.Enum) where++import Gpu.Vulkan.Pipeline.Enum
+ src/Gpu/Vulkan/Pipeline/ColorBlendAttachment.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.ColorBlendAttachment (++	-- * STATE++	State(..)++	) where++import Gpu.Vulkan.Pipeline.ColorBlendAttachment.Middle
+ src/Gpu/Vulkan/Pipeline/ColorBlendState.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.ColorBlendState (++	-- * CREATE INFO++	CreateInfo(..)++	) where++import Gpu.Vulkan.Pipeline.ColorBlendState.Middle
+ src/Gpu/Vulkan/Pipeline/Compute.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TypeApplications, RankNTypes #-}+{-# LANGUAGE MonoLocalBinds, GADTs, TypeFamilies #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.Compute (++	-- * CREATE++	createCs, C(..), CreateInfo(..),+	CreateInfoListToMiddle, FromMiddleList++	) where++import Foreign.Storable.PeekPoke+import Foreign.Storable.HeteroList+import Control.Exception+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry+import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex+import qualified Data.HeteroParList as HeteroParList+import Data.HeteroParList (pattern (:**))+import Data.Kind+import Data.Int++import Language.SpirV.ShaderKind++import Gpu.Vulkan.Pipeline.Enum++import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.Pipeline.ShaderStage.Internal as ShaderStage+import qualified Gpu.Vulkan.DescriptorSetLayout.Type as DescriptorSetLayout+import qualified Gpu.Vulkan.PipelineLayout.Type as Layout+import qualified Gpu.Vulkan.PipelineCache.Type as Cache+import qualified Gpu.Vulkan.Pipeline.Compute.Middle as M+++newtype C s (lyta ::+	(Type, [(Type, [DescriptorSetLayout.BindingType])], [Type])) = C M.C+	deriving Show++data CreateInfo mn ssta lyta bpha = CreateInfo {+	createInfoNext :: TMaybe.M mn,+	createInfoFlags :: CreateFlags,+	createInfoStage :: U5 ShaderStage.CreateInfo ssta,+	createInfoLayout :: U3 Layout.P lyta,+	createInfoBasePipelineHandleOrIndex ::+		Maybe (Either (U2 C bpha) Int32) }++createInfoToMiddle ::+	(WithPoked (TMaybe.M n'), AllocationCallbacks.ToMiddle mscc) =>+	Device.D ds ->+	CreateInfo n '(n1, n', 'GlslComputeShader, mscc, vs) lyta bpha ->+	IO (M.CreateInfo n n1 vs)+createInfoToMiddle dvc CreateInfo {+	createInfoNext = mnxt,+	createInfoFlags = flgs,+	createInfoStage = U5 stg,+	createInfoLayout = U3 (Layout.P lyt),+	createInfoBasePipelineHandleOrIndex = mbphi } = do+	stg' <- ShaderStage.createInfoToMiddle dvc stg+	let	(bph, bpi) = case mbphi of+			Nothing -> (Nothing, Nothing)+			Just (Left (U2 (C h))) -> (Just h, Nothing)+			Just (Right i) -> (Nothing, Just i)+	pure M.CreateInfo {+		M.createInfoNext = mnxt,+		M.createInfoFlags = flgs,+		M.createInfoStage = stg',+		M.createInfoLayout = lyt,+		M.createInfoBasePipelineHandle = bph,+		M.createInfoBasePipelineIndex = bpi }++class (	M.CreateInfoListToCore (MiddleArgs as),+	DestroyCreateInfoMiddleList (MiddleArgs as) as ) =>+	CreateInfoListToMiddle as where+	type MiddleArgs as :: [(Maybe Type, Maybe Type, [Type])]+	createInfoListToMiddle ::+		Device.D sd -> HeteroParList.PL (U4 CreateInfo) as ->+		IO (HeteroParList.PL (U3 M.CreateInfo) (MiddleArgs as))++instance CreateInfoListToMiddle '[] where+	type MiddleArgs '[] = '[]+	createInfoListToMiddle _ HeteroParList.Nil = pure HeteroParList.Nil++instance (+	WithPoked (TMaybe.M n'), CreateInfoListToMiddle as,+	AllocationCallbacks.ToMiddle mscc,++	WithPoked (TMaybe.M n), WithPoked (TMaybe.M n1), PokableList vs+	) =>+	CreateInfoListToMiddle (+		'(n, '(n1, n', 'GlslComputeShader, mscc, vs), lyta, bpha+		) ': as) where+	type MiddleArgs (+		'(n, '(n1, n', 'GlslComputeShader, mscc, vs), lyta, bpha) ':+		as ) = '(n, n1, vs) ': MiddleArgs as+	createInfoListToMiddle dvc (U4 ci :** cis) = (:**)+		<$> (U3 <$> createInfoToMiddle dvc ci)+		<*> createInfoListToMiddle dvc cis++destroyCreateInfoMiddle ::+	AllocationCallbacks.ToMiddle mscc =>+	Device.D sd -> M.CreateInfo n n1 vs ->+	CreateInfo n '(n1, n2, 'GlslComputeShader, mscc, vs) lyta bpha -> IO ()+destroyCreateInfoMiddle dvc mci ci = ShaderStage.destroyShaderModule dvc+	(M.createInfoStage mci) ((\(U5 s) -> snd $ ShaderStage.createInfoModule s) $ createInfoStage ci)++class DestroyCreateInfoMiddleList vss vss' where+	destroyCreateInfoMiddleList ::+		Device.D sd ->+		HeteroParList.PL (U3 M.CreateInfo) vss ->+		HeteroParList.PL (U4 CreateInfo) vss' -> IO ()++instance DestroyCreateInfoMiddleList '[] '[] where+	destroyCreateInfoMiddleList _ HeteroParList.Nil HeteroParList.Nil = pure ()++instance (+	DestroyCreateInfoMiddleList vss vss',+	AllocationCallbacks.ToMiddle mscc ) =>+	DestroyCreateInfoMiddleList+		('(n, n1, vs) ': vss)+		('(n, '(n1, n2, 'GlslComputeShader, mscc, vs), lyta, bpha) ': vss') where+	destroyCreateInfoMiddleList dvc+		(U3 mci :** mcis) (U4 ci :** cis) = do+		destroyCreateInfoMiddle dvc mci ci+		destroyCreateInfoMiddleList dvc mcis cis++createCs :: (+	CreateInfoListToMiddle cias, AllocationCallbacks.ToMiddle mac,+	FromMiddleList (TMapIndex.M2_4 cias) ) =>+	Device.D sd -> Maybe (Cache.P spc) -> HeteroParList.PL (U4 CreateInfo) cias ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . HeteroParList.PL (C s) (TMapIndex.M2_4 cias) -> IO a) -> IO a+createCs dvc@(Device.D mdvc) mcch cis+	(AllocationCallbacks.toMiddle -> mac) f = do+	cis' <- createInfoListToMiddle dvc cis+	let	mcch' = (\(Cache.P c) -> c) <$> mcch+	bracket+		(M.createCs mdvc mcch' cis' mac+			<* destroyCreateInfoMiddleList dvc cis' cis)+		(mapM_ \c -> M.destroy mdvc c mac)+		(f . fromMiddleList)++class FromMiddleList ss where+	fromMiddleList :: [M.C] -> HeteroParList.PL (C sc) ss++instance FromMiddleList '[] where fromMiddleList [] = HeteroParList.Nil++instance FromMiddleList ss => FromMiddleList (s ': ss) where+	fromMiddleList (c : cs) = C c :** fromMiddleList cs
+ src/Gpu/Vulkan/Pipeline/DepthStencilState.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.DepthStencilState (++	-- * CREATE INFO++	CreateInfo(..), CreateFlags(..)++	) where++import Gpu.Vulkan.Pipeline.DepthStencilState.Middle
+ src/Gpu/Vulkan/Pipeline/DynamicState.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.DynamicState (++	-- * CREATE INFO++	CreateInfo(..), CreateFlags++	) where++import Gpu.Vulkan.Pipeline.DynamicState.Middle
+ src/Gpu/Vulkan/Pipeline/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.Enum (module Gpu.Vulkan.Pipeline.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Pipeline.Enum
+ src/Gpu/Vulkan/Pipeline/Graphics.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE GADTs, TypeFamilies #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.Graphics (++	-- * CREATE AND RECREATE++	createGs, unsafeRecreateGs, G, CreateInfo(..),+	CreateInfoListArgsToGArgs, CreateInfoListToMiddle,++	-- ** Group++	group, Group, createGs', unsafeDestroyGs, lookup++	) where++import Prelude hiding (lookup)+import Foreign.Storable.PeekPoke+import Control.Concurrent.STM+import Control.Concurrent.STM.TSem+import Control.Exception+import Data.Kind+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry+import Data.TypeLevel.Tuple.Index qualified as TIndex+import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex+import Data.Map qualified as Map+import Data.HeteroParList qualified as HeteroParList+import Data.HeteroParList (pattern (:**))+import Data.HeteroParList.Tuple qualified as HeteroParList+import Data.Word+import Data.Int++import Language.SpirV.ShaderKind++import Gpu.Vulkan.Pipeline.Enum+import Gpu.Vulkan.Pipeline.Graphics.Type++import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.Pipeline.Graphics.Middle as M+import qualified Gpu.Vulkan.PipelineCache.Type as Cache+import qualified Gpu.Vulkan.PipelineLayout.Type as Layout++import qualified Gpu.Vulkan.RenderPass.Type as RenderPass+import qualified Gpu.Vulkan.Pipeline.DynamicState as DynamicState+import qualified Gpu.Vulkan.Pipeline.ColorBlendState as ColorBlendState+import qualified Gpu.Vulkan.Pipeline.DepthStencilState as DepthStencilState+import qualified Gpu.Vulkan.Pipeline.MultisampleState as MultisampleState+import qualified Gpu.Vulkan.Pipeline.RasterizationState as RasterizationState+import qualified Gpu.Vulkan.Pipeline.ViewportState as ViewportState+import qualified Gpu.Vulkan.Pipeline.TessellationState as TessellationState+import qualified Gpu.Vulkan.Pipeline.InputAssemblyState as InputAssemblyState+import Gpu.Vulkan.Pipeline.VertexInputState.Internal+	qualified as VertexInputState+import qualified Gpu.Vulkan.Pipeline.ShaderStage.Internal as ShaderStage++import Gpu.Vulkan.VertexInput qualified as VertexInput++import qualified Gpu.Vulkan.Pipeline.ShaderStage.Middle as ShaderStage.M++-- CREATE AND RECREATE++createGs :: (CreateInfoListToMiddle cias, AllocationCallbacks.ToMiddle mac) =>+	Device.D sd -> Maybe (Cache.P sc) ->+	HeteroParList.PL (U14 CreateInfo) cias ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall sg .+		HeteroParList.PL+			(U3 (G sg)) (CreateInfoListArgsToGArgs cias) ->+		IO a) -> IO a+createGs d@(Device.D dvc) ((Cache.pToMiddle <$>) -> mc) cis+	macc@(AllocationCallbacks.toMiddle -> macd) f = bracket+	(createInfoListToMiddle d cis >>= \cis' -> M.createGs dvc mc cis'+			(AllocationCallbacks.toMiddle macc)+		<* destroyShaderStages' d cis' (allocationCallbacksListListFromCreateInfoList cis))+	(\gs -> M.destroyGs dvc gs macd) (f . gListFromMiddle)++class GListFromMiddle ss where+	gListFromMiddle :: [M.G] -> HeteroParList.PL (U3 (G sg)) ss+instance GListFromMiddle '[] where+	gListFromMiddle = \case+		[] -> HeteroParList.Nil+		_ : _ -> error "Wrong number of elements"++instance GListFromMiddle ss => GListFromMiddle ('(s, t, foo) ': ss) where+	gListFromMiddle = \case+		g : gs -> U3 (G @_ @s @t g) :** gListFromMiddle @ss gs+		[] -> error "Wrong number of elements"++unsafeRecreateGs :: (CreateInfoListToMiddle cias, AllocationCallbacks.ToMiddle mac) =>+	Device.D sd -> Maybe (Cache.P s) -> HeteroParList.PL (U14 CreateInfo) cias ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	HeteroParList.PL (U3 (G sg)) (CreateInfoListArgsToGArgs cias) -> IO ()+unsafeRecreateGs d@(Device.D dvc) ((Cache.pToMiddle <$>) -> mc) cis macc gpls = do+	cis' <- createInfoListToMiddle d cis+	M.recreateGs dvc mc cis'+		(AllocationCallbacks.toMiddle macc) $ gListToMiddle gpls+	destroyShaderStages' d cis' $ allocationCallbacksListListFromCreateInfoList cis++gListToMiddle :: HeteroParList.PL (U3 (G sg)) ss -> [M.G]+gListToMiddle = HeteroParList.toList $ \(U3 (G g)) -> g++-- CREATE INFO++data CreateInfo+	mn ssas visa iasa tsssa vpsa rstsa mssa dssa cbsa dsa lyta rpa bpha =+	CreateInfo {+		createInfoNext :: TMaybe.M mn,+		createInfoFlags :: CreateFlags,+		createInfoStages ::+			HeteroParList.PL (U5 ShaderStage.CreateInfo) ssas,+		createInfoVertexInputState ::+			Maybe (U3 VertexInputState.CreateInfo visa),+		createInfoInputAssemblyState ::+			Maybe (InputAssemblyState.CreateInfo iasa),+		createInfoTessellationState ::+			Maybe (TessellationState.CreateInfo tsssa),+		createInfoViewportState :: Maybe (ViewportState.CreateInfo vpsa),+		createInfoRasterizationState ::+			Maybe (RasterizationState.CreateInfo rstsa),+		createInfoMultisampleState ::+			Maybe (MultisampleState.CreateInfo mssa),+		createInfoDepthStencilState ::+			Maybe (DepthStencilState.CreateInfo dssa),+		createInfoColorBlendState ::+			Maybe (ColorBlendState.CreateInfo cbsa),+		createInfoDynamicState :: Maybe (DynamicState.CreateInfo dsa),+		createInfoLayout :: U3 Layout.P lyta,+		createInfoRenderPass :: RenderPass.R rpa,+		createInfoSubpass :: Word32,+		createInfoBasePipelineHandle :: Maybe (U4 G bpha),+		createInfoBasePipelineIndex :: Int32 }++-- CREATE INFO LIST ARGS TO G ARGS++type family CreateInfoListArgsToGArgs cias where+	CreateInfoListArgsToGArgs '[] = '[]+	CreateInfoListArgsToGArgs (cia ': cias) =+		CreateInfoArgsToGArgs cia ': CreateInfoListArgsToGArgs cias++type family CreateInfoArgsToGArgs cia where+	CreateInfoArgsToGArgs '(+		n, ssas, '(nv, vibs, vias), iasa, tsssa, vpsa, rstsa, mssa, dssa, cbsa, dsa,+		slbtss, rpa, bpha ) = '(vibs, vias, slbtss)++-- CREATE INFO LIST TO MIDDLE++class (	GListFromMiddle (CreateInfoListArgsToGArgs cias),+	DestroyShaderStages+		(MiddleArgs cias) (TAllocationCallbacksListList cias),+	AllocationCallbacksListListFromCreateInfoList cias,+	M.CreateInfoListToCore (MiddleArgs cias) ) =>+	CreateInfoListToMiddle cias where+	type MiddleArgs cias :: [(+		Maybe Type, [(Maybe Type, ShaderKind, [Type])], Maybe Type,+		Maybe Type, Maybe Type, Maybe Type, Maybe Type, Maybe Type,+		Maybe Type, Maybe Type, Maybe Type)]+	createInfoListToMiddle ::+		Device.D sd -> HeteroParList.PL (U14 CreateInfo) cias ->+		IO (HeteroParList.PL (U11 M.CreateInfo) (MiddleArgs cias))++instance CreateInfoListToMiddle '[] where+	type MiddleArgs '[] = '[]+	createInfoListToMiddle _ HeteroParList.Nil = pure HeteroParList.Nil++instance (++	HeteroParList.Map3_5 ssas,+	ShaderStage.CreateInfoListToMiddle ssas,+	ShaderStage.M.CreateInfoListToCore (ShaderStage.MiddleArgs ssas),+	VertexInputState.BindingStrideList vibs VertexInput.Rate,+	VertexInputState.AttributeDescriptions vibs vias,+	WithPoked (TMaybe.M mn), WithPoked (TMaybe.M nvis),+	WithPoked (TMaybe.M iasa), WithPoked (TMaybe.M tsssa),+	WithPoked (TMaybe.M vpsa), WithPoked (TMaybe.M rstsa),+	WithPoked (TMaybe.M mssa), WithPoked (TMaybe.M dssa),+	WithPoked (TMaybe.M cbsa), WithPoked (TMaybe.M dsa),+	CreateInfoListToMiddle ss ) =>+	CreateInfoListToMiddle ('(+		mn, ssas, '(nvis, vibs, vias), iasa, tsssa, vpsa, rstsa, mssa, dssa, cbsa, dsa,+		'(sl, sbtss, pcl), rpa, '(sb, vibs', vias', slbtss') ) ': ss)  where+	type MiddleArgs ('(+		mn, ssas, '(nvis, vibs, vias), iasa, tsssa, vpsa, rstsa, mssa, dssa, cbsa, dsa,+		'(sl, sbtss, pcl), rpa, '(sb, vibs', vias', slbtss') ) ': ss) =+		'(mn, ShaderStage.MiddleArgs ssas, nvis, iasa, tsssa, vpsa, rstsa,+			mssa, dssa, cbsa, dsa) ': MiddleArgs ss+	createInfoListToMiddle dvc (U14 ci :** cis) = (:**)+		<$> (U11 <$> createInfoToMiddle dvc ci)+		<*> createInfoListToMiddle dvc cis++createInfoToMiddle :: (+	ShaderStage.CreateInfoListToMiddle ssas,+	VertexInputState.BindingStrideList vibs VertexInput.Rate,+	VertexInputState.AttributeDescriptions vibs vias ) =>+	Device.D sd ->+	CreateInfo n ssas '(nvis, vibs, vias)+		iasa tsssa vpsa rstsa mssa dssa cbsa dsa sl rpa '(sb, vibs', vias', slbtss') ->+	IO (M.CreateInfo n (ShaderStage.MiddleArgs ssas)+		nvis iasa tsssa vpsa rstsa mssa dssa cbsa dsa)+createInfoToMiddle dvc CreateInfo {+	createInfoNext = mnxt,+	createInfoFlags = flgs,+	createInfoStages = stgs,+	createInfoVertexInputState = vis,+	createInfoInputAssemblyState = ias,+	createInfoTessellationState = ts,+	createInfoViewportState = vs,+	createInfoRasterizationState = rs,+	createInfoMultisampleState = ms,+	createInfoDepthStencilState = dss,+	createInfoColorBlendState = cbs,+	createInfoDynamicState = ds,+	createInfoLayout = U3 (Layout.P lyt),+	createInfoRenderPass = RenderPass.R rp,+	createInfoSubpass = sp,+	createInfoBasePipelineHandle = bph,+	createInfoBasePipelineIndex = bpi } = do+	stgs' <- ShaderStage.createInfoListToMiddle dvc stgs+	bph' <- maybe M.gNull (\(U4 (G g)) -> pure g) bph+	pure M.CreateInfo {+		M.createInfoNext = mnxt,+		M.createInfoFlags = flgs,+		M.createInfoStages = stgs',+		M.createInfoVertexInputState =+			VertexInputState.createInfoToMiddle . unU3 <$> vis,+		M.createInfoInputAssemblyState = ias,+		M.createInfoTessellationState = ts,+		M.createInfoViewportState = vs,+		M.createInfoRasterizationState = rs,+		M.createInfoMultisampleState = ms,+		M.createInfoDepthStencilState = dss,+		M.createInfoColorBlendState = cbs,+		M.createInfoDynamicState = ds,+		M.createInfoLayout = lyt,+		M.createInfoRenderPass = rp,+		M.createInfoSubpass = sp,+		M.createInfoBasePipelineHandle = bph',+		M.createInfoBasePipelineIndex = bpi }++-- DESTROY SHADER STAGES++class DestroyShaderStages mvs macs where+	destroyShaderStages' :: Device.D sd ->+		HeteroParList.PL (U11 M.CreateInfo) mvs ->+		HeteroParList.PL2+			(TPMaybe.M (U2 AllocationCallbacks.A)) macs -> IO ()++instance DestroyShaderStages '[] '[] where+	destroyShaderStages' _ HeteroParList.Nil HeteroParList.Nil = pure ()++instance (ShaderStage.DestroyShaderModuleList a2 mac, DestroyShaderStages ss macs) =>+	DestroyShaderStages ('(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11) ': ss) (mac ': macs) where+	destroyShaderStages' dvc (U11 cim :** cims) (mac :** macs) = do+		ShaderStage.destroyShaderModuleList dvc (M.createInfoStages cim) mac+		destroyShaderStages' dvc cims macs++class AllocationCallbacksListListFromCreateInfoList cias where+	type TAllocationCallbacksListList cias :: [[Maybe (Type, Type)]]+	allocationCallbacksListListFromCreateInfoList ::+		HeteroParList.PL (U14 CreateInfo) cias ->+		HeteroParList.PL2+			(TPMaybe.M (U2 AllocationCallbacks.A))+			(TAllocationCallbacksListList cias)++instance AllocationCallbacksListListFromCreateInfoList '[] where+	type TAllocationCallbacksListList '[] = '[]+	allocationCallbacksListListFromCreateInfoList+		HeteroParList.Nil = HeteroParList.Nil++instance (+	HeteroParList.Map3_5 (TIndex.I1_14 cia),+	AllocationCallbacksListListFromCreateInfoList cias ) =>+	AllocationCallbacksListListFromCreateInfoList (cia ': cias) where+	type TAllocationCallbacksListList (cia ': cias) =+		TMapIndex.M3_5 (TIndex.I1_14 cia) ':+		TAllocationCallbacksListList cias+	allocationCallbacksListListFromCreateInfoList (U14 ci :** cis) =+		allocationCallbacksListFromCreateInfo ci :**+		allocationCallbacksListListFromCreateInfoList cis++allocationCallbacksListFromCreateInfo :: HeteroParList.Map3_5 ssas =>+	CreateInfo mn ssas visa iasa tsssa vpsa rstsa mssa dssa cbsa dsa lyta rpa bpha ->+	HeteroParList.PL (TPMaybe.M (U2 AllocationCallbacks.A)) (TMapIndex.M3_5 ssas)+allocationCallbacksListFromCreateInfo =+	ShaderStage.allocationCallbacksListFromCreateInfoList . createInfoStages++-- Group++data Group sd ma sg k gas = Group (Device.D sd)+	(TPMaybe.M (U2 AllocationCallbacks.A) ma)+	TSem (TVar (Map.Map k ( HeteroParList.PL (U3 (G sg)) gas)))++group :: AllocationCallbacks.ToMiddle ma =>+	Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma ->+	(forall sg . Group sd ma sg k gas -> IO a) -> IO a+group dvc@(Device.D mdvc) mac@(AllocationCallbacks.toMiddle -> mmac) f = do+	(sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty+	rtn <- f $ Group dvc mac sem m+	((\gs -> M.destroyGs mdvc (gListToMiddle gs) mmac) `mapM_`)+		=<< atomically (readTVar m)+	pure rtn++createGs' :: (+	Ord k,+	CreateInfoListToMiddle cias, AllocationCallbacks.ToMiddle mac ) =>+	Group sd mac sg k (CreateInfoListArgsToGArgs cias) -> k ->+	Maybe (Cache.P sc) ->+	HeteroParList.PL (U14 CreateInfo) cias ->+	IO (Either String+		(HeteroParList.PL (U3 (G sg)) (CreateInfoListArgsToGArgs cias)))+createGs' (Group d@(Device.D dvc)+	(AllocationCallbacks.toMiddle -> mmac) sem gss) k+	((Cache.pToMiddle <$>) -> mc) cis = do+	ok <- atomically do+		mx <- Map.lookup k <$> readTVar gss+		case mx of+			Nothing -> waitTSem sem >> pure True+			Just _ -> pure False+	if ok+	then do	gs <- createInfoListToMiddle d cis >>= \cis' -> M.createGs dvc mc cis' mmac+				<* destroyShaderStages' d cis'+					(allocationCallbacksListListFromCreateInfoList cis)+		let	gs' = gListFromMiddle gs+		atomically $ modifyTVar gss (Map.insert k gs') >> signalTSem sem+		pure $ Right gs'+	else pure . Left $+		"Gpu.Vulkan.Pipeline.Graphics.create' :: The key already exist"++unsafeDestroyGs :: (Ord k, AllocationCallbacks.ToMiddle ma) =>+	Group sd ma sg k gas -> k -> IO (Either String ())+unsafeDestroyGs (Group (Device.D mdvc)+	(AllocationCallbacks.toMiddle -> mma) sem gss) k = do+	mgs <- atomically do+		mx <- Map.lookup k <$> readTVar gss+		case mx of+			Nothing -> pure Nothing+			Just _ -> waitTSem sem >> pure mx+	case mgs of+		Nothing -> pure $ Left+			"Gpu.Vulkan.Pipeline.Graphics.unsafeDestroyGs: No such key"+		Just gs -> do+			atomically . modifyTVar gss $ Map.delete k+			M.destroyGs mdvc (gListToMiddle gs) mma+			Right <$> atomically (signalTSem sem)++lookup :: Ord k =>+	Group sd ma sg k gas -> k -> IO (Maybe (HeteroParList.PL (U3 (G sg)) gas))+lookup (Group _ _ _sem gss) k = atomically $ Map.lookup k <$> readTVar gss
+ src/Gpu/Vulkan/Pipeline/Graphics/Type.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.Graphics.Type (G(..)) where++import GHC.TypeNats+import Data.Kind++import Gpu.Vulkan.DescriptorSetLayout.Type qualified as DscStLyt+import Gpu.Vulkan.Pipeline.Graphics.Middle qualified as M++import Gpu.Vulkan.VertexInput qualified as VertexInput++newtype G s (vibs :: [(Type, VertexInput.Rate)]) (vias :: [(Nat, Type)])+	(lyta :: (Type, [(Type, [DscStLyt.BindingType])], [Type])) = G M.G
+ src/Gpu/Vulkan/Pipeline/InputAssemblyState.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.InputAssemblyState (++	-- * CREATE INFO++	CreateInfo(..)++	) where++import Gpu.Vulkan.Pipeline.InputAssemblyState.Middle
+ src/Gpu/Vulkan/Pipeline/MultisampleState.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.MultisampleState (++	-- * CREATE INFO++	CreateInfo(..)++	) where++import Gpu.Vulkan.Pipeline.MultisampleState.Middle
+ src/Gpu/Vulkan/Pipeline/RasterizationState.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.RasterizationState (++	-- * CREATE INFO++	CreateInfo(..)++	) where++import Gpu.Vulkan.Pipeline.RasterizationState.Middle
+ src/Gpu/Vulkan/Pipeline/ShaderStage.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.ShaderStage (++	-- * CREATE INFO++	CreateInfo(..), CreateInfoListToMiddle,++	-- * ENUM++	module Gpu.Vulkan.Pipeline.ShaderStage.Enum++	) where++import Gpu.Vulkan.Pipeline.ShaderStage.Internal+import Gpu.Vulkan.Pipeline.ShaderStage.Enum
+ src/Gpu/Vulkan/Pipeline/ShaderStage/Enum.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.ShaderStage.Enum (+	module Gpu.Vulkan.Pipeline.ShaderStage.Enum ) where++import "gpu-vulkan-middle" Gpu.Vulkan.Pipeline.ShaderStage.Enum
+ src/Gpu/Vulkan/Pipeline/ShaderStage/Internal.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE GADTs, TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.ShaderStage.Internal (++	-- * CREATE INFO++	CreateInfo(..),++	-- ** To Middle++	CreateInfoListToMiddle(..), createInfoToMiddle,++	-- ** Destroy Shader Module++	DestroyShaderModuleList(..), destroyShaderModule,+	allocationCallbacksListFromCreateInfoList++	) where++import Foreign.Storable.PeekPoke+import Data.Kind+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry+import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex+import qualified Data.HeteroParList as HeteroParList+import Data.HeteroParList (pattern (:**))+import Data.HeteroParList.Tuple qualified as HeteroParList++import Language.SpirV.ShaderKind++import qualified Data.ByteString as BS++import Gpu.Vulkan.Enum+import Gpu.Vulkan.AllocationCallbacks.Type qualified as AllocationCallbacks+import Gpu.Vulkan.Pipeline.ShaderStage.Enum++import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.ShaderModule.Internal as ShaderModule+import qualified Gpu.Vulkan.Pipeline.ShaderStage.Middle as M++data CreateInfo mn mnsm sknd mac vs = CreateInfo {+	createInfoNext :: TMaybe.M mn,+	createInfoFlags :: CreateFlags,+	createInfoStage :: ShaderStageFlagBits,+	createInfoModule :: (+		ShaderModule.CreateInfo mnsm sknd, TPMaybe.M (U2 AllocationCallbacks.A) mac ),+	createInfoName :: BS.ByteString,+	createInfoSpecializationInfo :: Maybe (HeteroParList.L vs) }++allocationCallbacksFromCreateInfo ::+	CreateInfo mn mnsm sknd mac vs ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac+allocationCallbacksFromCreateInfo CreateInfo { createInfoModule = (_, mac) } =+	mac++allocationCallbacksListFromCreateInfoList :: HeteroParList.Map3_5 cias =>+	HeteroParList.PL (U5 CreateInfo) cias ->+	HeteroParList.PL+		(TPMaybe.M (U2 AllocationCallbacks.A)) (TMapIndex.M3_5 cias)+allocationCallbacksListFromCreateInfoList =+	HeteroParList.map3_5 (allocationCallbacksFromCreateInfo . unU5)++createInfoToMiddle ::+	(WithPoked (TMaybe.M mnsm), AllocationCallbacks.ToMiddle mac)  =>+	Device.D ds -> CreateInfo n mnsm sknd mac vs ->+	IO (M.CreateInfo n sknd vs)+createInfoToMiddle dvc CreateInfo {+	createInfoNext = mnxt,+	createInfoFlags = flgs,+	createInfoStage = stg,+	createInfoModule = (mdl, mac),+	createInfoName = nm,+	createInfoSpecializationInfo = spi+	} = do+	mdl' <- ShaderModule.create dvc mdl mac+	pure M.CreateInfo {+		M.createInfoNext = mnxt,+		M.createInfoFlags = flgs,+		M.createInfoStage = stg,+		M.createInfoModule = mdl',+		M.createInfoName = nm,+		M.createInfoSpecializationInfo = spi }++class DestroyShaderModuleList (MiddleArgs cias) (TMapIndex.M3_5 cias) =>+	CreateInfoListToMiddle cias where+	type MiddleArgs cias :: [(Maybe Type, ShaderKind, [Type])]+	createInfoListToMiddle ::+		Device.D ds ->+		HeteroParList.PL (U5 CreateInfo) cias ->+		IO (HeteroParList.PL (U3 M.CreateInfo) (MiddleArgs cias))++instance CreateInfoListToMiddle '[] where+	type MiddleArgs '[] = '[]+	createInfoListToMiddle _ HeteroParList.Nil = pure HeteroParList.Nil++instance (+	WithPoked (TMaybe.M mnsm), AllocationCallbacks.ToMiddle mac,+	CreateInfoListToMiddle cias ) =>+	CreateInfoListToMiddle ('(n, mnsm, sknd, mac, vs) ': cias) where+	type MiddleArgs ('(n, mnsm, sknd, mac, vs) ': cias) =+		'(n, sknd, vs) ': MiddleArgs cias+	createInfoListToMiddle dvc (U5 ci :** cis) = (:**)+		<$> (U3 <$> createInfoToMiddle dvc ci)+		<*> createInfoListToMiddle dvc cis++class DestroyShaderModuleList cias macs  where+	destroyShaderModuleList ::+		Device.D sd -> HeteroParList.PL (U3 M.CreateInfo) cias ->+		HeteroParList.PL (TPMaybe.M (U2 AllocationCallbacks.A)) macs ->+		IO ()++instance DestroyShaderModuleList '[] '[] where+	destroyShaderModuleList _ HeteroParList.Nil HeteroParList.Nil = pure ()++instance (+	AllocationCallbacks.ToMiddle mac,+	DestroyShaderModuleList cias macs ) =>+	DestroyShaderModuleList (cia ': cias) (mac ': macs) where+	destroyShaderModuleList dvc (U3 cim :** cims) (mac :** macs) =+		destroyShaderModule dvc cim mac >>+		destroyShaderModuleList dvc cims macs++destroyShaderModule :: AllocationCallbacks.ToMiddle mac =>+	Device.D sd -> M.CreateInfo n sknd vs ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac -> IO ()+destroyShaderModule dvc M.CreateInfo { M.createInfoModule = mmdl } mac =+	ShaderModule.destroy dvc mmdl mac
+ src/Gpu/Vulkan/Pipeline/TessellationState.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.TessellationState (++	-- * CREATE INFO++	CreateInfo(..)++	) where++import Gpu.Vulkan.Pipeline.TessellationState.Middle
+ src/Gpu/Vulkan/Pipeline/VertexInputState.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.VertexInputState (++	-- * CREATE INFO++	CreateInfo(..),++	-- * FORMATTABLE++	Formattable(..)++	) where++import Gpu.Vulkan.Pipeline.VertexInputState.Internal
+ src/Gpu/Vulkan/Pipeline/VertexInputState/BindingOffset.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE DefaultSignatures #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.VertexInputState.BindingOffset (BindingOffsetNew(..)) where++import GHC.Generics+import Foreign.Storable+import Control.Arrow+import Data.Kind++type Offset = Int++class BindingOffsetNew (ts :: [Type]) (a :: Type) where+	bindingOffsetNew :: (Int, Offset)++instance BindingOffsetNew' (Rep t) ts a => BindingOffsetNew (t ': ts) a where+	bindingOffsetNew = bindingOffsetNew' @(Rep t) @ts @a 0++class BindingOffsetNew' (t :: Type -> Type) (ts :: [Type]) (a :: Type) where+	bindingOffsetNew' :: Offset -> (Int, Offset)++instance BindingOffsetNew' body ts a =>+	BindingOffsetNew' (M1 _i _c body) ts a where+	bindingOffsetNew' = bindingOffsetNew' @body @ts @a++instance Storable a => BindingOffsetNew' (K1 _i a) ts a where+	bindingOffsetNew' = (0 ,) . align @a++instance {-# OVERLAPPABLE #-} BindingOffsetNew ts a =>+	BindingOffsetNew' (K1 _i t) ts a where+	bindingOffsetNew' _ = (+ 1) `first` bindingOffsetNew @ts @a++instance BindingOffsetNew' (body :*: bs) ts a =>+	BindingOffsetNew' (M1 _i _c body :*: bs) ts a where+	bindingOffsetNew' = bindingOffsetNew' @(body :*: bs) @ts @a++instance Storable a => BindingOffsetNew' (K1 _i a :*: _bs) ts a where+	bindingOffsetNew' = (0 ,) . align @a++instance BindingOffsetNew' (b :*: (b' :*: bs)) ts a =>+	BindingOffsetNew' ((b :*: b') :*: bs) ts a where+	bindingOffsetNew' = bindingOffsetNew' @(b :*: (b' :*: bs)) @ts @a++instance {-# OVERLAPPABLE #-} (Storable t, BindingOffsetNew' bs ts a) =>+	BindingOffsetNew' (K1 _i t :*: bs) ts a where+	bindingOffsetNew' ofst = bindingOffsetNew' @bs @ts @a (nextEnd @t ofst)++nextEnd :: forall t . Storable t => Offset -> Offset+nextEnd ofst = align @t ofst + sizeOf @t undefined++align :: forall t . Storable t => Offset -> Offset+align ofst = ((ofst - 1) `div` algn + 1) * algn+	where algn = alignment @t undefined
+ src/Gpu/Vulkan/Pipeline/VertexInputState/Data/Type/TypeFam.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.VertexInputState.Data.Type.TypeFam (Until) where++import Data.Kind++type family AppMaybe (f :: x -> y) (mx :: Maybe x) :: Maybe y where+	AppMaybe _ 'Nothing = 'Nothing+	AppMaybe f ('Just x) = 'Just (f x)++type family Until t (ts :: [Type]) :: Maybe [Type] where+	Until _ '[] = 'Nothing+	Until t (t : ts) = 'Just '[t]+	Until t (t' : ts) = AppMaybe ((:) t') (Until t ts)
+ src/Gpu/Vulkan/Pipeline/VertexInputState/Data/Type/TypeValMap.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE KindSignatures, DataKinds, ConstraintKinds, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.VertexInputState.Data.Type.TypeValMap (MapTypeVal2(..), MapTypeValMaybe2(..)) where++import Data.Kind++class MapTypeVal2 c (as :: [Type]) where+	mapTypeVal2 :: (forall a . c a => a -> b) -> [b]++instance MapTypeVal2 c '[] where mapTypeVal2 _ = []++instance (c a, MapTypeVal2 c as) => MapTypeVal2 c (a ': as) where+	mapTypeVal2 x = x (undefined :: a) : mapTypeVal2 @c @as x++class MapTypeValMaybe2 c (mas :: Maybe [Type]) where+	mapTypeValMaybe2 :: (forall a . c a => a -> b) -> Maybe [b]++instance MapTypeValMaybe2 c 'Nothing where mapTypeValMaybe2 _ = Nothing++instance MapTypeVal2 c as => MapTypeValMaybe2 c ('Just as) where+	mapTypeValMaybe2 x = Just $ mapTypeVal2 @c @as x
+ src/Gpu/Vulkan/Pipeline/VertexInputState/Formattable.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.VertexInputState.Formattable where++import Gpu.Vulkan.Enum++class Formattable a where formatOf :: Format+instance Formattable Int where formatOf = FormatUndefined
+ src/Gpu/Vulkan/Pipeline/VertexInputState/GHC/Generics/TypeFam.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.VertexInputState.GHC.Generics.TypeFam (Flatten) where++import GHC.Generics+import Data.Kind++type family GetType (x :: Type -> Type) :: Type where+	GetType (K1 i a) = a+	GetType (M1 m i a) = GetType a++type family Flatten (x :: Type -> Type) :: [Type] where+	Flatten U1 = '[]+	Flatten (K1 i a) = '[a]+	Flatten (M1 m i a) = Flatten a+	Flatten (M1 m i a :*: t2) = GetType a ': Flatten t2+	Flatten ((t1 :*: t2) :*: t3) = Flatten (t1 :*: t2 :*: t3)
+ src/Gpu/Vulkan/Pipeline/VertexInputState/Internal.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.VertexInputState.Internal (++	-- * CREATE INFO++	CreateInfo(..),++	-- * CREATE INFO TO MIDDLE++	createInfoToMiddle,+	BindingStrideList, AttributeDescriptions, Formattable(..)++	) where++import GHC.TypeNats+import GHC.Generics+import Foreign.Storable.PeekPoke+import Data.TypeLevel.TypeVal qualified as TypeVal+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.Tuple.MapIndex qualified as TMapIndex+import Data.Kind+import Data.Bits+import Data.Default++import qualified Gpu.Vulkan.Pipeline.VertexInputState.Middle as M+import qualified Gpu.Vulkan.VertexInput.Internal as VtxInp+import qualified Gpu.Vulkan.VertexInput.Middle as VtxInp.M++import Gpu.Vulkan.Pipeline.VertexInputState.BindingOffset+import Gpu.Vulkan.Pipeline.VertexInputState.Formattable+import Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment+import Gpu.Vulkan.Pipeline.VertexInputState.Data.Type.TypeValMap+import Gpu.Vulkan.Pipeline.VertexInputState.GHC.Generics.TypeFam++-- CREATE INFO++data CreateInfo mn (vibs :: [(Type, VtxInp.Rate)]) (vias :: [(Nat, Type)]) =+	CreateInfo {+		createInfoNext :: TMaybe.M mn,+		createInfoFlags :: M.CreateFlags }++deriving instance Show (TMaybe.M mn) => Show (CreateInfo mn vibs vias)++instance Default (CreateInfo 'Nothing vibs vias) where+	def = CreateInfo {+		createInfoNext = TMaybe.N, createInfoFlags = zeroBits }++-- CREATE INFO TO MIDDLE++createInfoToMiddle :: forall n vibs vias . (+	BindingStrideList vibs VtxInp.Rate,+	AttributeDescriptions vibs vias ) =>+	CreateInfo n vibs vias -> M.CreateInfo n+createInfoToMiddle CreateInfo {+	createInfoNext = mnxt, createInfoFlags = flgs } = M.CreateInfo {+	M.createInfoNext = mnxt,+	M.createInfoFlags = flgs,+	M.createInfoVertexBindingDescriptions = bindingDescriptions @vibs,+	M.createInfoVertexAttributeDescriptions =+		attributeDescriptions @vibs @vias }++-- Binding Descriptions++bindingDescriptions ::+	forall vibs . BindingStrideList vibs VtxInp.Rate =>+	[VtxInp.M.BindingDescription]+bindingDescriptions = fmap VtxInp.bindingDescriptionToMiddle+	. VtxInp.bindingDescriptionFromRaw+	$ bindingStrideList @_ @vibs @VtxInp.Rate++class BindingStrideList (ts :: [(Type, k)]) v where+	bindingStrideList :: [(SizeAlignment, v)]++instance BindingStrideList '[] v where bindingStrideList = []++instance (MapTypeVal2 Sizable (Flatten (Rep t)), BindingStrideList ts v, TypeVal.T a v) =>+	BindingStrideList ('(t, a) ': ts) v where+	bindingStrideList =+		(wholeSizeAlignment @t, TypeVal.t @_ @a @v) :+		bindingStrideList @_ @ts @v++-- Attribute Descriptions++class AttributeDescriptions+	(vibs :: [(Type, VtxInp.Rate)]) (vias :: [(Nat, Type)]) where+	attributeDescriptions :: [VtxInp.AttributeDescription]++instance AttributeDescriptions vibs '[] where attributeDescriptions = []++instance (+	KnownNat i, BindingOffsetNew (TMapIndex.M0_2 vibs) t, Formattable t,+	AttributeDescriptions vibs vias ) =>+	AttributeDescriptions vibs ('(i, t) ': vias) where+	attributeDescriptions = VtxInp.AttributeDescription {+		VtxInp.attributeDescriptionLocation =+			fromIntegral $ natVal @i undefined,+		VtxInp.attributeDescriptionBinding = bdng,+		VtxInp.attributeDescriptionFormat = formatOf @t,+		VtxInp.attributeDescriptionOffset = ost } : ads+		where+		(fromIntegral -> bdng, fromIntegral -> ost) =+			bindingOffsetNew @(TMapIndex.M0_2 vibs) @t+		ads = attributeDescriptions @vibs @vias
+ src/Gpu/Vulkan/Pipeline/VertexInputState/SizeAlignment.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE DataKinds, ConstraintKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs -fno-warn-orphans #-}++module Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment (+	wholeSizeAlignment, offsetOf,+	module Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment.Internal, Offset ) where++import GHC.Generics+import Foreign.Storable.PeekPoke+import Data.Kind++import Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment.Internal+import Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment.TH++import Gpu.Vulkan.Pipeline.VertexInputState.Data.Type.TypeValMap+import Gpu.Vulkan.Pipeline.VertexInputState.GHC.Generics.TypeFam++concat <$> instanceSizeAlignmentListTuple `mapM` filter (/= 1) [0 .. 15]+concat <$> instanceSizeAlignmentListUntilTuple `mapM` filter (/= 1) [0 .. 15]++wholeSizeAlignment :: forall a . MapTypeVal2 Sizable (Flatten (Rep a)) => SizeAlignment+wholeSizeAlignment = let sas = sizeAlignmentListNew @a in+	(calcWholeSize sas, calcWholeAlignment sas)++sizeAlignmentListNew :: forall a . MapTypeVal2 Sizable (Flatten (Rep a)) => [SizeAlignment]+sizeAlignmentListNew = sizeAlignmentTypeList @(Flatten (Rep a))++sizeAlignmentTypeList ::+	forall (as :: [Type]) . MapTypeVal2 Sizable as => [SizeAlignment]+sizeAlignmentTypeList = mapTypeVal2 @Sizable @as (\(_ :: a) -> (sizeOf' @a, alignment' @a))++calcWholeAlignment :: [SizeAlignment] -> Alignment+calcWholeAlignment = foldl lcm 1 . (snd <$>)++calcWholeSize :: [SizeAlignment] -> Size+calcWholeSize = foldl next 0 . rotateAlignmentL++type Offset = Int++offsetOf :: forall t ts . SizeAlignmentListUntil t ts => Maybe Offset+offsetOf = calcOffset <$> sizeAlignmentListUntil @t @ts++calcOffset :: [SizeAlignment] -> Offset+calcOffset = foldl next 0 . shiftAlignmentL++next :: Offset -> SizeAlignment -> Offset+next os (sz, algn) = ((os + sz - 1) `div` algn + 1) * algn++shiftAlignmentL :: [SizeAlignment] -> [SizeAlignment]+shiftAlignmentL [] = error "empty size and alignment list"+shiftAlignmentL sas = zip ss as where (ss, _ : as) = unzip sas++rotateAlignmentL :: [SizeAlignment] -> [SizeAlignment]+rotateAlignmentL [] = error "empty size and alignment list"+rotateAlignmentL sas = zip ss (as ++ [a]) where (ss, a : as) = unzip sas
+ src/Gpu/Vulkan/Pipeline/VertexInputState/SizeAlignment/Internal.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE KindSignatures, DataKinds, ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment.Internal (+	SizeAlignmentList(sizeAlignmentList),+	SizeAlignmentListUntil(sizeAlignmentListUntil), MapSizableUntil,+	Size, Alignment, SizeAlignment ) where++import GHC.Generics+import Data.Kind+import Gpu.Vulkan.Pipeline.VertexInputState.GHC.Generics.TypeFam+import Gpu.Vulkan.Pipeline.VertexInputState.Data.Type.TypeFam+import Gpu.Vulkan.Pipeline.VertexInputState.Data.Type.TypeValMap++import Foreign.Storable.PeekPoke++type Size = Int+type Alignment = Int+type SizeAlignment = (Size, Alignment)++sizeAlignmentTypeList ::+	forall (as :: [Type]) . MapTypeVal2 Sizable as => [SizeAlignment]+sizeAlignmentTypeList = mapTypeVal2 @Sizable @as (\(_ :: a) -> (sizeOf' @a, alignment' @a))++class SizeAlignmentList a where+	sizeAlignmentList :: [SizeAlignment]++	default sizeAlignmentList :: (+		MapTypeVal2 Sizable (Flatten (Rep a)) ) => [SizeAlignment]+	sizeAlignmentList = sizeAlignmentTypeList @(Flatten (Rep a))++sizeAlignmentTypeMaybeList ::+	forall (mas :: Maybe [Type]) . MapTypeValMaybe2 Sizable mas =>+	Maybe [SizeAlignment]+sizeAlignmentTypeMaybeList =+	mapTypeValMaybe2 @Sizable @mas (\(_ :: a) -> (sizeOf' @a, alignment' @a))++class SizeAlignmentListUntil t a where+	sizeAlignmentListUntil :: Maybe [SizeAlignment]++	default sizeAlignmentListUntil :: (+		MapTypeValMaybe2 Sizable (Until t (Flatten (Rep a))) ) =>+		Maybe [SizeAlignment]+	sizeAlignmentListUntil =+		sizeAlignmentTypeMaybeList @(Until t (Flatten (Rep a)))++type MapSizableUntil t ts = MapTypeValMaybe2 Sizable (Until t (Flatten (Rep ts)))
+ src/Gpu/Vulkan/Pipeline/VertexInputState/SizeAlignment/TH.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment.TH (+	instanceSizeAlignmentListTuple,+	instanceSizeAlignmentListUntilTuple ) where++import Language.Haskell.TH+import Foreign.Storable.PeekPoke+import Gpu.Vulkan.Pipeline.VertexInputState.SizeAlignment.Internal+import Data.Bool++instanceSizeAlignmentListTuple :: Int -> DecsQ+instanceSizeAlignmentListTuple n = newTypes n >>= \ts -> do+	let	tpl = tupT ts+	(isInstance ''SizeAlignmentList . (: []) =<< tpl) >>= bool+		((: []) <$> instanceD+			(cxt $ (conT ''Sizable `appT`) <$> ts)+			(conT ''SizeAlignmentList `appT` tpl) [])+		(pure [])++tupT :: [TypeQ] -> TypeQ+tupT ts = foldl appT (tupleT $ length ts) ts++newTypes :: Int -> Q [TypeQ]+newTypes = ((varT <$>) <$>) . newNames++newNames :: Int -> Q [Name]+newNames n = newName `mapM` take n ((: "") <$> ['a' .. 'z'])++instanceSizeAlignmentListUntilTuple :: Int -> DecsQ+instanceSizeAlignmentListUntilTuple n =+	newName "t" >>= \t -> newTypes n >>= \ts -> do+		let	tpl = tupT ts+		(isInstance ''SizeAlignmentListUntil . (: []) =<< tpl) >>= bool+			((: []) <$> instanceD+				(cxt [conT ''MapSizableUntil `appT` varT t `appT` tpl])+--					varT t `appT` promotedListT ts])+				(conT ''SizeAlignmentListUntil `appT`+					varT t `appT` tpl) [])+			(pure [])
+ src/Gpu/Vulkan/Pipeline/ViewportState.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Pipeline.ViewportState (++	-- * CREATE INFO++	CreateInfo(..), CreateFlags++	) where++import Gpu.Vulkan.Pipeline.ViewportState.Middle
+ src/Gpu/Vulkan/PipelineCache.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.PipelineCache (++	-- * CREATE++	create, P, M.CreateInfo(..),++	-- * GET DATA++	getData, M.Data(..),++	-- * READ AND WRITE DATA++	readFile, writeFile, hRead, hWrite++	) where++import Prelude hiding (readFile, writeFile)++import Foreign.Storable.PeekPoke+import Control.Exception+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry++import Gpu.Vulkan.PipelineCache.Type++import Gpu.Vulkan.AllocationCallbacks qualified as AllocationCallbacks+import Gpu.Vulkan.AllocationCallbacks.Type qualified as AllocationCallbacks+import Gpu.Vulkan.Device qualified as Device+import Gpu.Vulkan.Device.Type qualified as Device+import Gpu.Vulkan.PipelineCache.Middle qualified as M (+	create, destroy, CreateInfo(..), getData, Data(..) )++import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc+import Foreign.C.Types+import Data.Word+import System.IO (Handle, hGetBuf, hPutBuf, withBinaryFile, IOMode(..))++import Data.ByteString qualified as BS++create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mscc) =>+	Device.D sd -> M.CreateInfo mn ->+	TPMaybe.M (U2 AllocationCallbacks.A) mscc -> (forall s . P s -> IO a) -> IO a+create (Device.D dv) ci+	(AllocationCallbacks.toMiddle -> mac) f =+	bracket (M.create dv ci mac) (\c -> M.destroy dv c mac) (f . P)++getData :: Device.D sd -> P s -> IO M.Data+getData (Device.D dv) (P c) = M.getData dv c++readFile :: FilePath -> IO M.Data+readFile fp = withBinaryFile fp ReadMode hRead++hRead :: Handle -> IO M.Data+hRead h = do+	sz <- readDataSize h+	allocaBytes (fromIntegral sz) \pd -> do+		_ <- hGetBuf h pd (fromIntegral sz)+		dataFromRaw sz pd++writeFile :: FilePath -> M.Data -> IO ()+writeFile fp d = withBinaryFile fp WriteMode (`hWrite` d)++hWrite :: Handle -> M.Data -> IO ()+hWrite h d = dataToRaw d \sz pd ->+	writeDataSize h sz >> hPutBuf h pd (fromIntegral sz)++readDataSize :: Handle -> IO Word64+readDataSize = readStorable++readStorable :: forall a . Storable a => Handle -> IO a+readStorable h = alloca \px -> hGetBuf h px (sizeOf @a undefined) >> peek px++writeDataSize :: Handle -> Word64 -> IO ()+writeDataSize = writeStorable++writeStorable :: Storable a => Handle -> a -> IO ()+writeStorable h x = alloca \px -> poke px x >> hPutBuf h px (sizeOf x)++dataFromRaw :: Word64 -> Ptr CChar -> IO M.Data+dataFromRaw sz pd = M.Data <$> BS.packCStringLen (pd, fromIntegral sz)++dataToRaw :: M.Data -> (Word64 -> Ptr CChar -> IO a) -> IO a+dataToRaw (M.Data bs) f = BS.useAsCStringLen bs \(pd, sz) -> f (fromIntegral sz) pd
+ src/Gpu/Vulkan/PipelineCache/Type.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.PipelineCache.Type (++	-- * PIPELINE CACHE++	P(..)++	) where++import qualified Gpu.Vulkan.PipelineCache.Middle as M++newtype P s = P { pToMiddle :: M.P } deriving Show
+ src/Gpu/Vulkan/PipelineLayout.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.PipelineLayout (++	-- * CREATE++	create, P, CreateInfo(..), M.CreateFlags++	) where++import Foreign.Storable.PeekPoke+import Control.Exception+import Data.Kind+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry+import qualified Data.HeteroParList as HeteroParList++import Gpu.Vulkan.PipelineLayout.Type++import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.DescriptorSetLayout.Type as DscStLyt+import qualified Gpu.Vulkan.PushConstant.Internal as PushConstant+import qualified Gpu.Vulkan.PipelineLayout.Middle as M++-- CREATE++create :: (+	WithPoked (TMaybe.M mn),+	HeteroParList.ToListT2 Type [DscStLyt.BindingType] lytas,+	PushConstant.RangeListToMiddle whole ranges,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd ->+	CreateInfo mn lytas ('PushConstant.Layout whole ranges) ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . P s lytas whole -> IO a) -> IO a+create (Device.D dvc) (createInfoToMiddle -> ci)+	(AllocationCallbacks.toMiddle -> mac) f =+	bracket (M.create dvc ci mac) (\l -> M.destroy dvc l mac) (f . P)++-- CREATE INFO++data CreateInfo mn lytas (pcl :: PushConstant.Layout) = CreateInfo {+	createInfoNext :: TMaybe.M mn, createInfoFlags :: M.CreateFlags,+	createInfoSetLayouts :: HeteroParList.PL (U2 DscStLyt.D) lytas }++deriving instance (+	Show (TMaybe.M mn), Show (HeteroParList.PL (U2 DscStLyt.D) lytas) ) =>+	Show (CreateInfo mn lytas pcl)++createInfoToMiddle :: forall n k lytas whole ranges . (+	PushConstant.RangeListToMiddle whole ranges,+	HeteroParList.ToListT2 k [DscStLyt.BindingType] lytas ) =>+	CreateInfo n lytas ('PushConstant.Layout whole ranges) -> M.CreateInfo n+createInfoToMiddle CreateInfo {+	createInfoNext = mnxt,+	createInfoFlags = flgs,+	createInfoSetLayouts = HeteroParList.toListT2+		$ DscStLyt.unL . unU2 -> sls } = M.CreateInfo {+	M.createInfoNext = mnxt,+	M.createInfoFlags = flgs,+	M.createInfoSetLayouts = sls,+	M.createInfoPushConstantRanges =+		PushConstant.rangeListToMiddle @whole @ranges }
+ src/Gpu/Vulkan/PipelineLayout/Type.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.PipelineLayout.Type where++import Data.Kind++import qualified Gpu.Vulkan.DescriptorSetLayout.Type as DescriptorSetLayout+import qualified Gpu.Vulkan.PipelineLayout.Middle as M++newtype P s+	(sbtss :: [(Type, [DescriptorSetLayout.BindingType])]) (pcw :: [Type]) =+	P M.P deriving Show
+ src/Gpu/Vulkan/PushConstant.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.PushConstant (++	-- * PUSHCONSTANT LAYOUT++	Layout(..), Range(..), RangeListToMiddle++	) where++import Gpu.Vulkan.PushConstant.Internal
+ src/Gpu/Vulkan/PushConstant/Internal.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.PushConstant.Internal (++	-- * PUSHCONSTANT LAYOUT++	Layout(..), Range(..),++	-- * PUSH CONSTANT LAYOUT TO RANGES++	RangeListToMiddle(..)++	) where++import Foreign.Storable.HeteroList+import Data.Kind++import Gpu.Vulkan.TypeEnum qualified as T+import Gpu.Vulkan.PushConstant.Middle qualified as M++data Layout = Layout [Type] [Range]++data Range = Range [T.ShaderStageFlagBits] [Type]++class RangeListToMiddle (whole :: [Type]) (ranges :: [Range]) where+	rangeListToMiddle :: [M.Range]++instance RangeListToMiddle whole '[] where rangeListToMiddle = []++instance (RangeToMiddle whole range, RangeListToMiddle whole ranges) =>+	RangeListToMiddle whole (range ': ranges) where+	rangeListToMiddle =+		rangeToMiddle @whole @range : rangeListToMiddle @whole @ranges++class RangeToMiddle (whole :: [Type]) (range :: Range) where+	rangeToMiddle :: M.Range++instance (T.ShaderStageFlagBitsListToValue sss, InfixOffsetSize part whole) =>+	RangeToMiddle whole ('Range sss part) where+	rangeToMiddle = M.Range {+		M.rangeStageFlags = T.shaderStageFlagBitsListToValue @sss,+		M.rangeOffset = fromIntegral offt,+		M.rangeSize = fromIntegral sz }+		where+		(offt, sz) = infixOffsetSize @part @whole
+ src/Gpu/Vulkan/Query.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Query (++	-- * TYPE SYNONYMS++	Q, First, Count,++	-- * ENUM++	module Gpu.Vulkan.Query.Enum++	) where++import Data.Word+import Gpu.Vulkan.Query.Enum++type First = Word32+type Count = Word32+type Q = Word32
+ src/Gpu/Vulkan/Query/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Query.Enum (module Gpu.Vulkan.Query.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Query.Enum
+ src/Gpu/Vulkan/QueryPool.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE GADTs, TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.QueryPool (++	-- * CREATE++	create, Q, CreateInfo(..),++	-- * GET RESULTS++	getResults, QueryType, PipelineStatistics(..), Timestamp(..),++	M.Availability(..)++	) where++import Foreign.Storable+import Foreign.Storable.PeekPoke+import Control.Exception+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry+import Data.Kind+import Data.Word++import Gpu.Vulkan.AllocationCallbacks qualified as AllocationCallbacks+import Gpu.Vulkan.AllocationCallbacks.Type qualified as AllocationCallbacks+import Gpu.Vulkan.PhysicalDevice qualified as PhysicalDevice+import Gpu.Vulkan.PhysicalDevice.Struct qualified as PhysicalDevice+import Gpu.Vulkan.Device.Type qualified as Device+import Gpu.Vulkan.Query qualified as Q+import Gpu.Vulkan.QueryPool.Type+import Gpu.Vulkan.QueryPool.Middle qualified as M++-- CREATE++create :: (+	WithPoked (TMaybe.M mn), QueryType tp,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd -> CreateInfo mn tp ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . Q s tp -> IO a) -> IO a+create (Device.D dv) ci+	(AllocationCallbacks.toMiddle -> macc) f = bracket+	(M.create dv (createInfoToMiddle ci) macc)+	(\qp -> M.destroy dv qp macc) (f . Q)++data CreateInfo mn (tp :: Bool -> Type) = CreateInfo {+	createInfoNext :: TMaybe.M mn,+	createInfoFlags :: M.CreateFlags,+	createInfoQueryCount :: Q.Count,+	createInfoPipelineStatistics :: Q.PipelineStatisticFlags }++deriving instance Show (TMaybe.M mn) => Show (CreateInfo mn tp)++createInfoToMiddle ::+	forall n tp . QueryType tp => CreateInfo n tp -> M.CreateInfo n+createInfoToMiddle CreateInfo {+	createInfoNext = mnxt,+	createInfoFlags = flgs,+	createInfoQueryCount = qc,+	createInfoPipelineStatistics = ps } = M.CreateInfo {+	M.createInfoNext = mnxt,+	M.createInfoFlags = flgs,+	M.createInfoQueryType = queryType @tp,+	M.createInfoQueryCount = qc,+	M.createInfoPipelineStatistics = ps }++-- GET RESULTS++getResults :: forall sd sq av tp w64 . (+	QueryType tp,+	Storable (M.W32W64 w64), M.W32W64Tools w64,+	M.AvailabilityTools av (M.W32W64 w64) ) =>+	PhysicalDevice.P ->+	Device.D sd -> Q sq tp -> Q.First -> Q.Count -> Q.ResultFlags ->+	IO [M.Availability av (tp w64)]+getResults pd (Device.D dv) (Q qp) fq qc flgs = do+	a <- getQueryArg @tp pd+	((fromWord a <$>) <$>) <$> M.getResults dv qp fq qc flgs++class QueryType (qt :: Bool -> Type) where+	type QueryArg qt+	queryType :: Q.Type+	fromWord :: QueryArg qt -> M.W32W64 w64 -> qt w64+	getQueryArg :: PhysicalDevice.P -> IO (QueryArg qt)++-- Pipeline Statistics++instance QueryType PipelineStatistics where+	type QueryArg PipelineStatistics = ()+	queryType = Q.TypePipelineStatistics+	fromWord () = pipelineStatisticsFromWord+	getQueryArg _ = pure ()++data PipelineStatistics (w64 :: Bool) where+	PipelineStatistics32 :: Word32 -> PipelineStatistics 'False+	PipelineStatistics64 :: Word64 -> PipelineStatistics 'True++deriving instance Show (PipelineStatistics w64)++pipelineStatisticsFromWord :: M.W32W64 w64 -> PipelineStatistics w64+pipelineStatisticsFromWord = \case+	M.W32 w -> PipelineStatistics32 w; M.W64 w -> PipelineStatistics64 w++-- Timestamp++data Timestamp w64 where+	Timestamp32 :: {+		timestampPeriod32 :: Float,+		timestampW32 :: Word32 } -> Timestamp 'False+	Timestamp64 :: {+		timestampPeriod64 :: Float,+		timestampW64 :: Word64 } -> Timestamp 'True++instance Show (Timestamp w64) where+	show = \case+		Timestamp32 p w ->+			show @Double (realToFrac p * fromIntegral w) ++ "ns"+		Timestamp64 p w ->+			show @Double (realToFrac p * fromIntegral w) ++ "ns"++instance QueryType Timestamp where+	type QueryArg Timestamp = Float+	queryType = Q.TypeTimestamp+	fromWord p = \case+		M.W32 w -> Timestamp32 p w; M.W64 w -> Timestamp64 p w+	getQueryArg pd = do+		lmts <- PhysicalDevice.propertiesLimits+			<$> PhysicalDevice.getProperties pd+		pure $ PhysicalDevice.limitsTimestampPeriod lmts
+ src/Gpu/Vulkan/QueryPool/Type.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE KindSignatures #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.QueryPool.Type (++	-- * QUERY POOL++	Q(..)++	) where++import Data.Kind++import Gpu.Vulkan.QueryPool.Middle qualified as M++newtype Q sq (tp :: Bool -> Type) = Q M.Q deriving Show
+ src/Gpu/Vulkan/Queue.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Queue (++	-- * SUBMIT AND WAIT IDLE++	submit, M.waitIdle, M.Q,++	-- * TYPE SYNONYM++	Index,++	-- * ENUM++	module Gpu.Vulkan.Queue.Enum++	) where++import Data.TypeLevel.Tuple.Uncurry+import Data.HeteroParList qualified as HeteroParList+import Data.Word++import Gpu.Vulkan.Internal++import qualified Gpu.Vulkan.Fence.Type as Fence++import Gpu.Vulkan.Queue.Middle qualified as M+import Gpu.Vulkan.Queue.Enum++submit :: SubmitInfoListToMiddle sias => M.Q ->+	HeteroParList.PL (U4 SubmitInfo) sias -> Maybe (Fence.F sf) -> IO ()+submit q sis mf =+	M.submit q (submitInfoListToMiddle sis) $ (\(Fence.F f) -> f) <$> mf++type Index = Word32
+ src/Gpu/Vulkan/Queue/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Queue.Enum (module Gpu.Vulkan.Queue.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Queue.Enum
+ src/Gpu/Vulkan/QueueFamily.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.QueueFamily (++	-- * PROPERTIES++	Properties(..),++	-- * INDEX++	Index, pattern Ignored++	) where++import Gpu.Vulkan.QueueFamily.Middle
+ src/Gpu/Vulkan/RenderPass.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.RenderPass (++	-- * CREATE++	create, R, CreateInfo(..),++	-- ** Group++	group, Group, create', unsafeDestroy, lookup,++	-- * BEGIN INFO++	BeginInfo(..),++	-- * ENUM++	module Gpu.Vulkan.RenderPass.Enum++	) where++import Prelude hiding (lookup)+import Gpu.Vulkan.RenderPass.Internal+import Gpu.Vulkan.RenderPass.Enum
+ src/Gpu/Vulkan/RenderPass/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.RenderPass.Enum (module Gpu.Vulkan.RenderPass.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.RenderPass.Enum
+ src/Gpu/Vulkan/RenderPass/Internal.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.RenderPass.Internal (++	-- * CREATE++	create, R, CreateInfo(..),++	-- ** Group++	group, Group, create', unsafeDestroy, lookup,++	-- * BEGIN INFO++	BeginInfo(..), beginInfoToMiddle++	) where++import Prelude hiding (lookup)++import Foreign.Storable.PeekPoke+import Control.Concurrent.STM+import Control.Concurrent.STM.TSem+import Control.Exception+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry+import Data.Map qualified as Map+import Data.HeteroParList qualified as HeteroParList++import Gpu.Vulkan.RenderPass.Type++import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.Device.Type as Device+import Gpu.Vulkan.RenderPass.Enum+import qualified Gpu.Vulkan.RenderPass.Middle as M+import qualified Gpu.Vulkan.Attachment as Attachment++import qualified Gpu.Vulkan.Subpass.Middle as Subpass++import qualified Gpu.Vulkan.Framebuffer.Type as Framebuffer+import Gpu.Vulkan.Middle++-- CREATE++create :: (+	WithPoked (TMaybe.M mn), Attachment.DescriptionListToMiddle fmts,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd -> CreateInfo mn fmts ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . R s -> IO a) -> IO a+create (Device.D dvc) ci (AllocationCallbacks.toMiddle -> mac) f = bracket+	(M.create dvc (createInfoToMiddle ci) mac)+	(\r -> M.destroy dvc r mac) (f . R)++data CreateInfo mn fmts = CreateInfo {+	createInfoNext :: TMaybe.M mn,+	createInfoFlags :: CreateFlags,+	createInfoAttachments ::+		HeteroParList.PL Attachment.Description fmts,+	createInfoSubpasses :: [Subpass.Description],+	createInfoDependencies :: [Subpass.Dependency] }++createInfoToMiddle :: Attachment.DescriptionListToMiddle fmts =>+	CreateInfo n fmts -> M.CreateInfo n+createInfoToMiddle CreateInfo {+	createInfoNext = mnxt,+	createInfoFlags = flgs,+	createInfoAttachments = atts,+	createInfoSubpasses = spss,+	createInfoDependencies = dps } = M.CreateInfo {+	M.createInfoNext = mnxt,+	M.createInfoFlags = flgs,+	M.createInfoAttachments = Attachment.descriptionListToMiddle atts,+	M.createInfoSubpasses = spss,+	M.createInfoDependencies = dps }++-- Group++data Group sd ma sr k = Group (Device.D sd)+	(TPMaybe.M (U2 AllocationCallbacks.A) ma)+	TSem (TVar (Map.Map k (R sr)))++group :: AllocationCallbacks.ToMiddle ma =>+	Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma ->+	(forall sr . Group sd ma sr k -> IO a) -> IO a+group dvc@(Device.D mdvc) mac@(AllocationCallbacks.toMiddle -> mmac) f = do+	(sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty+	rtn <- f $ Group dvc mac sem m+	((\(R mr) -> M.destroy mdvc mr mmac) `mapM_`)+		=<< atomically (readTVar m)+	pure rtn++create' :: (+	Ord k, WithPoked (TMaybe.M mn), Attachment.DescriptionListToMiddle fmts,+	AllocationCallbacks.ToMiddle mac ) =>+	Group sd mac sr k -> k -> CreateInfo mn fmts ->+	IO (Either String (R sr))+create' (Group (Device.D mdvc)+	(AllocationCallbacks.toMiddle -> mac) sem rs) k ci = do+	ok <- atomically do+		mx <- Map.lookup k <$> readTVar rs+		case mx of+			Nothing -> waitTSem sem >> pure True+			Just _ -> pure False+	if ok+	then do	r <- M.create mdvc (createInfoToMiddle ci) mac+		let r' = R r+		atomically $ modifyTVar rs (Map.insert k r') >> signalTSem sem+		pure $ Right r'+	else pure . Left $+		"Gpu.Vulkan.RenderPass.Internal.create': The key already exist"++unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) =>+	Group sd ma sr k -> k -> IO (Either String ())+unsafeDestroy (Group (Device.D mdvc)+	(AllocationCallbacks.toMiddle -> ma) sem rs) k = do+	mr <- atomically do+		mx <- Map.lookup k <$> readTVar rs+		case mx of+			Nothing -> pure Nothing+			Just _ -> waitTSem sem >> pure mx+	case mr of+		Nothing -> pure $ Left+			"Gpu.Vulkan.RenderPass.Internal.unsafeDestroy: No such key"+		Just (R r) -> do+			M.destroy mdvc r ma+			atomically do+				modifyTVar rs $ Map.delete k+				signalTSem sem+				pure $ Right ()++lookup :: Ord k => Group sd ma sr k -> k -> IO (Maybe (R sr))+lookup (Group _ _ _sem rs) k = atomically $ Map.lookup k <$> readTVar rs++-- BEGIN INFO++data BeginInfo mn sr sf cts = BeginInfo {+	beginInfoNext :: TMaybe.M mn,+	beginInfoRenderPass :: R sr,+	beginInfoFramebuffer :: Framebuffer.F sf,+	beginInfoRenderArea :: Rect2d,+	beginInfoClearValues :: HeteroParList.PL ClearValue cts }++beginInfoToMiddle :: BeginInfo n sr sf cts -> M.BeginInfo n cts+beginInfoToMiddle BeginInfo {+	beginInfoNext = mnxt,+	beginInfoRenderPass = R rp,+	beginInfoFramebuffer = Framebuffer.F fb,+	beginInfoRenderArea = ra,+	beginInfoClearValues = cvs } = M.BeginInfo {+		M.beginInfoNext = mnxt,+		M.beginInfoRenderPass = rp,+		M.beginInfoFramebuffer = fb,+		M.beginInfoRenderArea = ra,+		M.beginInfoClearValues = cvs }
+ src/Gpu/Vulkan/RenderPass/Type.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.RenderPass.Type where++import qualified Gpu.Vulkan.RenderPass.Middle as M++newtype R s = R M.R deriving Show
+ src/Gpu/Vulkan/Sample.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Sample (++	-- * COUNT AND MASK++	CountAndMask(..),++	-- ENUM++	module Gpu.Vulkan.Sample.Enum++	) where++import Gpu.Vulkan.Sample.Middle+import Gpu.Vulkan.Sample.Enum
+ src/Gpu/Vulkan/Sample/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Sample.Enum (module Gpu.Vulkan.Sample.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Sample.Enum
+ src/Gpu/Vulkan/Sampler.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Sampler (++	-- * CREATE++	create, S, M.CreateInfo(..),++	-- * ENUM++	module Gpu.Vulkan.Sampler.Enum++	) where++import Foreign.Storable.PeekPoke+import Control.Exception+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry++import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.Sampler.Middle as M+import Gpu.Vulkan.Sampler.Enum++import Gpu.Vulkan.Sampler.Type++create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) =>+	Device.D sd -> M.CreateInfo mn ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . S s -> IO a) -> IO a+create (Device.D dvc) ci+	(AllocationCallbacks.toMiddle -> mac) f =+	bracket (M.create dvc ci mac) (\s -> M.destroy dvc s mac) (f . S)
+ src/Gpu/Vulkan/Sampler/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Sampler.Enum (module Gpu.Vulkan.Sampler.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Sampler.Enum
+ src/Gpu/Vulkan/Sampler/Type.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Sampler.Type where++import qualified Gpu.Vulkan.Sampler.Middle as M++newtype S s = S { sToMiddle :: M.S } deriving Show
+ src/Gpu/Vulkan/Semaphore.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Semaphore (++	-- * CREATE++	create, S, CreateInfo(..),++	-- ** Group++	group, Group, create', unsafeDestroy, lookup,++	) where++import Prelude hiding (lookup)+import Gpu.Vulkan.Semaphore.Internal
+ src/Gpu/Vulkan/Semaphore/Internal.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Semaphore.Internal (++	-- * CREATE++	create, S(..), M.CreateInfo(..),++	-- ** Group++	group, Group, create', unsafeDestroy, lookup,++	) where++import Prelude hiding (lookup)+import Foreign.Storable.PeekPoke+import Control.Concurrent.STM+import Control.Concurrent.STM.TSem+import Control.Exception+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry+import Data.Map qualified as Map+import Data.Word++import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.Semaphore.Middle as M++import Gpu.Vulkan.Semaphore.Type++create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mac) =>+	Device.D sd -> M.CreateInfo mn ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall ss . S ss -> IO a) -> IO a+create (Device.D dvc) ci+	(AllocationCallbacks.toMiddle -> macc) f = bracket+	(M.create dvc ci macc) (\s -> M.destroy dvc s macc) (f . S)++data Group sd ma ss k = Group (Device.D sd)+	(TPMaybe.M (U2 AllocationCallbacks.A) ma) TSem (TVar (Map.Map k (S ss)))++group :: AllocationCallbacks.ToMiddle ma =>+	Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma ->+	(forall ss . Group sd ma ss k -> IO a) -> IO a+group dvc@(Device.D mdvc) mac@(AllocationCallbacks.toMiddle -> mmac) f = do+	(sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar Map.empty+	rtn <- f $ Group dvc mac sem m+	((\(S s) -> M.destroy mdvc s mmac) `mapM_`) =<< atomically (readTVar m)+	pure rtn++create' :: (+	Ord k, WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle ma) =>+	Group sd ma ss k -> k -> M.CreateInfo mn -> IO (Either String (S ss))+create' (Group (Device.D mdvc)+	(AllocationCallbacks.toMiddle -> mmac) sem ss) k ci = do+	ok <- atomically do+		mx <- Map.lookup k <$> readTVar ss+		case mx of+			Nothing -> waitTSem sem >> pure True+			Just _ -> pure False+	if ok+	then do	s <- M.create mdvc ci mmac+		let	s' = S s+		atomically $ modifyTVar ss (Map.insert k s') >> signalTSem sem+		pure $ Right s'+	else pure . Left $+		"Gpu.Vulkan.Semaphore.Internal.create': The key already exist"++unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) =>+	Group sd ma ss k -> k -> IO (Either String ())+unsafeDestroy (Group (Device.D mdvc)+	(AllocationCallbacks.toMiddle -> ma) sem ss) k = do+	ms <- atomically do+		mx <- Map.lookup k <$> readTVar ss+		case mx of+			Nothing -> pure Nothing+			Just _ -> waitTSem sem >> pure mx+	case ms of+		Nothing -> pure $ Left+			"Gpu.Vulkan.Semaphore.unsafeDestroy: No such key"+		Just (S s) -> do+			M.destroy mdvc s ma+			atomically do+				modifyTVar ss $ Map.delete k+				signalTSem sem+				pure $ Right ()++lookup :: Ord k => Group sd ma ss k -> k -> IO (Maybe (S ss))+lookup (Group _ _ _sem ss) k = atomically $ Map.lookup k <$> readTVar ss
+ src/Gpu/Vulkan/Semaphore/Type.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Semaphore.Type where++import Gpu.Vulkan.Semaphore.Middle qualified as M++newtype S s = S M.S deriving Show
+ src/Gpu/Vulkan/ShaderModule.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.ShaderModule (++	-- * CREATE INFO++	CreateInfo(..), CreateFlags++	) where++import Gpu.Vulkan.ShaderModule.Internal
+ src/Gpu/Vulkan/ShaderModule/Internal.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.ShaderModule.Internal (++	-- * CREATE AND DESTROY++	create, destroy, M.CreateInfo(..), M.CreateFlags++	) where++import Foreign.Storable.PeekPoke+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry++import qualified Gpu.Vulkan.AllocationCallbacks as AllocationCallbacks+import qualified Gpu.Vulkan.AllocationCallbacks.Type as AllocationCallbacks+import qualified Gpu.Vulkan.Device.Type as Device+import qualified Gpu.Vulkan.ShaderModule.Middle as M++create :: (WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle mscc) =>+	Device.D sd -> M.CreateInfo mn sknd -> TPMaybe.M (U2 AllocationCallbacks.A) mscc -> IO (M.S sknd)+create (Device.D dvc) m mac =+	M.create dvc m $ AllocationCallbacks.toMiddle mac++destroy :: AllocationCallbacks.ToMiddle mscc =>+	Device.D sd -> M.S sknd -> TPMaybe.M (U2 AllocationCallbacks.A) mscc -> IO ()+destroy (Device.D dvc) mm mac =+	M.destroy dvc mm $ AllocationCallbacks.toMiddle mac
+ src/Gpu/Vulkan/Subpass.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Subpass (++	-- * SUBPASS DESCRIPTION++	Description(..),++	-- * SUBPASS DEPENDENCY++	Dependency(..), S, pattern SExternal,++	-- * ENUM++	module Gpu.Vulkan.Subpass.Enum++	) where++import Gpu.Vulkan.Subpass.Middle+import Gpu.Vulkan.Subpass.Enum
+ src/Gpu/Vulkan/Subpass/Enum.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Subpass.Enum (module Gpu.Vulkan.Subpass.Enum) where++import "gpu-vulkan-middle" Gpu.Vulkan.Subpass.Enum
+ src/Gpu/Vulkan/TypeEnum.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures, TypeOperators #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.TypeEnum where++import Language.Haskell.TH+import Data.Bits++import Gpu.Vulkan.TypeEnum.Th++import qualified Gpu.Vulkan.Enum as E++import Gpu.Vulkan.TypeEnum.TypeValues++do	is <- lines <$> runIO (readFile "th/vkShaderStageFlagBits.txt")+	(: []) <$> dataD (pure []) (mkName "ShaderStageFlagBits") [] Nothing+		((`normalC` []) . mkName <$> is)+		[]++class ShaderStageFlagBitsListToValue (ts :: [ShaderStageFlagBits]) where+	shaderStageFlagBitsListToValue :: E.ShaderStageFlagBits++instance ShaderStageFlagBitsListToValue '[] where+	shaderStageFlagBitsListToValue = zeroBits++instance (ShaderStageFlagBitsToValue t, ShaderStageFlagBitsListToValue ts) =>+	ShaderStageFlagBitsListToValue (t ': ts) where+	shaderStageFlagBitsListToValue =+		shaderStageFlagBitsToValue @t .|.+		shaderStageFlagBitsListToValue @ts++class ShaderStageFlagBitsToValue (t :: ShaderStageFlagBits) where+	shaderStageFlagBitsToValue :: E.ShaderStageFlagBits++do	is <- lines <$> runIO (readFile "th/vkShaderStageFlagBits.txt")+	sequence $ mkInstance <$> is++typeValues "E" "Format" =<< lines <$> runIO (readFile "th/vkFormat.txt")
+ src/Gpu/Vulkan/TypeEnum/Th.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.TypeEnum.Th where++import Language.Haskell.TH++mkInstance :: String -> Q Dec+mkInstance ss =+	instanceD (pure []) (conT (mkName "ShaderStageFlagBitsToValue") `appT` promotedT (mkName ss)) [+		valD (varP $ mkName "shaderStageFlagBitsToValue") (normalB . conE . mkName $ "E." ++ ss) []+		]
+ src/Gpu/Vulkan/TypeEnum/TypeValues.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.TypeEnum.TypeValues (typeValues) where++import Language.Haskell.TH+import Data.Proxy+import Data.Char++typeValues :: String -> String -> [String] -> Q [Dec]+typeValues mdl tp elms =+	(\a b c -> a ++ b ++ c)	+		<$> ((: []) <$> mkType tp elms)+		<*> ((:)	<$> mkClass mdl tp+				<*> sequence (mkInstance mdl tp <$> elms))+		<*> sequence [+			sigFoo mdl tp,+			funD (mkName $ hd toLower tp ++ "ToType") (foo <$> elms) ]++mkType :: String -> [String] -> Q Dec+mkType tp elms = dataD (pure []) (mkName tp) [] Nothing+	((`normalC` []) . mkName <$> elms) [derivClause Nothing [conT ''Show]]++mkClass :: String -> String -> Q Dec+mkClass mdl tp = do+	t <- newName "t"+	classD (cxt []) (mkName $ tp ++ "ToValue")+		[kindedTV t (ConT $ mkName tp)]+		[]+		[sigD (mkName $ hd toLower tp ++ "ToValue") . conT . mkName $ mdl ++ "." ++ tp]++hd :: (a -> a) -> [a] -> [a]+hd _ [] = []+hd f (x : xs) = f x : xs++mkInstance :: String -> String -> String -> Q Dec+mkInstance mdl tp ss =+	instanceD (pure []) (conT (mkName $ tp ++ "ToValue") `appT` promotedT (mkName ss)) [+		valD	(varP . mkName $ hd toLower tp ++ "ToValue")+			(normalB . conE . mkName $ mdl ++ "." ++ ss) []+		]++sigFoo :: String -> String -> Q Dec+sigFoo mdl tp = do+	t <- newName "t"+	a <- newName "a"+	tv <- kindedInvisTV t SpecifiedSpec (conT $ mkName tp)+	sigD (mkName $ hd toLower tp ++ "ToType")+		$ conT (mkName $ mdl ++ "." ++ tp)+			`arrT` ((forallT [tv]+				(cxt [conT (mkName $ tp ++ "ToValue") `appT` varT t])+				((conT ''Proxy `appT` varT t) `arrT` varT a))+		`arrT` varT a)++foo :: String -> Q Clause+foo nm = do+	f <- newName "f"+	clause+		[conP (mkName $ "E." ++ nm) [], varP f]+		(normalB $ varE f `appE`+			(conE 'Proxy `appTypeE` promotedT (mkName nm)))+		[]++arrT :: Q Type -> Q Type -> Q Type+t1 `arrT` t2 = arrowT `appT` t1 `appT` t2
+ src/Gpu/Vulkan/VertexInput.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.VertexInput (Rate(..)) where++import Gpu.Vulkan.VertexInput.Internal
+ src/Gpu/Vulkan/VertexInput/Internal.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE DataKinds, PolyKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGe MultiParamTypeClasses, AllowAmbiguousTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.VertexInput.Internal (+	Rate(..),+	M.AttributeDescription(..),+	BindingDescription(..),++	bindingDescriptionFromRaw,+	bindingDescriptionToMiddle,++	) where++import Data.Word+import Data.TypeLevel.TypeVal qualified as TypeVal++import Gpu.Vulkan.VertexInput.Middle qualified as M+import Gpu.Vulkan.VertexInput.Enum qualified as M++data Rate = RateVertex | RateInstance deriving Show++instance TypeVal.T 'RateVertex Rate where t = RateVertex+instance TypeVal.T 'RateInstance Rate where t = RateInstance++data BindingDescription = BindingDescription {+	bindingDescriptionBinding :: Word32,+	bindingDescriptionStride :: Word32,+	bindingDescriptionInputRate :: Rate }+	deriving Show++type SizeAlignment = (Int, Int)++bindingDescriptionFromRaw :: [(SizeAlignment, Rate)] -> [BindingDescription]+bindingDescriptionFromRaw sars = (<$> zip [0 ..] sars)+	\(b, ((fromIntegral -> sz, _algn), r)) -> BindingDescription b sz r++bindingDescriptionToMiddle :: BindingDescription -> M.BindingDescription+bindingDescriptionToMiddle BindingDescription {+	bindingDescriptionBinding = bdg,+	bindingDescriptionStride = strd,+	bindingDescriptionInputRate = rt } = M.BindingDescription {+	M.bindingDescriptionBinding = bdg,+	M.bindingDescriptionStride = strd,+	M.bindingDescriptionInputRate = rateToEnum rt }+	where rateToEnum = \case+		RateVertex -> M.RateVertex; RateInstance -> M.RateInstance
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"
+ th/vkFormat.txt view
@@ -0,0 +1,303 @@+FormatUndefined+FormatR4g4UnormPack8+FormatR4g4b4a4UnormPack16+FormatB4g4r4a4UnormPack16+FormatR5g6b5UnormPack16+FormatB5g6r5UnormPack16+FormatR5g5b5a1UnormPack16+FormatB5g5r5a1UnormPack16+FormatA1r5g5b5UnormPack16+FormatR8Unorm+FormatR8Snorm+FormatR8Uscaled+FormatR8Sscaled+FormatR8Uint+FormatR8Sint+FormatR8Srgb+FormatR8g8Unorm+FormatR8g8Snorm+FormatR8g8Uscaled+FormatR8g8Sscaled+FormatR8g8Uint+FormatR8g8Sint+FormatR8g8Srgb+FormatR8g8b8Unorm+FormatR8g8b8Snorm+FormatR8g8b8Uscaled+FormatR8g8b8Sscaled+FormatR8g8b8Uint+FormatR8g8b8Sint+FormatR8g8b8Srgb+FormatB8g8r8Unorm+FormatB8g8r8Snorm+FormatB8g8r8Uscaled+FormatB8g8r8Sscaled+FormatB8g8r8Uint+FormatB8g8r8Sint+FormatB8g8r8Srgb+FormatR8g8b8a8Unorm+FormatR8g8b8a8Snorm+FormatR8g8b8a8Uscaled+FormatR8g8b8a8Sscaled+FormatR8g8b8a8Uint+FormatR8g8b8a8Sint+FormatR8g8b8a8Srgb+FormatB8g8r8a8Unorm+FormatB8g8r8a8Snorm+FormatB8g8r8a8Uscaled+FormatB8g8r8a8Sscaled+FormatB8g8r8a8Uint+FormatB8g8r8a8Sint+FormatB8g8r8a8Srgb+FormatA8b8g8r8UnormPack32+FormatA8b8g8r8SnormPack32+FormatA8b8g8r8UscaledPack32+FormatA8b8g8r8SscaledPack32+FormatA8b8g8r8UintPack32+FormatA8b8g8r8SintPack32+FormatA8b8g8r8SrgbPack32+FormatA2r10g10b10UnormPack32+FormatA2r10g10b10SnormPack32+FormatA2r10g10b10UscaledPack32+FormatA2r10g10b10SscaledPack32+FormatA2r10g10b10UintPack32+FormatA2r10g10b10SintPack32+FormatA2b10g10r10UnormPack32+FormatA2b10g10r10SnormPack32+FormatA2b10g10r10UscaledPack32+FormatA2b10g10r10SscaledPack32+FormatA2b10g10r10UintPack32+FormatA2b10g10r10SintPack32+FormatR16Unorm+FormatR16Snorm+FormatR16Uscaled+FormatR16Sscaled+FormatR16Uint+FormatR16Sint+FormatR16Sfloat+FormatR16g16Unorm+FormatR16g16Snorm+FormatR16g16Uscaled+FormatR16g16Sscaled+FormatR16g16Uint+FormatR16g16Sint+FormatR16g16Sfloat+FormatR16g16b16Unorm+FormatR16g16b16Snorm+FormatR16g16b16Uscaled+FormatR16g16b16Sscaled+FormatR16g16b16Uint+FormatR16g16b16Sint+FormatR16g16b16Sfloat+FormatR16g16b16a16Unorm+FormatR16g16b16a16Snorm+FormatR16g16b16a16Uscaled+FormatR16g16b16a16Sscaled+FormatR16g16b16a16Uint+FormatR16g16b16a16Sint+FormatR16g16b16a16Sfloat+FormatR32Uint+FormatR32Sint+FormatR32Sfloat+FormatR32g32Uint+FormatR32g32Sint+FormatR32g32Sfloat+FormatR32g32b32Uint+FormatR32g32b32Sint+FormatR32g32b32Sfloat+FormatR32g32b32a32Uint+FormatR32g32b32a32Sint+FormatR32g32b32a32Sfloat+FormatR64Uint+FormatR64Sint+FormatR64Sfloat+FormatR64g64Uint+FormatR64g64Sint+FormatR64g64Sfloat+FormatR64g64b64Uint+FormatR64g64b64Sint+FormatR64g64b64Sfloat+FormatR64g64b64a64Uint+FormatR64g64b64a64Sint+FormatR64g64b64a64Sfloat+FormatB10g11r11UfloatPack32+FormatE5b9g9r9UfloatPack32+FormatD16Unorm+FormatX8D24UnormPack32+FormatD32Sfloat+FormatS8Uint+FormatD16UnormS8Uint+FormatD24UnormS8Uint+FormatD32SfloatS8Uint+FormatBc1RgbUnormBlock+FormatBc1RgbSrgbBlock+FormatBc1RgbaUnormBlock+FormatBc1RgbaSrgbBlock+FormatBc2UnormBlock+FormatBc2SrgbBlock+FormatBc3UnormBlock+FormatBc3SrgbBlock+FormatBc4UnormBlock+FormatBc4SnormBlock+FormatBc5UnormBlock+FormatBc5SnormBlock+FormatBc6hUfloatBlock+FormatBc6hSfloatBlock+FormatBc7UnormBlock+FormatBc7SrgbBlock+FormatEtc2R8g8b8UnormBlock+FormatEtc2R8g8b8SrgbBlock+FormatEtc2R8g8b8a1UnormBlock+FormatEtc2R8g8b8a1SrgbBlock+FormatEtc2R8g8b8a8UnormBlock+FormatEtc2R8g8b8a8SrgbBlock+FormatEacR11UnormBlock+FormatEacR11SnormBlock+FormatEacR11g11UnormBlock+FormatEacR11g11SnormBlock+FormatAstc4x4UnormBlock+FormatAstc4x4SrgbBlock+FormatAstc5x4UnormBlock+FormatAstc5x4SrgbBlock+FormatAstc5x5UnormBlock+FormatAstc5x5SrgbBlock+FormatAstc6x5UnormBlock+FormatAstc6x5SrgbBlock+FormatAstc6x6UnormBlock+FormatAstc6x6SrgbBlock+FormatAstc8x5UnormBlock+FormatAstc8x5SrgbBlock+FormatAstc8x6UnormBlock+FormatAstc8x6SrgbBlock+FormatAstc8x8UnormBlock+FormatAstc8x8SrgbBlock+FormatAstc10x5UnormBlock+FormatAstc10x5SrgbBlock+FormatAstc10x6UnormBlock+FormatAstc10x6SrgbBlock+FormatAstc10x8UnormBlock+FormatAstc10x8SrgbBlock+FormatAstc10x10UnormBlock+FormatAstc10x10SrgbBlock+FormatAstc12x10UnormBlock+FormatAstc12x10SrgbBlock+FormatAstc12x12UnormBlock+FormatAstc12x12SrgbBlock+FormatG8b8g8r8422Unorm+FormatB8g8r8g8422Unorm+FormatG8B8R83plane420Unorm+FormatG8B8r82plane420Unorm+FormatG8B8R83plane422Unorm+FormatG8B8r82plane422Unorm+FormatG8B8R83plane444Unorm+FormatR10x6UnormPack16+FormatR10x6g10x6Unorm2pack16+FormatR10x6g10x6b10x6a10x6Unorm4pack16+FormatG10x6b10x6g10x6r10x6422Unorm4pack16+FormatB10x6g10x6r10x6g10x6422Unorm4pack16+FormatG10x6B10x6R10x63plane420Unorm3pack16+FormatG10x6B10x6r10x62plane420Unorm3pack16+FormatG10x6B10x6R10x63plane422Unorm3pack16+FormatG10x6B10x6r10x62plane422Unorm3pack16+FormatG10x6B10x6R10x63plane444Unorm3pack16+FormatR12x4UnormPack16+FormatR12x4g12x4Unorm2pack16+FormatR12x4g12x4b12x4a12x4Unorm4pack16+FormatG12x4b12x4g12x4r12x4422Unorm4pack16+FormatB12x4g12x4r12x4g12x4422Unorm4pack16+FormatG12x4B12x4R12x43plane420Unorm3pack16+FormatG12x4B12x4r12x42plane420Unorm3pack16+FormatG12x4B12x4R12x43plane422Unorm3pack16+FormatG12x4B12x4r12x42plane422Unorm3pack16+FormatG12x4B12x4R12x43plane444Unorm3pack16+FormatG16b16g16r16422Unorm+FormatB16g16r16g16422Unorm+FormatG16B16R163plane420Unorm+FormatG16B16r162plane420Unorm+FormatG16B16R163plane422Unorm+FormatG16B16r162plane422Unorm+FormatG16B16R163plane444Unorm+FormatG8B8r82plane444Unorm+FormatG10x6B10x6r10x62plane444Unorm3pack16+FormatG12x4B12x4r12x42plane444Unorm3pack16+FormatG16B16r162plane444Unorm+FormatA4r4g4b4UnormPack16+FormatA4b4g4r4UnormPack16+FormatAstc4x4SfloatBlock+FormatAstc5x4SfloatBlock+FormatAstc5x5SfloatBlock+FormatAstc6x5SfloatBlock+FormatAstc6x6SfloatBlock+FormatAstc8x5SfloatBlock+FormatAstc8x6SfloatBlock+FormatAstc8x8SfloatBlock+FormatAstc10x5SfloatBlock+FormatAstc10x6SfloatBlock+FormatAstc10x8SfloatBlock+FormatAstc10x10SfloatBlock+FormatAstc12x10SfloatBlock+FormatAstc12x12SfloatBlock+FormatPvrtc12bppUnormBlockImg+FormatPvrtc14bppUnormBlockImg+FormatPvrtc22bppUnormBlockImg+FormatPvrtc24bppUnormBlockImg+FormatPvrtc12bppSrgbBlockImg+FormatPvrtc14bppSrgbBlockImg+FormatPvrtc22bppSrgbBlockImg+FormatPvrtc24bppSrgbBlockImg+FormatR16g16S105Nv+FormatAstc4x4SfloatBlockExt+FormatAstc5x4SfloatBlockExt+FormatAstc5x5SfloatBlockExt+FormatAstc6x5SfloatBlockExt+FormatAstc6x6SfloatBlockExt+FormatAstc8x5SfloatBlockExt+FormatAstc8x6SfloatBlockExt+FormatAstc8x8SfloatBlockExt+FormatAstc10x5SfloatBlockExt+FormatAstc10x6SfloatBlockExt+FormatAstc10x8SfloatBlockExt+FormatAstc10x10SfloatBlockExt+FormatAstc12x10SfloatBlockExt+FormatAstc12x12SfloatBlockExt+FormatG8b8g8r8422UnormKhr+FormatB8g8r8g8422UnormKhr+FormatG8B8R83plane420UnormKhr+FormatG8B8r82plane420UnormKhr+FormatG8B8R83plane422UnormKhr+FormatG8B8r82plane422UnormKhr+FormatG8B8R83plane444UnormKhr+FormatR10x6UnormPack16Khr+FormatR10x6g10x6Unorm2pack16Khr+FormatR10x6g10x6b10x6a10x6Unorm4pack16Khr+FormatG10x6b10x6g10x6r10x6422Unorm4pack16Khr+FormatB10x6g10x6r10x6g10x6422Unorm4pack16Khr+FormatG10x6B10x6R10x63plane420Unorm3pack16Khr+FormatG10x6B10x6r10x62plane420Unorm3pack16Khr+FormatG10x6B10x6R10x63plane422Unorm3pack16Khr+FormatG10x6B10x6r10x62plane422Unorm3pack16Khr+FormatG10x6B10x6R10x63plane444Unorm3pack16Khr+FormatR12x4UnormPack16Khr+FormatR12x4g12x4Unorm2pack16Khr+FormatR12x4g12x4b12x4a12x4Unorm4pack16Khr+FormatG12x4b12x4g12x4r12x4422Unorm4pack16Khr+FormatB12x4g12x4r12x4g12x4422Unorm4pack16Khr+FormatG12x4B12x4R12x43plane420Unorm3pack16Khr+FormatG12x4B12x4r12x42plane420Unorm3pack16Khr+FormatG12x4B12x4R12x43plane422Unorm3pack16Khr+FormatG12x4B12x4r12x42plane422Unorm3pack16Khr+FormatG12x4B12x4R12x43plane444Unorm3pack16Khr+FormatG16b16g16r16422UnormKhr+FormatB16g16r16g16422UnormKhr+FormatG16B16R163plane420UnormKhr+FormatG16B16r162plane420UnormKhr+FormatG16B16R163plane422UnormKhr+FormatG16B16r162plane422UnormKhr+FormatG16B16R163plane444UnormKhr+FormatG8B8r82plane444UnormExt+FormatG10x6B10x6r10x62plane444Unorm3pack16Ext+FormatG12x4B12x4r12x42plane444Unorm3pack16Ext+FormatG16B16r162plane444UnormExt+FormatA4r4g4b4UnormPack16Ext+FormatA4b4g4r4UnormPack16Ext+FormatMaxEnum
+ th/vkPhysicalDeviceFeatures.txt view
@@ -0,0 +1,55 @@+VkBool32|A robustBufferAccess+VkBool32|A fullDrawIndexUint32+VkBool32|A imageCubeArray+VkBool32|A independentBlend+VkBool32|A geometryShader+VkBool32|A tessellationShader+VkBool32|A sampleRateShading+VkBool32|A dualSrcBlend+VkBool32|A logicOp+VkBool32|A multiDrawIndirect+VkBool32|A drawIndirectFirstInstance+VkBool32|A depthClamp+VkBool32|A depthBiasClamp+VkBool32|A fillModeNonSolid+VkBool32|A depthBounds+VkBool32|A wideLines+VkBool32|A largePoints+VkBool32|A alphaToOne+VkBool32|A multiViewport+VkBool32|A samplerAnisotropy+VkBool32|A textureCompressionETC2+VkBool32|A textureCompressionASTC_LDR+VkBool32|A textureCompressionBC+VkBool32|A occlusionQueryPrecise+VkBool32|A pipelineStatisticsQuery+VkBool32|A vertexPipelineStoresAndAtomics+VkBool32|A fragmentStoresAndAtomics+VkBool32|A shaderTessellationAndGeometryPointSize+VkBool32|A shaderImageGatherExtended+VkBool32|A shaderStorageImageExtendedFormats+VkBool32|A shaderStorageImageMultisample+VkBool32|A shaderStorageImageReadWithoutFormat+VkBool32|A shaderStorageImageWriteWithoutFormat+VkBool32|A shaderUniformBufferArrayDynamicIndexing+VkBool32|A shaderSampledImageArrayDynamicIndexing+VkBool32|A shaderStorageBufferArrayDynamicIndexing+VkBool32|A shaderStorageImageArrayDynamicIndexing+VkBool32|A shaderClipDistance+VkBool32|A shaderCullDistance+VkBool32|A shaderFloat64+VkBool32|A shaderInt64+VkBool32|A shaderInt16+VkBool32|A shaderResourceResidency+VkBool32|A shaderResourceMinLod+VkBool32|A sparseBinding+VkBool32|A sparseResidencyBuffer+VkBool32|A sparseResidencyImage2D+VkBool32|A sparseResidencyImage3D+VkBool32|A sparseResidency2Samples+VkBool32|A sparseResidency4Samples+VkBool32|A sparseResidency8Samples+VkBool32|A sparseResidency16Samples+VkBool32|A sparseResidencyAliased+VkBool32|A variableMultisampleRate+VkBool32|A inheritedQueries
+ th/vkPhysicalDeviceLimits.txt view
@@ -0,0 +1,106 @@+uint32_t|A maxImageDimension1D+uint32_t|A maxImageDimension2D+uint32_t|A maxImageDimension3D+uint32_t|A maxImageDimensionCube+uint32_t|A maxImageArrayLayers+uint32_t|A maxTexelBufferElements+uint32_t|A maxUniformBufferRange+uint32_t|A maxStorageBufferRange+uint32_t|A maxPushConstantsSize+uint32_t|A maxMemoryAllocationCount+uint32_t|A maxSamplerAllocationCount+VkDeviceSize|A bufferImageGranularity+VkDeviceSize|A sparseAddressSpaceSize+uint32_t|A maxBoundDescriptorSets+uint32_t|A maxPerStageDescriptorSamplers+uint32_t|A maxPerStageDescriptorUniformBuffers+uint32_t|A maxPerStageDescriptorStorageBuffers+uint32_t|A maxPerStageDescriptorSampledImages+uint32_t|A maxPerStageDescriptorStorageImages+uint32_t|A maxPerStageDescriptorInputAttachments+uint32_t|A maxPerStageResources+uint32_t|A maxDescriptorSetSamplers+uint32_t|A maxDescriptorSetUniformBuffers+uint32_t|A maxDescriptorSetUniformBuffersDynamic+uint32_t|A maxDescriptorSetStorageBuffers+uint32_t|A maxDescriptorSetStorageBuffersDynamic+uint32_t|A maxDescriptorSetSampledImages+uint32_t|A maxDescriptorSetStorageImages+uint32_t|A maxDescriptorSetInputAttachments+uint32_t|A maxVertexInputAttributes+uint32_t|A maxVertexInputBindings+uint32_t|A maxVertexInputAttributeOffset+uint32_t|A maxVertexInputBindingStride+uint32_t|A maxVertexOutputComponents+uint32_t|A maxTessellationGenerationLevel+uint32_t|A maxTessellationPatchSize+uint32_t|A maxTessellationControlPerVertexInputComponents+uint32_t|A maxTessellationControlPerVertexOutputComponents+uint32_t|A maxTessellationControlPerPatchOutputComponents+uint32_t|A maxTessellationControlTotalOutputComponents+uint32_t|A maxTessellationEvaluationInputComponents+uint32_t|A maxTessellationEvaluationOutputComponents+uint32_t|A maxGeometryShaderInvocations+uint32_t|A maxGeometryInputComponents+uint32_t|A maxGeometryOutputComponents+uint32_t|A maxGeometryOutputVertices+uint32_t|A maxGeometryTotalOutputComponents+uint32_t|A maxFragmentInputComponents+uint32_t|A maxFragmentOutputAttachments+uint32_t|A maxFragmentDualSrcAttachments+uint32_t|A maxFragmentCombinedOutputResources+uint32_t|A maxComputeSharedMemorySize+uint32_t|L maxComputeWorkGroupCount 3+uint32_t|A maxComputeWorkGroupInvocations+uint32_t|L maxComputeWorkGroupSize 3+uint32_t|A subPixelPrecisionBits+uint32_t|A subTexelPrecisionBits+uint32_t|A mipmapPrecisionBits+uint32_t|A maxDrawIndexedIndexValue+uint32_t|A maxDrawIndirectCount+float|A maxSamplerLodBias+float|A maxSamplerAnisotropy+uint32_t|A maxViewports+uint32_t|L maxViewportDimensions 2+float|L viewportBoundsRange 2+uint32_t|A viewportSubPixelBits+size_t|A minMemoryMapAlignment+VkDeviceSize|A minTexelBufferOffsetAlignment+VkDeviceSize|A minUniformBufferOffsetAlignment+VkDeviceSize|A minStorageBufferOffsetAlignment+int32_t|A minTexelOffset+uint32_t|A maxTexelOffset+int32_t|A minTexelGatherOffset+uint32_t|A maxTexelGatherOffset+float|A minInterpolationOffset+float|A maxInterpolationOffset+uint32_t|A subPixelInterpolationOffsetBits+uint32_t|A maxFramebufferWidth+uint32_t|A maxFramebufferHeight+uint32_t|A maxFramebufferLayers+VkSampleCountFlags|A framebufferColorSampleCounts+VkSampleCountFlags|A framebufferDepthSampleCounts+VkSampleCountFlags|A framebufferStencilSampleCounts+VkSampleCountFlags|A framebufferNoAttachmentsSampleCounts+uint32_t|A maxColorAttachments+VkSampleCountFlags|A sampledImageColorSampleCounts+VkSampleCountFlags|A sampledImageIntegerSampleCounts+VkSampleCountFlags|A sampledImageDepthSampleCounts+VkSampleCountFlags|A sampledImageStencilSampleCounts+VkSampleCountFlags|A storageImageSampleCounts+uint32_t|A maxSampleMaskWords+VkBool32|A timestampComputeAndGraphics+float|A timestampPeriod+uint32_t|A maxClipDistances+uint32_t|A maxCullDistances+uint32_t|A maxCombinedClipAndCullDistances+uint32_t|A discreteQueuePriorities+float|L pointSizeRange 2+float|L lineWidthRange 2+float|A pointSizeGranularity+float|A lineWidthGranularity+VkBool32|A strictLines+VkBool32|A standardSampleLocations+VkDeviceSize|A optimalBufferCopyOffsetAlignment+VkDeviceSize|A optimalBufferCopyRowPitchAlignment+VkDeviceSize|A nonCoherentAtomSize
+ th/vkShaderStageFlagBits.txt view
@@ -0,0 +1,28 @@+ShaderStageFlagsZero+ShaderStageVertexBit+ShaderStageTessellationControlBit+ShaderStageTessellationEvaluationBit+ShaderStageGeometryBit+ShaderStageFragmentBit+ShaderStageComputeBit+ShaderStageAllGraphics+ShaderStageAll+ShaderStageRaygenBitKhr+ShaderStageAnyHitBitKhr+ShaderStageClosestHitBitKhr+ShaderStageMissBitKhr+ShaderStageIntersectionBitKhr+ShaderStageCallableBitKhr+ShaderStageTaskBitExt+ShaderStageMeshBitExt+ShaderStageSubpassShadingBitHuawei+ShaderStageClusterCullingBitHuawei+ShaderStageRaygenBitNv+ShaderStageAnyHitBitNv+ShaderStageClosestHitBitNv+ShaderStageMissBitNv+ShaderStageIntersectionBitNv+ShaderStageCallableBitNv+ShaderStageTaskBitNv+ShaderStageMeshBitNv+ShaderStageFlagBitsMaxEnum