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

raw patch · 8 files changed

+378/−0 lines, 8 filesdep +basedep +containersdep +fixed-genericsetup-changed

Dependencies added: base, containers, fixed-generic, gpu-vulkan, gpu-vulkan-khr-surface, gpu-vulkan-khr-swapchain, gpu-vulkan-middle-khr-swapchain, hetero-parameter-list, stm, storable-peek-poke, typelevel-tools-yj

Files

CHANGELOG.md +11/−0
LICENSE +26/−0
README.md +1/−0
Setup.hs +2/−0
gpu-vulkan-khr-swapchain.cabal +74/−0
src/Gpu/Vulkan/Khr/Swapchain.hs +252/−0
src/Gpu/Vulkan/Khr/Swapchain/Type.hs +10/−0
test/Spec.hs +2/−0

+ CHANGELOG.md view

@@ -0,0 +1,11 @@+# Changelog for `gpu-vulkan-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-khr-swapchain

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ gpu-vulkan-khr-swapchain.cabal view

@@ -0,0 +1,74 @@+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-khr-swapchain+version:        0.1.0.0+synopsis:       VK_KHR_swapchain extension of the Vulkan API+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/gpu-vulkan-khr-swapchain#readme>+category:       GPU+homepage:       https://github.com/YoshikuniJujo/gpu-vulkan-khr-swapchain#readme+bug-reports:    https://github.com/YoshikuniJujo/gpu-vulkan-khr-swapchain/issues+author:         Yoshikuni Jujo+maintainer:     yoshikuni.jujo@gmail.com+copyright:      Copyright (c) 2023 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-khr-swapchain++library+  exposed-modules:+      Gpu.Vulkan.Khr.Swapchain+  other-modules:+      Gpu.Vulkan.Khr.Swapchain.Type+      Paths_gpu_vulkan_khr_swapchain+  autogen-modules:+      Paths_gpu_vulkan_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+    , containers <1+    , fixed-generic <1+    , gpu-vulkan <1+    , gpu-vulkan-khr-surface <1+    , gpu-vulkan-middle-khr-swapchain <1+    , hetero-parameter-list <1+    , stm <3+    , storable-peek-poke <1+    , typelevel-tools-yj <1+  default-language: Haskell2010++test-suite gpu-vulkan-khr-swapchain-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_gpu_vulkan_khr_swapchain+  autogen-modules:+      Paths_gpu_vulkan_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+    , containers <1+    , fixed-generic <1+    , gpu-vulkan <1+    , gpu-vulkan-khr-surface <1+    , gpu-vulkan-khr-swapchain+    , gpu-vulkan-middle-khr-swapchain <1+    , hetero-parameter-list <1+    , stm <3+    , storable-peek-poke <1+    , typelevel-tools-yj <1+  default-language: Haskell2010

+ src/Gpu/Vulkan/Khr/Swapchain.hs view

