diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -2,6 +2,13 @@ ## WIP +## [0.2] - 2020-11-15 + +- Add `Vulkan.Utils.Misc` for handy functions used in Vulkan programs, but not + Vulkan specific. +- Add `Vulkan.Utils.Initializaion` for functions to ease creating a Vulkan device. +- Add `Vulkan.Vulkan.Utils.QueueAssignment` to help with easy queue creation. + ## [0.1.3] - 2020-11-12 - Add `glsl` interpolating quasiquoter diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: vulkan-utils -version: "0.1.3" +version: "0.2" synopsis: Utils for the vulkan package category: Graphics maintainer: Joe Hermaszewski @@ -13,16 +13,21 @@ library: source-dirs: src c-sources: cbits/DebugCallback.c + other-modules: "" dependencies: - base <5 - bytestring - extra - file-embed - filepath + - resourcet >= 1.2.4 - template-haskell - temporary + - text + - transformers - typed-process - - vulkan + - vector + - vulkan >= 3.6.14 tests: doctests: @@ -42,11 +47,12 @@ - cabal-doctest >= 1 && <1.1 default-extensions: - - AllowAmbiguousTypes - - CPP - DataKinds - DefaultSignatures - DeriveAnyClass + - DeriveFoldable + - DeriveFunctor + - DeriveTraversable - DerivingStrategies - DuplicateRecordFields - FlexibleContexts @@ -68,9 +74,9 @@ - ScopedTypeVariables - StandaloneDeriving - Strict + - TupleSections - TypeApplications - TypeFamilyDependencies - TypeOperators - TypeSynonymInstances - - UndecidableInstances - ViewPatterns diff --git a/src/Vulkan/Utils/Initialization.hs b/src/Vulkan/Utils/Initialization.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/Initialization.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE OverloadedLists #-} + +module Vulkan.Utils.Initialization + ( createDebugInstanceWithExtensions + , createInstanceWithExtensions + , pickPhysicalDevice + , physicalDeviceName + , createDeviceWithExtensions + ) where + +import Control.Exception ( throwIO ) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Bits +import Data.ByteString ( ByteString ) +import Data.Foldable +import Data.Maybe +import Data.Ord +import Data.Text ( Text ) +import Data.Text.Encoding ( decodeUtf8 ) +import qualified Data.Vector as V +import GHC.IO.Exception ( IOErrorType(NoSuchThing) + , IOException(..) + ) +import Vulkan.CStruct.Extends +import Vulkan.Core10 +import Vulkan.Extensions.VK_EXT_debug_utils +import Vulkan.Extensions.VK_EXT_validation_features +import Vulkan.Utils.Debug +import Vulkan.Utils.Misc +import Vulkan.Zero + +---------------------------------------------------------------- +-- * Instance Creation +---------------------------------------------------------------- + +-- | Like 'createInstanceWithExtensions' except it will create a debug utils +-- messenger (from the @VK_EXT_debug_utils@ extension). +-- +-- If the @VK_EXT_validation_features@ extension (from the +-- @VK_LAYER_KHRONOS_validation@ layer) is available is it will be enabled and +-- best practices messages enabled. +createDebugInstanceWithExtensions + :: forall es m + . (Extendss InstanceCreateInfo es, PokeChain es, MonadResource m) + => [ByteString] + -- ^ Required layers + -> [ByteString] + -- ^ Optional layers + -> [ByteString] + -- ^ Required extensions + -> [ByteString] + -- ^ Optional extensions + -> InstanceCreateInfo es + -> m Instance +createDebugInstanceWithExtensions requiredLayers optionalLayers requiredExtensions optionalExtensions instanceCreateInfo + = do + let debugMessengerCreateInfo = zero + { messageSeverity = DEBUG_UTILS_MESSAGE_SEVERITY_WARNING_BIT_EXT + .|. DEBUG_UTILS_MESSAGE_SEVERITY_ERROR_BIT_EXT + , messageType = DEBUG_UTILS_MESSAGE_TYPE_GENERAL_BIT_EXT + .|. DEBUG_UTILS_MESSAGE_TYPE_VALIDATION_BIT_EXT + .|. DEBUG_UTILS_MESSAGE_TYPE_PERFORMANCE_BIT_EXT + , pfnUserCallback = debugCallbackPtr + } + validationFeatures = ValidationFeaturesEXT + [VALIDATION_FEATURE_ENABLE_BEST_PRACTICES_EXT] + [] + instanceCreateInfo' + :: InstanceCreateInfo + (DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es) + instanceCreateInfo' = instanceCreateInfo + { next = debugMessengerCreateInfo :& validationFeatures :& next + (instanceCreateInfo :: InstanceCreateInfo es) + } + inst <- createInstanceWithExtensions + requiredLayers + ("VK_LAYER_KHRONOS_validation" : optionalLayers) + (EXT_DEBUG_UTILS_EXTENSION_NAME : requiredExtensions) + (EXT_VALIDATION_FEATURES_EXTENSION_NAME : optionalExtensions) + instanceCreateInfo' + _ <- withDebugUtilsMessengerEXT inst + debugMessengerCreateInfo + Nothing + allocate + pure inst + +-- | Create an 'Instance' with some layers and extensions, the layers and +-- extensions will be added to the provided 'InstanceCreateInfo'. +-- +-- Will throw an 'IOError in the case of missing layers or extensions. Details +-- on missing layers and extensions will be reported in stderr. +createInstanceWithExtensions + :: forall es m + . (Extendss InstanceCreateInfo es, PokeChain es, MonadResource m) + => [ByteString] + -- ^ Required layers + -> [ByteString] + -- ^ Optional layers + -> [ByteString] + -- ^ Required extensions + -> [ByteString] + -- ^ Optional extensions + -> InstanceCreateInfo es + -> m Instance +createInstanceWithExtensions requiredLayers optionalLayers requiredExtensions optionalExtensions instanceCreateInfo + = do + -- + -- First get the layers, they're needed to get the list of supported + -- extensions, as some of them may only be present in layers. + -- + availableLayerNames <- + toList . fmap layerName . snd <$> enumerateInstanceLayerProperties + layers <- partitionOptReqIO "layer" + availableLayerNames + optionalLayers + requiredLayers + + -- Run 'enumerateInstanceExtensionProperties' once for the instance itself, + -- and once for each layer and collect the results. + availableExtensionNames <- concat <$> traverse + ( fmap (toList . fmap extensionName . snd) + . enumerateInstanceExtensionProperties + ) + (Nothing : (Just <$> layers)) + extensions <- partitionOptReqIO "instance extension" + availableExtensionNames + optionalExtensions + requiredExtensions + + let + instanceCreateInfo' :: InstanceCreateInfo es + instanceCreateInfo' = instanceCreateInfo + { enabledLayerNames = + enabledLayerNames (instanceCreateInfo :: InstanceCreateInfo es) + <> V.fromList layers + , enabledExtensionNames = + enabledExtensionNames (instanceCreateInfo :: InstanceCreateInfo es) + <> V.fromList extensions + } + (_, inst) <- withInstance instanceCreateInfo' Nothing allocate + pure inst + +---------------------------------------------------------------- +-- * Physical device selection +---------------------------------------------------------------- + +-- | Get a single 'PhysicalDevice' deciding with a scoring function +-- +-- Pass a function which will extract any required values from a device in the +-- spirit of parse-don't validate. Also provide a function to compare these +-- results for sorting multiple devices. +-- +-- For example the result function could return a tuple of device memory and +-- the compute queue family index, and the scoring function could be 'fst' to +-- select devices based on their memory capacity. +-- +-- If no devices are deemed suitable then an 'IOError' is thrown. +pickPhysicalDevice + :: (MonadIO m, Ord b) + => Instance + -> (PhysicalDevice -> m (Maybe a)) + -- ^ Some result for a PhysicalDevice, Nothing if it is not to be chosen. + -> (a -> b) + -- ^ Scoring function to rate this result + -> m (a, PhysicalDevice) + -- ^ The score and the device +pickPhysicalDevice inst devInfo score = do + (_, devs) <- enumeratePhysicalDevices inst + infos <- catMaybes + <$> sequence [ fmap (, d) <$> devInfo d | d <- toList devs ] + case maximumByMay (comparing (score.fst)) infos of + Nothing -> liftIO $ noSuchThing "Unable to find appropriate PhysicalDevice" + Just d -> pure d + +-- | Extract the name of a 'PhysicalDevice' with 'getPhysicalDeviceProperties' +physicalDeviceName :: MonadIO m => PhysicalDevice -> m Text +physicalDeviceName = + fmap (decodeUtf8 . deviceName) . getPhysicalDeviceProperties + +---------------------------------------------------------------- +-- * Device initialization +---------------------------------------------------------------- + +-- | Create a 'Device' with some extensions, the extensions will be added to +-- the provided 'DeviceCreateInfo'. +-- +-- Will throw an 'IOError in the case of missing extensions. Missing extensions +-- will be listed on stderr. +createDeviceWithExtensions + :: forall es m + . (Extendss DeviceCreateInfo es, PokeChain es, MonadResource m) + => PhysicalDevice + -> [ByteString] + -- ^ Required extensions + -> [ByteString] + -- ^ Optional extensions + -> DeviceCreateInfo es + -> m Device +createDeviceWithExtensions phys requiredExtensions optionalExtensions deviceCreateInfo + = do + availableExtensionNames <- + fmap extensionName + . snd + <$> enumerateDeviceExtensionProperties phys Nothing + extensions <- partitionOptReqIO "device extension" + (toList availableExtensionNames) + requiredExtensions + optionalExtensions + + let + deviceCreateInfo' :: DeviceCreateInfo es + deviceCreateInfo' = deviceCreateInfo + { enabledExtensionNames = + enabledExtensionNames (deviceCreateInfo :: DeviceCreateInfo es) + <> V.fromList extensions + } + + (_, dev) <- withDevice phys deviceCreateInfo' Nothing allocate + pure dev + +---------------------------------------------------------------- +-- Utils +---------------------------------------------------------------- + +noSuchThing :: String -> IO a +noSuchThing message = + throwIO $ IOError Nothing NoSuchThing "" message Nothing Nothing + +maximumByMay :: Foldable t => (a -> a -> Ordering) -> t a -> Maybe a +maximumByMay f xs = if null xs then Nothing else Just (maximumBy f xs) diff --git a/src/Vulkan/Utils/Misc.hs b/src/Vulkan/Utils/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/Misc.hs @@ -0,0 +1,117 @@ +module Vulkan.Utils.Misc + ( -- * Sorting things + partitionOptReq + , partitionOptReqIO + -- * Bit Utils + , showBits + , (.&&.) + ) where + +import Control.Monad.IO.Class +import Data.Bits +import Data.Foldable +import Data.List ( intercalate + , partition + ) +import GHC.IO ( throwIO ) +import GHC.IO.Exception ( IOErrorType(NoSuchThing) + , IOException(..) + ) +import System.IO ( hPutStrLn + , stderr + ) + +-- | From a list of things, take all the required things and as many optional +-- things as possible. +partitionOptReq + :: Eq a + => [a] + -- ^ What do we have available + -> [a] + -- ^ Optional desired elements + -> [a] + -- ^ Required desired elements + -> ([a], Either [a] [a]) + -- ^ (Missing optional elements, Either (missing required elements) or (all + -- required elements and as many optional elements as possible) +partitionOptReq available optional required = + let (optHave, optMissing) = partition (`elem` available) optional + (reqHave, reqMissing) = partition (`elem` available) required + in ( optMissing + , case reqMissing of + [] -> Right (reqHave <> optHave) + xs -> Left xs + ) + +-- | Like 'partitionOptReq'. +-- +-- Will throw an 'IOError in the case of missing things. Details on missing +-- things will be reported in stderr. +-- +-- This is useful in dealing with layers and extensions. +partitionOptReqIO + :: (Show a, Eq a, MonadIO m) + => String + -- ^ What are we sorting (Used for a debug message) + -> [a] + -- ^ What do we have available + -> [a] + -- ^ Optional desired elements + -> [a] + -- ^ Required desired elements + -> m [a] + -- ^ All the required elements and as many optional elements as possible +partitionOptReqIO type' available optional required = liftIO $ do + let (optMissing, exts) = partitionOptReq available optional required + for_ optMissing + $ \o -> sayErr $ "Missing optional " <> type' <> ": " <> show o + case exts of + Left reqMissing -> do + for_ reqMissing + $ \r -> sayErr $ "Missing required " <> type' <> ": " <> show r + noSuchThing $ "Don't have all required " <> type' <> "s" + Right xs -> pure xs + +---------------------------------------------------------------- +-- * Bit utils +---------------------------------------------------------------- + +-- | Show valies as a union of their individual bits +-- +-- >>> showBits @Int 5 +-- "1 .|. 4" +-- +-- >>> showBits @Int 0 +-- "zeroBits" +-- +-- >>> import Vulkan.Core10.Enums.QueueFlagBits +-- >>> showBits (QUEUE_COMPUTE_BIT .|. QUEUE_GRAPHICS_BIT) +-- "QUEUE_GRAPHICS_BIT .|. QUEUE_COMPUTE_BIT" +showBits :: forall a . (Show a, FiniteBits a) => a -> String +showBits a = if a == zeroBits + then "zeroBits" + else intercalate " .|. " $ fmap show (setBits a) + where + setBits :: a -> [a] + setBits a = + [ b + | -- lol, is this really necessary + p <- [countTrailingZeros a .. finiteBitSize a - countLeadingZeros a - 1] + , let b = bit p + , a .&&. b + ] + +-- | Check if the intersection of bits is non-zero +(.&&.) :: Bits a => a -> a -> Bool +x .&&. y = (x .&. y) /= zeroBits + +---------------------------------------------------------------- +-- Internal utils +---------------------------------------------------------------- + +noSuchThing :: String -> IO a +noSuchThing message = + throwIO $ IOError Nothing NoSuchThing "" message Nothing Nothing + +sayErr :: MonadIO m => String -> m () +sayErr = liftIO . hPutStrLn stderr diff --git a/src/Vulkan/Utils/QueueAssignment.hs b/src/Vulkan/Utils/QueueAssignment.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/QueueAssignment.hs @@ -0,0 +1,282 @@ +module Vulkan.Utils.QueueAssignment + ( assignQueues + , QueueSpec(..) + , QueueFamilyIndex(..) + , QueueIndex(..) + -- * Queue Family Predicates + , isComputeQueueFamily + , isGraphicsQueueFamily + , isTransferQueueFamily + , isTransferOnlyQueueFamily + , isPresentQueue + ) where + +import Control.Applicative +import Control.Category ( (>>>) ) +import Control.Monad ( filterM ) +import Control.Monad.IO.Class +import Control.Monad.Trans.Class ( MonadTrans(lift) ) +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.State.Strict + ( evalState + , evalStateT + , get + , put + ) +import Data.Bits +import Data.Foldable +import Data.Functor ( (<&>) ) +import Data.Traversable +import qualified Data.Vector as V +import Data.Vector ( Vector ) +import Data.Word +import GHC.Stack ( HasCallStack ) +import Vulkan.Core10 +import Vulkan.Extensions.VK_KHR_surface + ( SurfaceKHR + , getPhysicalDeviceSurfaceSupportKHR + ) +import Vulkan.Utils.Misc +import Vulkan.Zero + +---------------------------------------------------------------- +-- Device Queue creation +---------------------------------------------------------------- + +-- | Requirements for a 'Queue' to be assigned a family by 'assignQueues'. +-- +-- To assign to a specific queue family index @f@: +-- +-- @ +-- queueSpecFamilyPredicate = \i _ -> i == f +-- @ +-- +-- To assign to any queue family which supports compute operations: +-- +-- @ +-- let isComputeQueue q = QUEUE_COMPUTE_BIT .&&. queueFlags q +-- in QueueSpec priority (\_index q -> pure (isComputeQueue q)) +-- @ +data QueueSpec m = QueueSpec + { queueSpecQueuePriority :: Float + , queueSpecFamilyPredicate + :: QueueFamilyIndex -> QueueFamilyProperties -> m Bool + } + +newtype QueueFamilyIndex = QueueFamilyIndex { unQueueFamilyIndex :: Word32 } + deriving (Eq, Ord, Enum, Show) + +newtype QueueIndex = QueueIndex { unQueueIndex :: Word32 } + deriving (Eq, Ord, Enum, Show) + +-- | Given a 'PhysicalDevice' and a set of requirements for queues, calculate an +-- assignment of queues to queue families and return information with which to +-- create a 'Device' and also a function to extract the requested 'Queue's from +-- the device. +-- +-- You may want to create a custom type with a 'Traversable' instance to store +-- your queues like: +-- +-- @ +-- data MyQueues a = MyQueues +-- { computeQueue :: a +-- , graphicsAndPresentQueue :: a +-- , transferQueue :: a +-- } +-- +-- myQueueSpecs :: MyQueues QueueSpec +-- myQueueSpecs = MyQueues +-- { computeQueue = QueueSpec 0.5 isComputeQueueFamily +-- , graphicsAndPresentQueue = QueueSpec 1 isPresentQueueFamily +-- , transferQueue = QueueSpec 1 isTransferOnlyQueueFamily +-- } +-- @ +-- +-- Note, this doesn't permit differentiating queue family assignment based on +-- whether or not the queue is protected. +assignQueues + :: forall f m n + . (Traversable f, MonadIO m, MonadIO n) + => PhysicalDevice + -> f (QueueSpec m) + -- ^ A set of requirements for 'Queue's to be created + -> m + ( Maybe + (Vector (DeviceQueueCreateInfo '[]), Device -> n (f Queue)) + ) + -- ^ + -- - A set of 'DeviceQueueCreateInfo's to pass to 'createDevice' + -- - A function to extract the requested 'Queue's from the 'Device' created + -- with the 'DeviceQueueCreateInfo's + -- + -- 'Nothing' if it wasn't possible to satisfy all the 'QueueSpec's +assignQueues phys specs = runMaybeT $ do + queueFamilyProperties <- + zip [QueueFamilyIndex 0 ..] + . V.toList + <$> getPhysicalDeviceQueueFamilyProperties phys + + -- For each QueueSpec find the list of applicable families + specsWithFamilies <- for specs $ \spec -> do + families <- filterM (lift . uncurry (queueSpecFamilyPredicate spec)) + queueFamilyProperties + pure (spec, fst <$> families) + + let -- Get the number of available queues for each family + familiesWithCapacities :: [(QueueFamilyIndex, Word32)] + familiesWithCapacities = + [ (i, queueCount) + | (i, QueueFamilyProperties {..}) <- queueFamilyProperties + ] + + -- Assign each QueueSpec to a queue family + specsWithFamily :: f (QueueSpec m, QueueFamilyIndex) <- headMay + (assign + familiesWithCapacities + (specsWithFamilies <&> \(spec, indices) index -> + if index `elem` indices then Just (spec, index) else Nothing + ) + ) + + let maxFamilyIndex :: Maybe QueueFamilyIndex + maxFamilyIndex = maximumMay (snd <$> toList specsWithFamily) + + -- Assign each QueueSpec an index within its queue family + specsWithQueueIndex :: f (QueueSpec m, QueueFamilyIndex, QueueIndex) + specsWithQueueIndex = + flip evalState (repeat (QueueIndex 0)) + $ for specsWithFamily + $ \(spec, familyIndex) -> do + indices <- get + let (index, indices') = + incrementAt (unQueueFamilyIndex familyIndex) indices + put indices' + pure (spec, familyIndex, index) + + -- Gather the priorities for each queue in each queue family + queuePriorities :: [[Float]] + queuePriorities = foldr + (\(QueueSpec {..}, QueueFamilyIndex i) ps -> + prependAt i queueSpecQueuePriority ps + ) + (replicate + (maybe 0 (fromIntegral . unQueueFamilyIndex . succ) maxFamilyIndex) + [] + ) + specsWithFamily + + -- Make 'DeviceQueueCreateInfo's for the required queue families and + -- priorities. + queueCreateInfos :: Vector (DeviceQueueCreateInfo '[]) + queueCreateInfos = V.fromList + [ zero { queueFamilyIndex = familyIndex + , queuePriorities = V.fromList ps + } + | (familyIndex, ps) <- zip [0 ..] queuePriorities + , not (null ps) + ] + + -- Get + extractQueues :: Device -> n (f Queue) + extractQueues dev = + for specsWithQueueIndex + $ \(_, QueueFamilyIndex familyIndex, QueueIndex index) -> + getDeviceQueue dev familyIndex index + + pure (queueCreateInfos, extractQueues) + +---------------------------------------------------------------- +-- Queue Predicates +---------------------------------------------------------------- + +isComputeQueueFamily :: QueueFamilyProperties -> Bool +isComputeQueueFamily q = QUEUE_COMPUTE_BIT .&&. queueFlags q + +isGraphicsQueueFamily :: QueueFamilyProperties -> Bool +isGraphicsQueueFamily q = QUEUE_GRAPHICS_BIT .&&. queueFlags q + +isTransferQueueFamily :: QueueFamilyProperties -> Bool +isTransferQueueFamily q = QUEUE_TRANSFER_BIT .&&. queueFlags q + +-- | Does this queue have 'QUEUE_TRANSFER_BIT' set and not 'QUEUE_COMPUTE_BIT' +-- or 'QUEUE_GRAPHICS_BIT' +isTransferOnlyQueueFamily :: QueueFamilyProperties -> Bool +isTransferOnlyQueueFamily q = + ( queueFlags q + .&. (QUEUE_TRANSFER_BIT .|. QUEUE_GRAPHICS_BIT .|. QUEUE_COMPUTE_BIT) + ) + == QUEUE_TRANSFER_BIT + +-- | Can this queue family present to this surface on this device +isPresentQueue + :: MonadIO m => PhysicalDevice -> SurfaceKHR -> QueueFamilyIndex -> m Bool +isPresentQueue phys surf (QueueFamilyIndex i) = + getPhysicalDeviceSurfaceSupportKHR phys i surf + +---------------------------------------------------------------- +-- Helpers +---------------------------------------------------------------- + +-- | Find all possible valid assignments for elements of a 'Traversable' with +-- some limited resources. +-- +-- >>> assign @[] @_ @() [("a", 1)] [] +-- [[]] +-- +-- >>> assign @[] [("hi", 1), ("foo", 3)] [Just, Just . reverse, Just . take 1 ] +-- [["hi","oof","f"],["foo","ih","f"],["foo","oof","h"],["foo","oof","f"]] +-- +-- >>> assign @[] [("a", 1), ("b", 2)] [\case {"a" -> Just 1; "b" -> Just 2; _ -> Nothing}, \case {"b" -> Just 3; _ -> Nothing}, \case {"a" -> Just 4; _ -> Nothing}] +-- [[2,3,4]] +assign + :: forall f a b + . Traversable f + => [(a, Word32)] + -- ^ How many of each 'a' are available + -> f (a -> Maybe b) + -- ^ Which 'a's can each element use + -> [f b] + -- ^ A list of assignments, each element in this list has the length of the + -- requirements list +assign capacities = flip evalStateT capacities . traverse + (\p -> do + cs <- get + (choice, cs') <- lift (select p cs) + put cs' + pure choice + ) + +-- | Select an element from the list according to some predicate, and return +-- that element along with the decremented list. +select :: (a -> Maybe b) -> [(a, Word32)] -> [(b, [(a, Word32)])] +select p = \case + [] -> [] + x : xs -> + let hit b = (b, if snd x == 1 then xs else (pred <$> x) : xs) + miss = do + (selected, xs') <- select p xs + pure (selected, x : xs') + in if snd x == 0 + then miss + else case p (fst x) of + Nothing -> miss + Just b -> hit b : miss + +headMay :: Alternative f => [a] -> f a +headMay = \case + [] -> empty + x : _ -> pure x + +maximumMay :: (Foldable f, Ord a) => f a -> Maybe a +maximumMay f = if null f then Nothing else Just (maximum f) + +incrementAt :: (HasCallStack, Enum a) => Word32 -> [a] -> (a, [a]) +incrementAt index = modAt index succ + +prependAt :: HasCallStack => Word32 -> a -> [[a]] -> [[a]] +prependAt index p = snd . modAt index (p :) + +modAt :: HasCallStack => Word32 -> (a -> a) -> [a] -> (a, [a]) +modAt index f = splitAt (fromIntegral index) >>> \case + (_ , [] ) -> error "modAt, out of bounds" + (xs, y : ys) -> (y, xs <> (f y : ys)) diff --git a/src/Vulkan/Utils/ShaderQQ.hs b/src/Vulkan/Utils/ShaderQQ.hs --- a/src/Vulkan/Utils/ShaderQQ.hs +++ b/src/Vulkan/Utils/ShaderQQ.hs @@ -114,6 +114,8 @@ shaderQQ :: String -> QuasiQuoter shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ stage } +-- * Utilities + -- | Compile a glsl shader to spir-v using glslangValidator. -- -- Messages are converted to GHC warnings or errors depending on compilation success. diff --git a/vulkan-utils.cabal b/vulkan-utils.cabal --- a/vulkan-utils.cabal +++ b/vulkan-utils.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 6d99c3af4fa07ab496a943502da39d9e6a6a8d08636c91bcee01195c4a2149d3 +-- hash: 2b51403e73e2f406342411ce5b6dd2e2f8db703ba97dd8c135df3d0e3a9b51bc name: vulkan-utils -version: 0.1.3 +version: 0.2 synopsis: Utils for the vulkan package category: Graphics homepage: https://github.com/expipiplus1/vulkan#readme @@ -36,13 +36,16 @@ exposed-modules: Vulkan.Utils.Debug Vulkan.Utils.FromGL + Vulkan.Utils.Initialization + Vulkan.Utils.Misc + Vulkan.Utils.QueueAssignment Vulkan.Utils.ShaderQQ Vulkan.Utils.ShaderQQ.Interpolate other-modules: - Paths_vulkan_utils + hs-source-dirs: src - default-extensions: AllowAmbiguousTypes CPP DataKinds DefaultSignatures DeriveAnyClass DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MagicHash NoMonomorphismRestriction OverloadedStrings PartialTypeSignatures PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards RoleAnnotations ScopedTypeVariables StandaloneDeriving Strict TypeApplications TypeFamilyDependencies TypeOperators TypeSynonymInstances UndecidableInstances ViewPatterns + default-extensions: DataKinds DefaultSignatures DeriveAnyClass DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MagicHash NoMonomorphismRestriction OverloadedStrings PartialTypeSignatures PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards RoleAnnotations ScopedTypeVariables StandaloneDeriving Strict TupleSections TypeApplications TypeFamilyDependencies TypeOperators TypeSynonymInstances ViewPatterns c-sources: cbits/DebugCallback.c build-depends: @@ -51,10 +54,14 @@ , extra , file-embed , filepath + , resourcet >=1.2.4 , template-haskell , temporary + , text + , transformers , typed-process - , vulkan + , vector + , vulkan >=3.6.14 default-language: Haskell2010 test-suite doctests @@ -64,7 +71,7 @@ hs-source-dirs: test/doctest - default-extensions: AllowAmbiguousTypes CPP DataKinds DefaultSignatures DeriveAnyClass DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MagicHash NoMonomorphismRestriction OverloadedStrings PartialTypeSignatures PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards RoleAnnotations ScopedTypeVariables StandaloneDeriving Strict TypeApplications TypeFamilyDependencies TypeOperators TypeSynonymInstances UndecidableInstances ViewPatterns + default-extensions: DataKinds DefaultSignatures DeriveAnyClass DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MagicHash NoMonomorphismRestriction OverloadedStrings PartialTypeSignatures PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards RoleAnnotations ScopedTypeVariables StandaloneDeriving Strict TupleSections TypeApplications TypeFamilyDependencies TypeOperators TypeSynonymInstances ViewPatterns build-depends: base , doctest