packages feed

gpu-vulkan-middle-khr-swapchain (empty) → 0.1.0.0

raw patch · 9 files changed

+445/−0 lines, 9 filesdep +basedep +c-enumdep +data-defaultsetup-changed

Dependencies added: base, c-enum, data-default, gpu-vulkan-core, gpu-vulkan-core-khr-swapchain, gpu-vulkan-middle, gpu-vulkan-middle-khr-surface, gpu-vulkan-middle-khr-swapchain, storable-peek-poke, text, typelevel-tools-yj

Files

+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `gpu-vulkan-middle-khr-swapchain`++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,26 @@+Copyright 2025 Yoshikuni Jujo++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1.  Redistributions of source code must retain the above copyright notice, this+    list of conditions and the following disclaimer.++2.  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.++3.  Neither the name of the copyright holder nor the names of its 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 HOLDER 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 @@+# gpu-vulkan-middle-khr-swapchain
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gpu-vulkan-middle-khr-swapchain.cabal view
@@ -0,0 +1,75 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:           gpu-vulkan-middle-khr-swapchain+version:        0.1.0.0+synopsis:       medium wrapper for VK_KHR_swapchain extension of the Vulkan API+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/gpu-vulkan-middle-khr-swapchain#readme>+category:       GPU+homepage:       https://github.com/YoshikuniJujo/gpu-vulkan-middle-khr-swapchain#readme+bug-reports:    https://github.com/YoshikuniJujo/gpu-vulkan-middle-khr-swapchain/issues+author:         Yoshikuni Jujo+maintainer:     yoshikuni.jujo@gmail.com+copyright:      (c) 2025 Yoshikuni Jujo+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-doc-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/YoshikuniJujo/gpu-vulkan-middle-khr-swapchain++library+  exposed-modules:+      Gpu.Vulkan.Khr.Swapchain.Enum+      Gpu.Vulkan.Khr.Swapchain.Middle+      Gpu.Vulkan.Khr.Swapchain.Middle.Internal+  other-modules:+      Paths_gpu_vulkan_middle_khr_swapchain+  autogen-modules:+      Paths_gpu_vulkan_middle_khr_swapchain+  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+    , c-enum <1+    , data-default <1+    , gpu-vulkan-core <1+    , gpu-vulkan-core-khr-swapchain <1+    , gpu-vulkan-middle <1+    , gpu-vulkan-middle-khr-surface <1+    , storable-peek-poke <1+    , text <3+    , typelevel-tools-yj <1+  default-language: Haskell2010++test-suite gpu-vulkan-middle-khr-swapchain-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_gpu_vulkan_middle_khr_swapchain+  autogen-modules:+      Paths_gpu_vulkan_middle_khr_swapchain+  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+    , c-enum <1+    , data-default <1+    , gpu-vulkan-core <1+    , gpu-vulkan-core-khr-swapchain <1+    , gpu-vulkan-middle <1+    , gpu-vulkan-middle-khr-surface <1+    , gpu-vulkan-middle-khr-swapchain+    , storable-peek-poke <1+    , text <3+    , typelevel-tools-yj <1+  default-language: Haskell2010
+ src/Gpu/Vulkan/Khr/Swapchain/Enum.hsc view
@@ -0,0 +1,37 @@+-- This file is automatically generated by the tools/makeEnum.hs+--	% stack runghc --cwd tools/ makeEnum++{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-missing-export-lists -fno-warn-tabs #-}++module Gpu.Vulkan.Khr.Swapchain.Enum where++import Foreign.Storable+import Foreign.C.Enum+import Data.Bits+import Data.Word+import Data.Default++#include <vulkan/vulkan.h>++enum "CreateFlagBits" ''#{type VkSwapchainCreateFlagBitsKHR}+		[''Show, ''Eq, ''Storable, ''Bits] [+	("CreateFlagsZero", 0),+	("CreateSplitInstanceBindRegionsBit",+		#{const VK_SWAPCHAIN_CREATE_SPLIT_INSTANCE_BIND_REGIONS_BIT_KHR}),+	("CreateProtectedBit",+		#{const VK_SWAPCHAIN_CREATE_PROTECTED_BIT_KHR}),+	("CreateMutableFormatBit",+		#{const VK_SWAPCHAIN_CREATE_MUTABLE_FORMAT_BIT_KHR}),+	("CreateDeferredMemoryAllocationBitExt",+		#{const VK_SWAPCHAIN_CREATE_DEFERRED_MEMORY_ALLOCATION_BIT_EXT}),+	("CreateFlagBitsMaxEnum",+		#{const VK_SWAPCHAIN_CREATE_FLAG_BITS_MAX_ENUM_KHR}) ]++instance Default CreateFlagBits where+	def = CreateFlagsZero++type CreateFlags = CreateFlagBits
+ src/Gpu/Vulkan/Khr/Swapchain/Middle.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Khr.Swapchain.Middle (++	-- * EXTENSION NAME++	extensionName,++	-- * CREAET AND DESTROY++	create, recreate, destroy, S, CreateInfo(..),++	-- * GET IMAGES++	getImages,++	-- * ACQUIRE NEXT IMAGE++	acquireNextImage, acquireNextImageResult,	-- VK_KHR_swapchain++	-- * QUEUE PRESENT++	queuePresent, PresentInfo(..)			-- VK_KHR_swapchain++	) where++import Gpu.Vulkan.Khr.Swapchain.Middle.Internal
+ src/Gpu/Vulkan/Khr/Swapchain/Middle/Internal.hsc view
@@ -0,0 +1,264 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, OverloadedStrings, TupleSections #-}+{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Khr.Swapchain.Middle.Internal (++	-- * EXTENSION NAME++	extensionName,++	-- * CREAET AND DESTROY++	create, recreate, destroy, S, CreateInfo(..),++	-- * GET IMAGES++	getImages,++	-- * INTERNAL USE++	sToCore,++	-- * ACQUIRE NEXT IMAGE++	acquireNextImage, acquireNextImageResult,	-- VK_KHR_swapchain++	-- * QUEUE PRESENT++	queuePresent, PresentInfo(..)			-- VK_KHR_swapchain++	) where++import Foreign.Ptr+import Foreign.Marshal+import Foreign.Storable+import Foreign.Storable.PeekPoke+import Data.TypeLevel.Maybe qualified as TMaybe+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.Word+import Data.IORef++import qualified Data.Text as T++import Gpu.Vulkan.Enum+import Gpu.Vulkan.Base.Middle.Internal+import Gpu.Vulkan.Exception.Middle+import Gpu.Vulkan.Exception.Enum+import Gpu.Vulkan.Khr.Surface.Enum+import Gpu.Vulkan.Khr.Swapchain.Enum++import Gpu.Vulkan.AllocationCallbacks.Middle.Internal+	qualified as AllocationCallbacks+import qualified Gpu.Vulkan.QueueFamily.Middle as QueueFamily+import qualified Gpu.Vulkan.Device.Middle.Internal as Device+import qualified Gpu.Vulkan.Image.Middle.Internal as Image+import qualified Gpu.Vulkan.Image.Enum as Image+import qualified Gpu.Vulkan.Khr.Surface.Middle.Internal as Surface.M+import qualified Gpu.Vulkan.Core as C+import qualified Gpu.Vulkan.Khr.Swapchain.Core as C++import qualified Gpu.Vulkan.Device.Middle.Internal as Device.M+import qualified Gpu.Vulkan.Fence.Middle.Internal as Fence+import qualified Gpu.Vulkan.Semaphore.Middle.Internal as Semaphore.M+import Gpu.Vulkan.Queue.Middle.Internal as Queue+import Control.Arrow++#include <vulkan/vulkan.h>++extensionName :: T.Text+extensionName = #{const_str VK_KHR_SWAPCHAIN_EXTENSION_NAME}++newtype S = S { _unS :: IORef (C.Extent2d, C.S) }++instance Show S where show _ = "Gpu.Vulkan.Khr.Swapchain.Middle.S"++sToCore :: S -> IO C.S+sToCore (S s) = snd <$> readIORef s++sFromCore :: C.Extent2d -> C.S -> IO S+sFromCore ex s = S <$> newIORef (ex, s)++data CreateInfo mn = CreateInfo {+	createInfoNext :: TMaybe.M mn,+	createInfoFlags :: CreateFlags,+	createInfoSurface :: Surface.M.S,+	createInfoMinImageCount :: Word32,+	createInfoImageFormat :: Format,+	createInfoImageColorSpace :: ColorSpace,+	createInfoImageExtent :: C.Extent2d,+	createInfoImageArrayLayers :: Word32,+	createInfoImageUsage :: Image.UsageFlags,+	createInfoImageSharingMode :: SharingMode,+	createInfoQueueFamilyIndices :: [QueueFamily.Index],+	createInfoPreTransform :: TransformFlagBits,+	createInfoCompositeAlpha :: CompositeAlphaFlagBits,+	createInfoPresentMode :: PresentMode,+	createInfoClipped :: Bool,+	createInfoOldSwapchain :: Maybe S }++deriving instance Show (TMaybe.M mn) => Show (CreateInfo mn)++create :: WithPoked (TMaybe.M mn) =>+	Device.D -> CreateInfo mn -> TPMaybe.M AllocationCallbacks.A mc -> IO S+create (Device.D dvc) ci mac = sFromCore ex =<< alloca \psc -> do+		createInfoToCoreOld ci \pci ->+			AllocationCallbacks.mToCore mac \pac -> do+				r <- C.create dvc pci pac psc+				throwUnlessSuccess $ Result r+		peek psc+	where ex = createInfoImageExtent ci++recreate :: WithPoked (TMaybe.M mn) =>+	Device.D -> CreateInfo mn ->+	TPMaybe.M AllocationCallbacks.A mc ->+	S -> IO ()+recreate (Device.D dvc) ci macc (S rs) = alloca \psc ->+		createInfoToCoreOld ci \pci ->+		AllocationCallbacks.mToCore macc \pacc -> do+			r <- C.create dvc pci pacc psc+			throwUnlessSuccess $ Result r+			(_, sco) <- readIORef rs+			writeIORef rs . (ex ,) =<< peek psc+			C.destroy dvc sco pacc+	where ex = createInfoImageExtent ci++destroy :: Device.D -> S -> TPMaybe.M AllocationCallbacks.A md -> IO ()+destroy (Device.D dvc) sc mac = AllocationCallbacks.mToCore mac \pac -> do+	sc' <- sToCore sc+	C.destroy dvc sc' pac++createInfoToCoreOld :: WithPoked (TMaybe.M mn) => CreateInfo mn -> (Ptr C.CreateInfo -> IO a) -> IO ()+createInfoToCoreOld CreateInfo {+	createInfoNext = mnxt,+	createInfoFlags = CreateFlagBits flgs,+	createInfoSurface = Surface.M.S sfc,+	createInfoMinImageCount = mic,+	createInfoImageFormat = Format ifmt,+	createInfoImageColorSpace = ColorSpace ics,+	createInfoImageExtent = iex,+	createInfoImageArrayLayers = ials,+	createInfoImageUsage = Image.UsageFlagBits iusg,+	createInfoImageSharingMode = SharingMode ism,+	createInfoQueueFamilyIndices = ((\(QueueFamily.Index i) -> i) <$>) -> qfis,+	createInfoPreTransform = TransformFlagBits pt,+	createInfoCompositeAlpha = CompositeAlphaFlagBits caf,+	createInfoPresentMode = PresentMode pm,+	createInfoClipped = clpd,+	createInfoOldSwapchain = mos } f =+	withPoked' mnxt \pnxt -> withPtrS pnxt \(castPtr -> pnxt') ->+	allocaArray qfic \pqfis ->+	pokeArray pqfis qfis >>+	let	ci os = C.CreateInfo {+			C.createInfoSType = (),+			C.createInfoPNext = pnxt',+			C.createInfoFlags = flgs,+			C.createInfoSurface = sfc,+			C.createInfoMinImageCount = mic,+			C.createInfoImageFormat = ifmt,+			C.createInfoImageColorSpace = ics,+			C.createInfoImageExtent = iex,+			C.createInfoImageArrayLayers = ials,+			C.createInfoImageUsage = iusg,+			C.createInfoImageSharingMode = ism,+			C.createInfoQueueFamilyIndexCount = fromIntegral qfic,+			C.createInfoPQueueFamilyIndices = pqfis,+			C.createInfoPreTransform = pt,+			C.createInfoCompositeAlpha = caf,+			C.createInfoPresentMode = pm,+			C.createInfoClipped = boolToBool32 clpd,+			C.createInfoOldSwapchain = os } in+	case mos of+		Nothing -> withPoked (ci . wordPtrToPtr $ WordPtr #{const VK_NULL_HANDLE}) f+		Just s -> sToCore s >>= \os -> withPoked (ci os) f+	where qfic = length qfis++getImages :: Device.D -> S -> IO [Image.I]+getImages (Device.D dvc) sc = ((Image.I <$>) <$>) $ sToCore sc >>= \sc' ->+	sToExtent sc >>= \ex ->+	alloca \pSwapchainImageCount ->+	C.getImages dvc sc' pSwapchainImageCount NullPtr >>= \r ->+	throwUnlessSuccess (Result r) >>+	peek pSwapchainImageCount >>= \(fromIntegral -> swapchainImageCount) ->+	allocaArray swapchainImageCount \pSwapchainImages -> do+		r' <- C.getImages dvc sc' pSwapchainImageCount pSwapchainImages+		throwUnlessSuccess $ Result r'+		mapM (newIORef . (extent2dTo3d ex ,))+			=<< peekArray swapchainImageCount pSwapchainImages++sToExtent :: S -> IO C.Extent2d+sToExtent (S s) = fst <$> readIORef s++extent2dTo3d :: C.Extent2d -> C.Extent3d+extent2dTo3d C.Extent2d { C.extent2dWidth = w, C.extent2dHeight = h } =+	C.Extent3d {+		C.extent3dWidth = w, C.extent3dHeight = h, C.extent3dDepth = 1 }++acquireNextImage :: Device.M.D ->+	S -> Word64 -> Maybe Semaphore.M.S -> Maybe Fence.F -> IO Word32+acquireNextImage = acquireNextImageResult [Success]++acquireNextImageResult :: [Result] -> Device.M.D ->+	S -> Word64 -> Maybe Semaphore.M.S -> Maybe Fence.F -> IO Word32+acquireNextImageResult sccs+	(Device.M.D dvc) sc to msmp mfnc = alloca \pii ->+	sToCore sc >>= \sc' -> do+		r <- C.acquireNextImage dvc sc' to smp fnc pii+		throwUnless sccs $ Result r+		peek pii+	where+	smp = maybe NullHandle (\(Semaphore.M.S s) -> s) msmp+	fnc = maybe NullHandle (\(Fence.F f) -> f) mfnc++---------------------------------------------------------------------------++queuePresent :: WithPoked (TMaybe.M mn) => Queue.Q -> PresentInfo mn -> IO ()+queuePresent (Queue.Q q) pi_ =+	presentInfoMiddleToCore pi_ \cpi -> do+	withPoked cpi \ppi -> do+		r <- C.queuePresent q ppi+		let	(fromIntegral -> rc) = C.presentInfoSwapchainCount cpi+		rs <- peekArray rc $ C.presentInfoPResults cpi+		throwUnlessSuccesses $ Result <$> rs+		throwUnlessSuccess $ Result r++data PresentInfo mn = PresentInfo {+	presentInfoNext :: TMaybe.M mn,+	presentInfoWaitSemaphores :: [Semaphore.M.S],+	presentInfoSwapchainImageIndices ::+		[(S, Word32)] }++deriving instance Show (TMaybe.M mn) => Show (PresentInfo mn)++presentInfoMiddleToCore ::+	WithPoked (TMaybe.M mn) => PresentInfo mn -> (C.PresentInfo -> IO a) -> IO ()+presentInfoMiddleToCore PresentInfo {+	presentInfoNext = mnxt,+	presentInfoWaitSemaphores =+		(length &&& id) . (Semaphore.M.unS <$>) -> (wsc, wss),+	presentInfoSwapchainImageIndices =+		(length &&& id . unzip) -> (scc, (scs, iis)) } f =+	sToCore `mapM` scs >>= \scs' ->+	withPoked' mnxt \pnxt -> withPtrS pnxt \(castPtr -> pnxt') ->+	allocaArray wsc \pwss ->+	pokeArray pwss wss >>+	allocaArray scc \pscs ->+	pokeArray pscs scs' >>+	allocaArray scc \piis ->+	pokeArray piis iis >>+	allocaArray scc \prs -> f C.PresentInfo {+		C.presentInfoSType = (),+		C.presentInfoPNext = pnxt',+		C.presentInfoWaitSemaphoreCount = fromIntegral wsc,+		C.presentInfoPWaitSemaphores = pwss,+		C.presentInfoSwapchainCount = fromIntegral scc,+		C.presentInfoPSwapchains = pscs,+		C.presentInfoPImageIndices = piis,+		C.presentInfoPResults = prs }
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"