@@ -0,0 +1,252 @@+{-# LANGUAGE ImportQualifiedPost, PackageImports #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ScopedTypeVariables, RankNTypes, 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 (++	-- * EXTENSION NAME++	extensionName,++	-- * CREATE++	create, unsafeRecreate, S, CreateInfo(..),++	-- ** Group++	group, Group, create', unsafeDestroy, lookup,++	-- * GET IMAGES++	getImages,++	-- * QUEUE PRESENT++	queuePresent, PresentInfo(..), SwapchainImageIndex(..),		-- VK_KHR_swapchain++	-- * ACQUIRE NEXT IMAGE++	acquireNextImage, acquireNextImageResult,		-- VK_KHR_swapchain+++	) 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 Data.Fixed.Generic qualified as FixedG++import Gpu.Vulkan+import Gpu.Vulkan.Khr.Surface (+	PresentMode, ColorSpace, TransformFlagBits, CompositeAlphaFlagBits )+import Gpu.Vulkan.Khr.Swapchain.Type+import Gpu.Vulkan.Khr.Swapchain.Enum++import qualified Gpu.Vulkan as C+import qualified Gpu.Vulkan.TypeEnum as T+import qualified Gpu.Vulkan.AllocationCallbacks.Internal as AllocationCallbacks+import qualified Gpu.Vulkan.Device.Internal as Device+import qualified Gpu.Vulkan.Image.Internal as Image+import qualified Gpu.Vulkan.Khr.Swapchain.Middle as M++import qualified Gpu.Vulkan.Image as Image+import qualified Gpu.Vulkan.QueueFamily as QueueFamily+import qualified Gpu.Vulkan.Khr.Surface.Internal as Surface++import Gpu.Vulkan.PhysicalDevice qualified as PhysicalDevice++import qualified Gpu.Vulkan.Semaphore.Internal as Semaphore+import qualified Gpu.Vulkan.Fence.Internal as Fence+import Gpu.Vulkan.Exception+import Data.HeteroParList qualified as HeteroParList+import qualified Gpu.Vulkan.Queue as Queue++extensionName :: PhysicalDevice.ExtensionName+extensionName = PhysicalDevice.ExtensionName M.extensionName++create :: (+	WithPoked (TMaybe.M mn), T.FormatToValue fmt,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd -> CreateInfo mn ssfc fmt ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac ->+	(forall s . S fmt s -> IO a) -> IO a+create (Device.D dvc) ci (AllocationCallbacks.toMiddle -> mac) f = bracket+	(M.create dvc (createInfoToMiddle ci) mac)+	(\sc -> M.destroy dvc sc mac) (f . S)++unsafeRecreate :: (+	WithPoked (TMaybe.M mn), T.FormatToValue fmt,+	AllocationCallbacks.ToMiddle mac ) =>+	Device.D sd -> CreateInfo mn ssfc fmt ->+	TPMaybe.M (U2 AllocationCallbacks.A) mac -> S fmt ssc -> IO ()+unsafeRecreate (Device.D dvc) ci (AllocationCallbacks.toMiddle -> mac) (S sc) =+	M.recreate dvc (createInfoToMiddle ci) mac sc++data CreateInfo mn ssfc (fmt :: T.Format) = CreateInfo {+	createInfoNext :: TMaybe.M mn,+	createInfoFlags :: CreateFlags,+	createInfoSurface :: Surface.S ssfc,+	createInfoMinImageCount :: Word32,+	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 M.S }++deriving instance Show (TMaybe.M mn) => Show (CreateInfo mn ss fmt)++createInfoToMiddle :: forall n ss fmt . T.FormatToValue fmt =>+	CreateInfo n ss fmt -> M.CreateInfo n+createInfoToMiddle CreateInfo {+	createInfoNext = mnxt,+	createInfoFlags = flgs,+	createInfoSurface = Surface.S sfc,+	createInfoMinImageCount = mic,+	createInfoImageColorSpace = cs,+	createInfoImageExtent = ext,+	createInfoImageArrayLayers = ials,+	createInfoImageUsage = usg,+	createInfoImageSharingMode = sm,+	createInfoQueueFamilyIndices = qfis,+	createInfoPreTransform = ptfm,+	createInfoCompositeAlpha = calph,+	createInfoPresentMode = pm,+	createInfoClipped = clpd,+	createInfoOldSwapchain = osc } = M.CreateInfo {+	M.createInfoNext = mnxt,+	M.createInfoFlags = flgs,+	M.createInfoSurface = sfc,+	M.createInfoMinImageCount = mic,+	M.createInfoImageFormat = T.formatToValue @fmt,+	M.createInfoImageColorSpace = cs,+	M.createInfoImageExtent = ext,+	M.createInfoImageArrayLayers = ials,+	M.createInfoImageUsage = usg,+	M.createInfoImageSharingMode = sm,+	M.createInfoQueueFamilyIndices = qfis,+	M.createInfoPreTransform = ptfm,+	M.createInfoCompositeAlpha = calph,+	M.createInfoPresentMode = pm,+	M.createInfoClipped = clpd,+	M.createInfoOldSwapchain = osc }++getImages :: Device.D sd -> S fmt ss -> IO [Image.Binded ss ss nm fmt]+getImages (Device.D d) (S sc) = (Image.Binded <$>) <$> M.getImages d sc++data Group sd ma fmt ssc k = Group (Device.D sd)+	(TPMaybe.M (U2 AllocationCallbacks.A) ma) TSem (TVar (Map.Map k (S fmt ssc)))++group :: forall fmt k sd ma a .+	AllocationCallbacks.ToMiddle ma =>+	Device.D sd -> TPMaybe.M (U2 AllocationCallbacks.A) ma ->+	(forall ssc . Group sd ma fmt ssc 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' :: (+	T.FormatToValue fmt,+	Ord k, WithPoked (TMaybe.M mn), AllocationCallbacks.ToMiddle ma ) =>+	Group sd ma fmt ss k -> k -> CreateInfo mn ssfc fmt ->+	IO (Either String (S fmt ss))+create' (Group (Device.D mdvc)+	(AllocationCallbacks.toMiddle -> mmac) sem ss) k+	(createInfoToMiddle -> mci) = 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 mci mmac+		let	s' = S s+		atomically $ modifyTVar ss (Map.insert k s') >> signalTSem sem+		pure $ Right s'+	else pure . Left $+		"Gpu.Vulkan.Khr.Swapchain.create': The key already exist"++unsafeDestroy :: (Ord k, AllocationCallbacks.ToMiddle ma) =>+	Group sd ma fmt ssc k -> k -> IO (Either String ())+unsafeDestroy (Group (Device.D mdvc)+	(AllocationCallbacks.toMiddle -> ma) sem scs) k = do+	msc <- atomically do+		mx <- Map.lookup k <$> readTVar scs+		case mx of+			Nothing -> pure Nothing+			Just _ -> waitTSem sem >> pure mx+	case msc of+		Nothing -> pure $ Left+			"Gpu.Vulkan.Khr.Swapchain.destroy: No such key"+		Just (S sc) -> do+			M.destroy mdvc sc ma+			atomically do+				modifyTVar scs $ Map.delete k+				signalTSem sem+				pure $ Right ()++lookup :: Ord k => Group sd ma fmt ssc k -> k -> IO (Maybe (S fmt ssc))+lookup (Group _ _ _sem scs) k = atomically $ Map.lookup k <$> readTVar scs++queuePresent :: WithPoked (TMaybe.M mn) =>+	Queue.Q -> PresentInfo mn swss scfmt sscs -> IO ()+queuePresent q = M.queuePresent q . presentInfoToMiddle++data PresentInfo mn swss scfmt sscs = PresentInfo {+	presentInfoNext :: TMaybe.M mn,+	presentInfoWaitSemaphores :: HeteroParList.PL Semaphore.S swss,+	presentInfoSwapchainImageIndices ::+		HeteroParList.PL (SwapchainImageIndex scfmt) sscs }++presentInfoToMiddle :: PresentInfo mn sws scfmt sscs -> M.PresentInfo mn+presentInfoToMiddle PresentInfo {+	presentInfoNext = mnxt,+	presentInfoWaitSemaphores =+		HeteroParList.toList (\(Semaphore.S s) -> s) -> wss,+	presentInfoSwapchainImageIndices =+		HeteroParList.toList swapchainImageIndexToMiddle -> sciis+	} = M.PresentInfo {+		M.presentInfoNext = mnxt,+		M.presentInfoWaitSemaphores = wss,+		M.presentInfoSwapchainImageIndices = sciis }++data SwapchainImageIndex scfmt ssc =+	SwapchainImageIndex (S scfmt ssc) Word32 deriving Show++swapchainImageIndexToMiddle ::+	SwapchainImageIndex scfmt ssc -> (M.S, Word32)+swapchainImageIndexToMiddle (SwapchainImageIndex (S sc) idx) =+	(sc, idx)++acquireNextImage :: Device.D sd ->+	S scfmt ssc -> Maybe Sec -> Maybe (Semaphore.S ss) -> Maybe (Fence.F sf) -> IO Word32+acquireNextImage = acquireNextImageResult [Success]++acquireNextImageResult :: [Result] -> Device.D sd ->+	S scfmt ssc -> Maybe Sec -> Maybe (Semaphore.S ss) -> Maybe (Fence.F sf) -> IO Word32+acquireNextImageResult sccs (Device.D mdvc) (S msc)+	(maybe maxBound (\(Sec (FixedG.MkF ns)) -> ns) -> to)+	msmp (((\(Fence.F f) -> f) <$>) -> mfnc) =+	M.acquireNextImageResult+		sccs mdvc msc to ((\(Semaphore.S smp) -> smp) <$> msmp) mfnc

+ src/Gpu/Vulkan/Khr/Swapchain/Type.hs view

@@ -0,0 +1,10 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Khr.Swapchain.Type where++import qualified Gpu.Vulkan.TypeEnum as T+import qualified Gpu.Vulkan.Khr.Swapchain.Middle as M++newtype S (fmt :: T.Format) ss = S M.S deriving Show

+ test/Spec.hs view

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"