vulkan-utils 0.3 → 0.4
raw patch · 9 files changed
+1127/−209 lines, 9 filesdep +containersdep +dependent-mapdep +dependent-sumdep ~vulkan
Dependencies added: containers, dependent-map, dependent-sum, unordered-containers
Dependency ranges changed: vulkan
Files
- changelog.md +9/−0
- package.yaml +13/−3
- src/Vulkan/Utils/Initialization.hs +106/−139
- src/Vulkan/Utils/Internal.hs +36/−0
- src/Vulkan/Utils/Misc.hs +15/−30
- src/Vulkan/Utils/Requirements.hs +624/−0
- src/Vulkan/Utils/Requirements/TH.hs +288/−0
- src/Vulkan/Utils/ShaderQQ.hs +23/−30
- vulkan-utils.cabal +13/−7
changelog.md view
@@ -2,6 +2,15 @@ ## WIP +## [0.4] - 2020-11-30++- Add `Vulkan.Utils.Requirements`, a module with several helpers for the+ `Requirement` types found in `Vulkan.Requirement`+- Change the creation helpers in `Vulkan.Utils.Initialization` to use the new+ `Requirement` types.+- Add QuasiQuoters for creating device requirements in `Vulkan.Utils.Requirements.TH`+- Allow selecting target environment in `compileShader`+ ## [0.3] - 2020-11-24 - Change type of pickPhysicalDevice to return Nothing instead of throwing
package.yaml view
@@ -1,5 +1,5 @@ name: vulkan-utils-version: "0.3"+version: "0.4" synopsis: Utils for the vulkan package category: Graphics maintainer: Joe Hermaszewski <live.long.and.prosper@monoid.al>@@ -13,10 +13,14 @@ library: source-dirs: src c-sources: cbits/DebugCallback.c- other-modules: ""+ other-modules:+ - Vulkan.Utils.Internal dependencies: - base <5 - bytestring+ - containers+ - dependent-map+ - dependent-sum - extra - file-embed - filepath@@ -26,8 +30,9 @@ - text - transformers - typed-process+ - unordered-containers - vector- - vulkan >= 3.6.14 && < 3.8+ - vulkan >= 3.6.14 && < 3.9 tests: doctests:@@ -46,7 +51,11 @@ - Cabal - cabal-doctest >= 1 && <1.1 +ghc-options:+ - -Wall+ default-extensions:+ - ConstraintKinds - DataKinds - DefaultSignatures - DeriveAnyClass@@ -62,6 +71,7 @@ - InstanceSigs - LambdaCase - MagicHash+ - NamedFieldPuns - NoMonomorphismRestriction - OverloadedStrings - PartialTypeSignatures
src/Vulkan/Utils/Initialization.hs view
@@ -1,141 +1,144 @@ {-# LANGUAGE OverloadedLists #-} module Vulkan.Utils.Initialization- ( createDebugInstanceWithExtensions- , createInstanceWithExtensions- , pickPhysicalDevice+ ( -- * Instance creation+ createInstanceFromRequirements+ , createDebugInstanceFromRequirements+ -- * Device creation+ , createDeviceFromRequirements+ , -- * Physical device selection+ pickPhysicalDevice , physicalDeviceName- , createDeviceWithExtensions ) where 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 Vulkan.CStruct.Extends import Vulkan.Core10 import Vulkan.Extensions.VK_EXT_debug_utils import Vulkan.Extensions.VK_EXT_validation_features+import Vulkan.Requirement import Vulkan.Utils.Debug-import Vulkan.Utils.Misc+import Vulkan.Utils.Internal+import Vulkan.Utils.Requirements import Vulkan.Zero ------------------------------------------------------------------- * Instance Creation+-- Instance ---------------------------------------------------------------- --- | Like 'createInstanceWithExtensions' except it will create a debug utils+-- | Like 'createInstanceFromRequirements' 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+createDebugInstanceFromRequirements+ :: forall m es+ . (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es)+ => [InstanceRequirement]+ -- ^ Required+ -> [InstanceRequirement]+ -- ^ Optional -> 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+createDebugInstanceFromRequirements required optional baseCreateInfo = 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 = baseCreateInfo+ { next = debugMessengerCreateInfo :& validationFeatures :& next+ (baseCreateInfo :: InstanceCreateInfo es)+ }+ additionalRequirements =+ [ RequireInstanceExtension+ { instanceExtensionLayerName = Nothing+ , instanceExtensionName = EXT_DEBUG_UTILS_EXTENSION_NAME+ , instanceExtensionMinVersion = minBound+ }+ ]+ additionalOptionalRequirements =+ [ RequireInstanceLayer+ { instanceLayerName = "VK_LAYER_KHRONOS_validation"+ , instanceLayerMinVersion = minBound }- validationFeatures = ValidationFeaturesEXT- [VALIDATION_FEATURE_ENABLE_BEST_PRACTICES_EXT]- []- instanceCreateInfo'- :: InstanceCreateInfo- (DebugUtilsMessengerCreateInfoEXT : ValidationFeaturesEXT : es)- instanceCreateInfo' = instanceCreateInfo- { next = debugMessengerCreateInfo :& validationFeatures :& next- (instanceCreateInfo :: InstanceCreateInfo es)+ , RequireInstanceExtension+ { instanceExtensionLayerName = Just "VK_LAYER_KHRONOS_validation"+ , instanceExtensionName = EXT_VALIDATION_FEATURES_EXTENSION_NAME+ , instanceExtensionMinVersion = minBound }- 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+ ]+ inst <- createInstanceFromRequirements+ (additionalRequirements <> toList required)+ (additionalOptionalRequirements <> toList optional)+ 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'.+-- | Create an 'Instance from some requirements. ----- 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+-- Will throw an 'IOError in the case of unsatisfied non-optional requirements.+-- Unsatisfied requirements will be listed on stderr.+createInstanceFromRequirements+ :: (MonadResource m, Extendss InstanceCreateInfo es, PokeChain es)+ => [InstanceRequirement]+ -- ^ Required+ -> [InstanceRequirement]+ -- ^ Optional -> 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+createInstanceFromRequirements required optional baseCreateInfo = do+ (mbICI, rrs, ors) <- checkInstanceRequirements required+ optional+ baseCreateInfo+ traverse_ sayErr (requirementReport rrs ors)+ case mbICI of+ Nothing -> liftIO $ unsatisfiedConstraints "Failed to create instance"+ Just ici -> snd <$> withInstance ici Nothing allocate - -- 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+----------------------------------------------------------------+-- * Device creation+---------------------------------------------------------------- - 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+-- | Create a 'Device' from some requirements.+--+-- Will throw an 'IOError in the case of unsatisfied non-optional requirements.+-- Unsatisfied requirements will be listed on stderr.+createDeviceFromRequirements+ :: forall m+ . MonadResource m+ => [DeviceRequirement]+ -- ^ Required+ -> [DeviceRequirement]+ -- ^ Optional+ -> PhysicalDevice+ -> DeviceCreateInfo '[]+ -> m Device+createDeviceFromRequirements required optional phys baseCreateInfo = do+ (mbDCI, rrs, ors) <- checkDeviceRequirements required+ optional+ phys+ baseCreateInfo+ traverse_ sayErr (requirementReport rrs ors)+ case mbDCI of+ Nothing -> liftIO $ unsatisfiedConstraints "Failed to create instance"+ Just (SomeStruct dci) -> snd <$> withDevice phys dci Nothing allocate ---------------------------------------------------------------- -- * Physical device selection@@ -153,6 +156,9 @@ -- 'Vulkan.Utils.QueueAssignment.assignQueues' to find your desired queues in -- the suitability function. --+-- Pehaps also use the functionality in 'Vulkan.Utils.Requirements' and return+-- the 'DeviceCreateInfo' too.+-- -- If no devices are deemed suitable then a 'NoSuchThing' 'IOError' is thrown. pickPhysicalDevice :: (MonadIO m, Ord b)@@ -175,50 +181,11 @@ 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 ---------------------------------------------------------------- maximumByMay :: Foldable t => (a -> a -> Ordering) -> t a -> Maybe a maximumByMay f xs = if null xs then Nothing else Just (maximumBy f xs)+
+ src/Vulkan/Utils/Internal.hs view
@@ -0,0 +1,36 @@+module Vulkan.Utils.Internal where++import Control.Monad.IO.Class+import GHC.IO ( throwIO )+import GHC.IO.Exception ( IOErrorType(..)+ , IOException(..)+ )+import System.IO ( hPutStrLn+ , stderr+ )+import Language.Haskell.TH.Quote++----------------------------------------------------------------+-- Internal utils+----------------------------------------------------------------++unsatisfiedConstraints :: String -> IO a+unsatisfiedConstraints message =+ throwIO $ IOError Nothing UnsatisfiedConstraints "" message Nothing Nothing++noSuchThing :: String -> IO a+noSuchThing message =+ throwIO $ IOError Nothing NoSuchThing "" message Nothing Nothing++sayErr :: MonadIO m => String -> m ()+sayErr = liftIO . hPutStrLn stderr++badQQ :: String -> QuasiQuoter+badQQ name = QuasiQuoter (bad "expression")+ (bad "pattern")+ (bad "type")+ (bad "declaration")+ where+ bad :: String -> a+ bad context =+ error $ "Can't use " <> name <> " quote in a " <> context <> " context"
src/Vulkan/Utils/Misc.hs view
@@ -13,13 +13,7 @@ import Data.List ( intercalate , partition )-import GHC.IO ( throwIO )-import GHC.IO.Exception ( IOErrorType(NoSuchThing)- , IOException(..)- )-import System.IO ( hPutStrLn- , stderr- )+import Vulkan.Utils.Internal -- | From a list of things, take all the required things and as many optional -- things as possible.@@ -59,8 +53,9 @@ -- ^ Optional desired elements -> [a] -- ^ Required desired elements- -> m [a]- -- ^ All the required elements and as many optional elements as possible+ -> m ([a],[a])+ -- ^ All the required elements and as many optional elements as possible,+ -- as well as the missing optional elements. partitionOptReqIO type' available optional required = liftIO $ do let (optMissing, exts) = partitionOptReq available optional required for_ optMissing@@ -70,7 +65,7 @@ for_ reqMissing $ \r -> sayErr $ "Missing required " <> type' <> ": " <> show r noSuchThing $ "Don't have all required " <> type' <> "s"- Right xs -> pure xs+ Right xs -> pure (xs, optMissing) ---------------------------------------------------------------- -- * Bit utils@@ -91,27 +86,17 @@ 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- ] +-- | The list of bits which are set+setBits :: FiniteBits a => 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
+ src/Vulkan/Utils/Requirements.hs view
@@ -0,0 +1,624 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE UndecidableInstances #-}++module Vulkan.Utils.Requirements+ ( -- * Instance requirements+ checkInstanceRequirements+ , -- * Device requirements+ checkDeviceRequirements+ , -- * Results+ RequirementResult(..)+ , Unsatisfied(..)+ , requirementReport+ , prettyRequirementResult+ ) where++import Control.Arrow ( Arrow((***)) )+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.State+import Data.Bifunctor+import Data.ByteString ( ByteString )+import qualified Data.Dependent.Map as DMap+import Data.Dependent.Map ( DMap )+import Data.Dependent.Sum ( DSum((:=>)) )+import Data.Foldable+import Data.Functor.Product ( Product(..) )+import qualified Data.HashMap.Strict as Map+import Data.Kind ( Type )+import Data.List.Extra ( nubOrd )+import Data.Proxy+import Data.Semigroup ( Endo(..) )+import Data.Traversable+import Data.Typeable ( eqT )+import qualified Data.Vector as V+import Data.Vector ( Vector )+import Data.Word+import Foreign.Ptr ( FunPtr+ , Ptr+ , nullFunPtr+ )+import GHC.Base ( Proxy# )+import GHC.Exts ( proxy# )+import Type.Reflection+import Vulkan.CStruct ( FromCStruct+ , ToCStruct+ )+import Vulkan.CStruct.Extends+import Vulkan.Core10+import Vulkan.Core11.DeviceInitialization+import Vulkan.Core11.Promoted_From_VK_KHR_get_physical_device_properties2+import Vulkan.Dynamic ( InstanceCmds+ ( pVkGetPhysicalDeviceFeatures2+ , pVkGetPhysicalDeviceProperties2+ )+ )+import Vulkan.NamedType+import Vulkan.Requirement+import Vulkan.Version+import Vulkan.Zero ( Zero(..) )+import Data.List (intercalate)++----------------------------------------------------------------+-- * Instance Creation+----------------------------------------------------------------++checkInstanceRequirements+ :: forall m o r es+ . (MonadIO m, Traversable r, Traversable o)+ => r InstanceRequirement+ -- ^ Required requests+ -> o InstanceRequirement+ -- ^ Optional requests+ -> InstanceCreateInfo es+ -- ^ An 'InstanceCreateInfo', this will be returned appropriately modified by+ -- the requirements+ -> m+ ( Maybe (InstanceCreateInfo es)+ , r RequirementResult+ , o RequirementResult+ )+checkInstanceRequirements required optional baseCreateInfo = do+ let requiredList = toList required+ allAsList = requiredList <> toList optional+ foundVersion <- enumerateInstanceVersion+ (_, layerProps) <- enumerateInstanceLayerProperties+ lookupExtension <- getLookupExtension+ Nothing+ [ instanceExtensionLayerName+ | RequireInstanceExtension { instanceExtensionLayerName } <- allAsList+ ]++ (r, continue) <- flip runStateT True $ for required $ \r ->+ case checkInstanceRequest foundVersion layerProps lookupExtension r of+ res -> do+ unless (res == Satisfied) (put False)+ pure res++ (o, goodOptions) <- flip runStateT mempty $ for optional $ \o ->+ case checkInstanceRequest foundVersion layerProps lookupExtension o of+ res -> do+ when (res == Satisfied) $ modify (o :)+ pure res++ let ici = do+ guard continue+ pure $ makeInstanceCreateInfo (requiredList <> goodOptions)+ baseCreateInfo+ pure (ici, r, o)++-- | Insert the settings of the requirements in to the provided instance create+-- info+makeInstanceCreateInfo+ :: forall es+ . [InstanceRequirement]+ -> InstanceCreateInfo es+ -> InstanceCreateInfo es+makeInstanceCreateInfo reqs baseCreateInfo =+ let+ layers = [ instanceLayerName | RequireInstanceLayer {..} <- reqs ]+ extensions =+ [ instanceExtensionName | RequireInstanceExtension {..} <- reqs ]+ in+ baseCreateInfo+ { enabledLayerNames =+ enabledLayerNames (baseCreateInfo :: InstanceCreateInfo es)+ <> V.fromList layers+ , enabledExtensionNames =+ enabledExtensionNames (baseCreateInfo :: InstanceCreateInfo es)+ <> V.fromList extensions+ }++checkInstanceRequest+ :: ("apiVersion" ::: Word32)+ -> ("properties" ::: Vector LayerProperties)+ -> ( ("layerName" ::: Maybe ByteString)+ -> ByteString+ -> Maybe ExtensionProperties+ )+ -> InstanceRequirement+ -> RequirementResult+checkInstanceRequest foundVersion layerProps lookupExtension = \case+ RequireInstanceVersion minVersion -> if foundVersion >= minVersion+ then Satisfied+ else UnsatisfiedInstanceVersion (Unsatisfied minVersion foundVersion)++ RequireInstanceLayer { instanceLayerName, instanceLayerMinVersion }+ | Just props <- find ((== instanceLayerName) . layerName) layerProps+ , foundLayerVersion <- implementationVersion props+ -> if foundVersion >= instanceLayerMinVersion+ then Satisfied+ else UnsatisfiedLayerVersion+ instanceLayerName+ (Unsatisfied instanceLayerMinVersion foundLayerVersion)+ | otherwise+ -> MissingLayer instanceLayerName++ RequireInstanceExtension { instanceExtensionLayerName, instanceExtensionName, instanceExtensionMinVersion }+ | Just eProps <- lookupExtension instanceExtensionLayerName+ instanceExtensionName+ , specVersion (eProps :: ExtensionProperties) >= instanceExtensionMinVersion+ -> Satisfied+ | otherwise+ -> UnsatisfiedInstanceExtension instanceExtensionName++----------------------------------------------------------------+-- Device+----------------------------------------------------------------++checkDeviceRequirements+ :: forall m o r+ . (MonadIO m, Traversable r, Traversable o)+ => r DeviceRequirement+ -- ^ Required requests+ -> o DeviceRequirement+ -- ^ Optional requests+ -> PhysicalDevice+ -> DeviceCreateInfo '[]+ -- ^ A deviceCreateInfo with no extensions. If you need elements in the+ -- struct chain you can add them later with+ -- 'Vulkan.CStruct.Extends.extendSomeStruct'+ -> m+ ( Maybe (SomeStruct DeviceCreateInfo)+ , r RequirementResult+ , o RequirementResult+ )+checkDeviceRequirements required optional phys baseCreateInfo = do+ let requiredList = toList required+ allAsList = requiredList <> toList optional++ --+ -- First collect the types and properties that we'll need to query using+ -- getPhysicalDeviceProperties2 and getPhysicalDeviceFeatures2+ --+ withDeviceFeatureStructs allAsList $ \(_ :: Proxy fs) ->+ withDevicePropertyStructs allAsList $ \(_ :: Proxy ps) -> do+ --+ -- Fetch everything+ --+ feats <- getPhysicalDeviceFeaturesMaybe @fs phys+ props <- getPhysicalDevicePropertiesMaybe @ps phys+ lookupExtension <- getLookupExtension+ (Just phys)+ [ deviceExtensionLayerName+ | RequireDeviceExtension { deviceExtensionLayerName } <- allAsList+ ]++ (r, continue) <- flip runStateT True $ for required $ \r ->+ case checkDeviceRequest feats props lookupExtension r of+ res -> do+ unless (res == Satisfied) (put False)+ pure res++ (o, goodOptions) <- flip runStateT mempty $ for optional $ \o ->+ case checkDeviceRequest feats props lookupExtension o of+ res -> do+ when (res == Satisfied) $ modify (o :)+ pure res++ --+ -- Now create the types for just the available features+ --+ let dci = do+ guard continue+ pure $ makeDeviceCreateInfo (requiredList <> goodOptions)+ baseCreateInfo+ pure (dci, r, o)++{-# ANN makeDeviceCreateInfo ("HLint: ignore Move guards forward" :: String) #-}+-- | Generate 'DeviceCreateInfo' from some requirements.+--+-- The returned struct chain will enable all required features and extensions.+makeDeviceCreateInfo+ :: [DeviceRequirement]+ -> DeviceCreateInfo '[]+ -> SomeStruct DeviceCreateInfo+makeDeviceCreateInfo allReqs baseCreateInfo =+ let+ featureSetters :: DMap TypeRep (Product (Has KnownFeatureStruct) Endo)+ featureSetters = DMap.fromListWithKey+ (\_ l r -> catProducts l r)+ [ typeRep :=> Pair Has (Endo enableFeature)+ | RequireDeviceFeature { enableFeature } <- allReqs+ ]++ makeZeroFeatureExts :: [Endo (SomeStruct DeviceCreateInfo)]+ makeZeroFeatureExts =+ [ Endo (extendSomeStruct s)+ | _ :=> Pair Has (f :: Endo s) <- DMap.toList featureSetters+ , ExtendedFeatureStruct <- pure $ sFeatureStruct @s+ , let s = appEndo f zero+ ]++ addBasicFeatures :: Endo (SomeStruct DeviceCreateInfo)+ addBasicFeatures =+ case DMap.lookup (typeRep @PhysicalDeviceFeatures) featureSetters of+ Nothing -> mempty+ Just (Pair _ s) -> Endo+ (extendSomeStruct+ ((zero :: PhysicalDeviceFeatures2 '[]) { features = appEndo s zero }+ )+ )++ extensionNames :: [ByteString]+ extensionNames =+ [ deviceExtensionName+ | RequireDeviceExtension { deviceExtensionName } <- allReqs+ ]++ newFeatures :: SomeStruct DeviceCreateInfo+ newFeatures = appEndo+ (fold (addBasicFeatures : makeZeroFeatureExts))+ (SomeStruct (baseCreateInfo :: DeviceCreateInfo '[])+ { enabledExtensionNames = V.fromList extensionNames+ }+ )+ in+ newFeatures++checkDeviceRequest+ :: forall fs ps+ . (KnownChain fs, KnownChain ps)+ => Maybe (PhysicalDeviceFeatures2 fs)+ -> Maybe (PhysicalDeviceProperties2 ps)+ -> ( ("layerName" ::: Maybe ByteString)+ -> ("extensionName" ::: ByteString)+ -> Maybe ExtensionProperties+ )+ -- ^ Lookup an extension+ -> DeviceRequirement+ -- ^ The requirement to test+ -> RequirementResult+ -- ^ The result+checkDeviceRequest mbFeats mbProps lookupExtension = \case+ RequireDeviceVersion minVersion+ | Just props <- mbProps+ , foundVersion <- apiVersion+ (properties (props :: PhysicalDeviceProperties2 ps) :: PhysicalDeviceProperties+ )+ -> if foundVersion >= minVersion+ then Satisfied+ else UnsatisfiedDeviceVersion (Unsatisfied minVersion foundVersion)+ | otherwise+ -> UnattemptedProperties "apiVersion"++ RequireDeviceFeature { featureName, checkFeature }+ | Just feats <- mbFeats -> case getFeatureStruct feats of+ Nothing ->+ error "Impossible: didn't find requested feature in struct chain"+ Just s ->+ if checkFeature s then Satisfied else UnsatisfiedFeature featureName+ | otherwise -> UnattemptedFeatures featureName++ RequireDeviceProperty { propertyName, checkProperty }+ | Just props <- mbProps -> case getPropertyStruct props of+ Nothing ->+ error "Impossible: didn't find requested property in struct chain"+ Just s ->+ if checkProperty s then Satisfied else UnsatisfiedProperty propertyName+ | otherwise -> UnattemptedProperties propertyName++ RequireDeviceExtension { deviceExtensionLayerName, deviceExtensionName, deviceExtensionMinVersion }+ | Just eProps <- lookupExtension deviceExtensionLayerName+ deviceExtensionName+ , specVersion (eProps :: ExtensionProperties) >= deviceExtensionMinVersion+ -> Satisfied+ | otherwise+ -> UnsatisfiedDeviceExtension deviceExtensionName+++----------------------------------------------------------------+-- Results+----------------------------------------------------------------++-- TODO, better version reporting for extensions+-- TODO, better reporting for properties+data RequirementResult+ = Satisfied+ -- ^ All the requirements were met+ | UnattemptedProperties ByteString+ -- ^ Didn't attempt this check because it required+ -- getPhysicalDeviceProperties2 which wasn't loaded+ | UnattemptedFeatures ByteString+ -- ^ Didn't attempt this check because it required+ -- getPhysicalDeviceFeatures2 which wasn't loaded+ | MissingLayer ByteString+ -- ^ A Layer was not found+ | UnsatisfiedDeviceVersion (Unsatisfied Word32)+ -- ^ A device version didn't meet the minimum requested+ | UnsatisfiedInstanceVersion (Unsatisfied Word32)+ -- ^ The instance version didn't meet the minimum requested+ | UnsatisfiedLayerVersion ByteString (Unsatisfied Word32)+ -- ^ A layer version didn't meet the minimum requested+ | UnsatisfiedFeature ByteString+ -- ^ A feature was missing+ | UnsatisfiedProperty ByteString+ -- ^ A propery was not an appropriate value+ | UnsatisfiedDeviceExtension ByteString+ -- ^ A device extension was missing+ | UnsatisfiedInstanceExtension ByteString+ -- ^ An instance extension was missing+ deriving (Eq, Ord)++data Unsatisfied a = Unsatisfied+ { unsatisfiedMinimum :: a+ -- ^ The minimum value to be accepted+ , unsatisfiedActual :: a+ -- ^ The value we got, less than 'unsatisfiedMinumum'+ }+ deriving (Eq, Ord)++-- | Generate a string describing which requirements were not met, if+-- everything was satisfied return 'Nothing'.+requirementReport+ :: (Foldable r, Foldable o)+ => r RequirementResult+ -> o RequirementResult+ -> Maybe String+requirementReport required optional =+ let pList xs =+ nubOrd [ prettyRequirementResult r | r <- toList xs, r /= Satisfied ]+ reqStrings = pList required+ optStrings = pList optional+ withHeader s = \case+ [] -> []+ xs -> (s <> " requirements not met:") : ((" " <>) <$> xs)+ reportLines =+ withHeader "Required" reqStrings <> withHeader "Optional" optStrings+ in if null reportLines then Nothing else Just $ unlines reportLines++prettyRequirementResult :: RequirementResult -> String+prettyRequirementResult = \case+ Satisfied -> "Satisfied"+ UnattemptedProperties n ->+ "Did not attempt to check "+ <> show n+ <> " because the 'getPhysicalDeviceProperties' function was not loaded"+ UnattemptedFeatures n ->+ "Did not attempt to check "+ <> show n+ <> " because the 'getPhysicalDeviceFeatures' function was not loaded"+ MissingLayer n -> "Couldn't find layer: " <> show n+ UnsatisfiedInstanceVersion u -> "Unsatisfied Instance version: " <> p u+ UnsatisfiedDeviceVersion u -> "Unsatisfied Device version: " <> p u+ UnsatisfiedLayerVersion n u ->+ "Unsatisfied layer version for " <> show n <> ": " <> p u+ UnsatisfiedFeature n -> "Missing feature: " <> show n+ UnsatisfiedProperty n -> "Unsatisfied property: " <> show n+ UnsatisfiedInstanceExtension n -> "Couldn't find instance extension: " <> show n+ UnsatisfiedDeviceExtension n -> "Couldn't find device extension: " <> show n+ where p = prettyUnsatisfied showVersion++-- How I'm feeling after writing all this type level nonsense+prettyUnsatisfied :: (t -> String) -> Unsatisfied t -> String+prettyUnsatisfied s Unsatisfied {..} =+ "Wanted minimum of "+ <> s unsatisfiedMinimum+ <> ", got: "+ <> s unsatisfiedActual++----------------------------------------------------------------+-- Chain lenses+----------------------------------------------------------------++-- | Enough information to focus on any structure within a Vulkan structure chain.+class (PeekChain xs, PokeChain xs) => KnownChain (xs :: [Type]) where+ -- | If the given structure can be found within a chain, return a lens to it.+ -- Otherwise, return 'Nothing'.+ has :: forall a. Typeable a => Proxy# a -> Maybe (Chain xs -> a, (a -> a) -> (Chain xs -> Chain xs))+ -- | Is this chain empty?+ knownChainNull :: Maybe (xs :~: '[])++instance KnownChain '[] where+ has _ = Nothing+ knownChainNull = Just Refl++instance (Typeable x, ToCStruct x, FromCStruct x, KnownChain xs) => KnownChain (x ': xs) where+ has (px :: Proxy# a)+ | Just Refl <- eqT @a @x+ = Just (fst,first)+ | otherwise+ = ((. snd) *** (second .)) <$> has px+ knownChainNull = Nothing++getPropertyStruct+ :: forall s es+ . (Typeable s, KnownChain es)+ => PhysicalDeviceProperties2 es+ -> Maybe s+getPropertyStruct c = case eqT @PhysicalDeviceProperties @s of+ Just Refl -> Just (properties (c :: PhysicalDeviceProperties2 es))+ Nothing -> getStruct c++getFeatureStruct+ :: forall s es+ . (Typeable s, KnownChain es)+ => PhysicalDeviceFeatures2 es+ -> Maybe s+getFeatureStruct c = case eqT @PhysicalDeviceFeatures @s of+ Just Refl -> Just (features (c :: PhysicalDeviceFeatures2 es))+ Nothing -> getStruct c++getStruct+ :: forall s h es+ . (Typeable h, Typeable s, KnownChain es, Extensible h)+ => h es+ -> Maybe s+getStruct c = ($ getNext c) . fst <$> has (proxy# :: Proxy# s)++----------------------------------------------------------------+-- Helpers for 'Device' and 'Instance' extensions+----------------------------------------------------------------++-- | Make a lookup function for extensions in layers+getLookupExtension+ :: MonadIO m+ => Maybe PhysicalDevice+ -- ^ Pass 'Nothing' for 'Instance' extensions, pass a PhysicalDevice for+ -- device extensions.+ -> ["layerName" ::: Maybe ByteString]+ -> m+ ( ("layerName" ::: Maybe ByteString)+ -> ByteString+ -> Maybe ExtensionProperties+ )+getLookupExtension mbPhys extensionLayers = do+ let enumerate = maybe enumerateInstanceExtensionProperties+ enumerateDeviceExtensionProperties+ mbPhys+ extensions <- for (nubOrd extensionLayers) $ \layer -> do+ (_, props) <- enumerate layer+ pure (layer, props)+ let extensionMap = Map.fromListWith (<>) extensions+ pure $ \layer name ->+ let es = Map.lookupDefault mempty layer extensionMap+ in find ((== name) . extensionName) es++----------------------------------------------------------------+-- Helpers for extracting the type of chain used by a set of requirements+----------------------------------------------------------------++withDevicePropertyStructs+ :: forall a+ . [DeviceRequirement]+ -> ChainCont DevicePropertyChain a+ -> a+withDevicePropertyStructs = go @'[] []+ where+ go+ :: forall (fs :: [Type])+ . DevicePropertyChain fs+ => [SomeTypeRep]+ -> [DeviceRequirement]+ -> ChainCont DevicePropertyChain a+ -> a+ go seen reqs f = case reqs of+ -- We've been through all the reqs, call the continuation with the types+ [] -> f (Proxy @fs)+ -- This is a device property, add it to the list if we've not seen it before+ (RequireDeviceProperty _ (_ :: s -> Bool)) : rs+ | ExtendedPropertyStruct <- sPropertyStruct @s+ , sRep <- SomeTypeRep (typeRep @s)+ , sRep `notElem` seen+ -> go @(s:fs) (sRep : seen) rs f+ -- Otherwise skip+ _ : rs -> go @fs seen rs f++withDeviceFeatureStructs+ :: forall a+ . [DeviceRequirement]+ -> ChainCont DeviceFeatureChain a+ -> a+withDeviceFeatureStructs = go @'[] []+ where+ go+ :: forall (fs :: [Type])+ . DeviceFeatureChain fs+ => [SomeTypeRep]+ -> [DeviceRequirement]+ -> ChainCont DeviceFeatureChain a+ -> a+ go seen reqs f = case reqs of+ -- We've been through all the reqs, call the continuation with the types+ [] -> f (Proxy @fs)+ -- This is a device feature, add it to the list if we've not seen it before+ (RequireDeviceFeature _ _ (_ :: s -> s)) : rs+ | ExtendedFeatureStruct <- sFeatureStruct @s+ , sRep <- SomeTypeRep (typeRep @s)+ , sRep `notElem` seen+ -> go @(s:fs) (sRep : seen) rs f+ -- Otherwise skip+ _ : rs -> go @fs seen rs f++class (KnownChain es, Extendss PhysicalDeviceFeatures2 es, Show (Chain es)) => DeviceFeatureChain es where+instance (KnownChain es, Extendss PhysicalDeviceFeatures2 es, Show (Chain es)) => DeviceFeatureChain es where++class (KnownChain es, Extendss PhysicalDeviceProperties2 es) => DevicePropertyChain es where+instance (KnownChain es, Extendss PhysicalDeviceProperties2 es) => DevicePropertyChain es where++type ChainCont c a = forall (es :: [Type]) . (c es) => Proxy es -> a++----------------------------------------------------------------+-- Helpers for getting features and properties without using the extended+-- versions of the functions if possible.+----------------------------------------------------------------++getPhysicalDeviceFeaturesMaybe+ :: forall fs m+ . (MonadIO m, KnownChain fs, Extendss PhysicalDeviceFeatures2 fs)+ => PhysicalDevice+ -> m (Maybe (PhysicalDeviceFeatures2 fs))+getPhysicalDeviceFeaturesMaybe = getMaybe pVkGetPhysicalDeviceFeatures2+ (PhysicalDeviceFeatures2 ())+ getPhysicalDeviceFeatures+ getPhysicalDeviceFeatures2++getPhysicalDevicePropertiesMaybe+ :: forall fs m+ . (MonadIO m, KnownChain fs, Extendss PhysicalDeviceProperties2 fs)+ => PhysicalDevice+ -> m (Maybe (PhysicalDeviceProperties2 fs))+getPhysicalDevicePropertiesMaybe = getMaybe pVkGetPhysicalDeviceProperties2+ (PhysicalDeviceProperties2 ())+ getPhysicalDeviceProperties+ getPhysicalDeviceProperties2++getMaybe+ :: forall fs s1 s2 m+ . (MonadIO m, KnownChain fs, Extendss s2 fs)+ => ( InstanceCmds+ -> FunPtr (Ptr PhysicalDevice_T -> Ptr (SomeStruct s2) -> IO ())+ )+ -> (s1 -> s2 '[])+ -> (PhysicalDevice -> m s1)+ -> (PhysicalDevice -> m (s2 fs))+ -> PhysicalDevice+ -> m (Maybe (s2 fs))+getMaybe funPtr wrapper2 get1 get2 phys =+ let hasFunPtr = funPtr (instanceCmds (phys :: PhysicalDevice)) /= nullFunPtr+ in case knownChainNull @fs of+ Just Refl -> Just . wrapper2 <$> get1 phys+ Nothing -> if hasFunPtr then Just <$> get2 phys else pure Nothing++----------------------------------------------------------------+-- Utils+----------------------------------------------------------------++showVersion :: Word32 -> String+showVersion ver = intercalate "." [show ma, show mi, show pa]+ where MAKE_VERSION ma mi pa = ver++data Has c a where+ Has :: c a => Has c a++instance Semigroup (Has c a) where+ Has <> _ = Has++-- | There is no Semigroup instance for 'Product' in base+catProducts+ :: (Semigroup (f a), Semigroup (g a))+ => Product f g a+ -> Product f g a+ -> Product f g a+catProducts (Pair a1 b1) (Pair a2 b2) = Pair (a1 <> a2) (b1 <> b2)
+ src/Vulkan/Utils/Requirements/TH.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}++module Vulkan.Utils.Requirements.TH+ ( req+ , reqs+ ) where++import Control.Applicative+import Control.Category ( (>>>) )+import Control.Monad+import Data.Char+import Data.Foldable+import Data.List ( intercalate+ , isPrefixOf+ )+import Data.List.Extra ( nubOrd )+import Data.Maybe+import Data.String+import Data.Traversable+import Data.Word+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import Prelude hiding ( GT )+import Text.ParserCombinators.ReadP+ hiding ( optional )+import Text.Read ( readMaybe )+import Vulkan.Requirement+import Vulkan.Utils.Internal+import Vulkan.Utils.Misc+import Vulkan.Version ( pattern MAKE_VERSION )++-- $setup+-- >>> import Vulkan.Core11.Promoted_From_VK_KHR_multiview+-- >>> import Vulkan.Core12+-- >>> import Vulkan.Extensions.VK_KHR_ray_tracing_pipeline+-- >>> import Vulkan.Zero++-- | Parse a requirement and produce an appropriate 'DeviceRequirement'+--+-- 'DeviceVersionRequirement's are specified by in the form+-- @<major>.<minor>[.<patch>]@+--+-- 'DeviceFeatureRequirement's are specified in the form @<type name>.<member+-- name>@ and produce a 'RequireDeviceFeature' which checks and sets this+-- feature.+--+-- 'DevicePropertyRequirement's are specified like feature requirements except+-- with an additional description of the constraint. This may be any of+--+-- - @myFunctioName@: To check with an in-scope function taking the property+-- type and returning 'Bool'+-- - @> 123@: To indicate a minimum bound on a integral property+-- - @>= 123@: To indicate an inclusive minimum bound on a integral property+-- - @& SOMETHING_BIT@: To indicate that the specified bit must be present in+-- the bitmask value+--+-- 'DeviceExtensionRequirement's are specified in the form @<extension name>+-- <optional version>@. @<extension name>@ must start with @VK_@. The version+-- will be compared against the 'specVersion' field of the+-- 'ExtensionProperties' record.+--+-- - Names may be qualified.+-- - The separator between the type and member can be any of @.@ @::@ @:@ @->@+-- or any amount of space+--+-- >>> let r = [req|PhysicalDeviceRayTracingPipelineFeaturesKHR.rayTracingPipeline|]+-- >>> featureName r+-- "PhysicalDeviceRayTracingPipelineFeaturesKHR.rayTracingPipeline"+--+-- >>> let r = [req|PhysicalDeviceVulkan11Features.multiview|]+-- >>> featureName r+-- "PhysicalDeviceVulkan11Features.multiview"+--+-- >>> let r = [req|PhysicalDeviceMultiviewFeatures.multiview|]+-- >>> featureName r+-- "PhysicalDeviceMultiviewFeatures.multiview"+req :: QuasiQuoter+req = (badQQ "req") { quoteExp = reqExp }++-- | Like 'reqs' except that this parses a list of newline separated+-- requirements+--+-- It ignores+-- - Blank lines+-- - Lines beginning with @--@ or @#@+reqs :: QuasiQuoter+reqs = (badQQ "req") { quoteExp = exps reqExp . filterComments }++reqExp :: String -> Q Exp+reqExp s = do+ case parse s of+ Nothing -> fail $ "Couldn't parse " <> show s+ Just r -> do+ r' <- nameRequest r+ renderRequest s r'++renderRequest :: String -> Request Name Name -> ExpQ+renderRequest input = \case+ Feature s m ->+ let t = conT s+ check = [|$(varE m) :: $t -> Bool|]+ enable = [|\str -> $(recUpdE [| str :: $t |] [fieldExp m [|True|]])|]+ in [| let featureName = fromString $(lift input)+ checkFeature = $(check)+ enableFeature = $(enable)+ in RequireDeviceFeature featureName checkFeature enableFeature+ |]+ Property s m c ->+ let t = conT s+ getProp = [|\str -> $(varE m) (str :: $t)|]+ checker = case c of+ GTE v -> [|(>= $(litE (IntegerL v)))|]+ GT v -> [|(> $(litE (IntegerL v)))|]+ AndBit b -> [|(.&&. $(conE b))|]+ Fun f -> [|$(varE f)|]+ check = [|$checker . $getProp|]+ in [| let propertyName = fromString $(lift input)+ checkProperty = $(check)+ in RequireDeviceProperty propertyName checkProperty+ |]+ Extension s v ->+ [| let deviceExtensionLayerName = Nothing+ deviceExtensionName = fromString $(lift s)+ deviceExtensionMinVersion = $(lift (fromMaybe minBound v))+ in RequireDeviceExtension+ deviceExtensionLayerName+ deviceExtensionName+ deviceExtensionMinVersion+ |]+ Version v -> [| RequireDeviceVersion $(lift v) |]++nameRequest :: Request [String] String -> Q (Request Name Name)+nameRequest = \case+ Feature s m -> do+ sName <- getQualTyName s+ let mName = mkName m+ pure $ Feature sName mName+ Property s m c -> do+ sName <- getQualTyName s+ let mName = mkName m+ c' <- for c getQualValueName+ pure $ Property sName mName c'+ Extension s v -> pure $ Extension s v+ Version v -> pure $ Version v+ where+ getQualTyName n = do+ let q = intercalate "." n+ maybe (fail $ "Couldn't find type name " <> show q) pure+ =<< lookupTypeName q+ getQualValueName n = do+ let q = intercalate "." n+ maybe (fail $ "Couldn't find value name " <> show q) pure+ =<< lookupValueName q++data Request qual unqual+ = Version Word32+ | Feature qual unqual+ | Property qual unqual (Constraint qual)+ | Extension String (Maybe Word32)+ deriving (Show)++data Constraint qual+ = GTE Integer+ | GT Integer+ | AndBit qual+ | Fun qual+ deriving (Show, Functor, Foldable, Traversable)++-- |+-- >>> parse ""+-- Nothing+--+-- >>> parse "Foo->bar"+-- Just (Feature ["Foo"] "bar")+--+-- >>> parse "V.Foo.bar"+-- Just (Feature ["V","Foo"] "bar")+--+-- >>> parse "V.E.Foo bar"+-- Just (Feature ["V","E","Foo"] "bar")+--+-- >>> parse "1.2"+-- Just (Version 4202496)+--+-- >>> parse "1 2 1"+-- Just (Version 4202497)+--+-- >>> parse "Foo.bar >= 10"+-- Just (Property ["Foo"] "bar" (GTE 10))+--+-- >>> parse "V.Foo.bar & A.B.C_BIT"+-- Just (Property ["V","Foo"] "bar" (AndBit ["A","B","C_BIT"]))+--+-- >>> parse "V.Foo.bar even"+-- Just (Property ["V","Foo"] "bar" (Fun ["even"]))+--+-- >>> parse "V.Foo.bar Prelude.even"+-- Just (Property ["V","Foo"] "bar" (Fun ["Prelude","even"]))+parse :: String -> Maybe (Request [String] String)+parse =+ let+ varRemChars = munch (isAlphaNum <||> (== '\'') <||> (== '_'))+ var = (:) <$> satisfy (isLower <||> (== '_')) <*> varRemChars+ con = (:) <$> satisfy isUpper <*> varRemChars+ mod' = con+ qual :: ReadP String -> ReadP [String]+ qual x = (pure <$> x) <|> ((:) <$> (mod' <* char '.') <*> qual x)+ separator = asum (skipSpaces : (void . string <$> [".", "->", "::", ":"]))++ digits = munch1 isDigit+ integer = readS_to_P (reads @Integer)+ word = do+ Just w <- readMaybe <$> digits+ pure w++ comp = do+ c <- (GT <$ string ">") <|> (GTE <$ string ">=")+ skipSpaces+ w <- integer+ pure $ c w+ andBit = do+ _ <- string "&"+ skipSpaces+ q <- qual con+ pure $ AndBit q+ fun = Fun <$> qual var+ constraint = comp <|> andBit <|> fun++ version = do+ ma <- word+ separator+ mi <- word+ pa <- fromMaybe 0 <$> (separator *> optional word)+ pure $ Version (MAKE_VERSION ma mi pa)++ feature = do+ s <- qual con+ _ <- separator+ m <- var+ pure $ Feature s m++ property = do+ s <- qual con+ _ <- separator+ m <- var+ skipSpaces+ c <- constraint+ pure $ Property s m c++ extension = do+ let prefix = "VK_"+ _ <- string prefix+ e <- (prefix <>) <$> munch (isAlphaNum <||> (== '_'))+ skipSpaces+ v <- optional word+ pure $ Extension e v++ request = do+ skipSpaces+ asum+ [ p <* skipSpaces <* eof+ | p <- [version, feature, property, extension]+ ]+ in+ readP_to_S request >>> \case+ -- xs -> pure $ Feature [] (show xs)+ [(r, "")] -> pure r+ _ -> Nothing+{-# ANN parse ("HLint: ignore Use <$>" :: String) #-}++----------------------------------------------------------------+-- Utils+----------------------------------------------------------------++-- | Filters blank or commented lines, remove duplicates+filterComments :: String -> [String]+filterComments =+ let bad = (("--" `isPrefixOf`) <||> ("#" `isPrefixOf`) <||> null)+ in nubOrd . filter (not . bad) . fmap (dropWhile isSpace) . lines++exps :: (String -> ExpQ) -> [String] -> ExpQ+exps f = listE . fmap f++(<||>) :: Applicative f => f Bool -> f Bool -> f Bool+(<||>) = liftA2 (||)+
src/Vulkan/Utils/ShaderQQ.hs view
@@ -26,6 +26,7 @@ import System.FilePath import System.IO.Temp import System.Process.Typed+import Vulkan.Utils.Internal ( badQQ ) import Vulkan.Utils.ShaderQQ.Interpolate -- $setup@@ -112,7 +113,7 @@ vert = shaderQQ "vert" shaderQQ :: String -> QuasiQuoter-shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ stage }+shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ Nothing stage } -- * Utilities @@ -120,15 +121,17 @@ -- -- Messages are converted to GHC warnings or errors depending on compilation success. compileShaderQ- :: String+ :: Maybe String+ -- ^ Argument to pass to `--target-env`+ -> String -- ^ stage -> String -- ^ glsl code -> Q Exp -- ^ Spir-V bytecode-compileShaderQ stage code = do+compileShaderQ targetEnv stage code = do loc <- location- (warnings, result) <- compileShader (Just loc) stage code+ (warnings, result) <- compileShader (Just loc) targetEnv stage code case warnings of [] -> pure () _some -> reportWarning $ prepare warnings@@ -155,21 +158,26 @@ :: MonadIO m => Maybe Loc -- ^ Source location+ -> Maybe String+ -- ^ Argument to pass to `--target-env` -> String -- ^ stage -> String -- ^ glsl code -> m ([GLSLWarning], Either [GLSLError] ByteString) -- ^ Spir-V bytecode with warnings or errors-compileShader loc stage code =+compileShader loc targetEnv stage code = liftIO $ withSystemTempDirectory "th-shader" $ \dir -> do let codeWithLineDirective = maybe code (insertLineDirective code) loc let shader = dir <> "/shader." <> stage spirv = dir <> "/shader.spv" writeFile shader codeWithLineDirective - (rc, out, err) <- readProcess- $ proc "glslangValidator" ["-S", stage, "-V", shader, "-o", spirv]+ let targetArgs = case targetEnv of+ Nothing -> []+ Just t -> ["--target-env", t]+ args = targetArgs ++ ["-S", stage, "-V", shader, "-o", spirv]+ (rc, out, err) <- readProcess $ proc "glslangValidator" args let (warnings, errors) = processValidatorMessages (out <> err) case rc of ExitSuccess -> do@@ -178,16 +186,15 @@ ExitFailure _rc -> pure (warnings, Left errors) processValidatorMessages :: BSL.ByteString -> ([GLSLWarning], [GLSLError])-processValidatorMessages = foldr grep ([], []) . filter (not . null) . lines . BSL.unpack- where- grep line (ws, es)- | "WARNING: " `isPrefixOf` line = (cut line : ws, es)- | "ERROR: " `isPrefixOf` line = (ws, cut line : es)- | otherwise = (ws, es)+processValidatorMessages =+ foldr grep ([], []) . filter (not . null) . lines . BSL.unpack+ where+ grep line (ws, es) | "WARNING: " `isPrefixOf` line = (cut line : ws, es)+ | "ERROR: " `isPrefixOf` line = (ws, cut line : es)+ | otherwise = (ws, es) - cut line = takeFileName path <> msg- where- (path, msg) = break (== ':') . drop 1 $ dropWhile (/= ' ') line+ cut line = takeFileName path <> msg+ where (path, msg) = break (== ':') . drop 1 $ dropWhile (/= ' ') line -- If possible, insert a #line directive after the #version directive (as well -- as the extension which allows filenames in line directives.@@ -207,17 +214,3 @@ in case afterVersion of [] -> code v : xs -> unlines $ beforeVersion <> [v] <> lineDirective <> xs--------------------------------------------------------------------- Utils-------------------------------------------------------------------badQQ :: String -> QuasiQuoter-badQQ name = QuasiQuoter (bad "expression")- (bad "pattern")- (bad "type")- (bad "declaration")- where- bad :: String -> a- bad context =- error $ "Can't use " <> name <> " quote in a " <> context <> " context"
vulkan-utils.cabal view
@@ -3,11 +3,9 @@ -- This file has been generated from package.yaml by hpack version 0.34.2. -- -- see: https://github.com/sol/hpack------ hash: 03fd72b5674b4b85451005687d857d0e9328528b514e5ba805729e54ad6ae761 name: vulkan-utils-version: 0.3+version: 0.4 synopsis: Utils for the vulkan package category: Graphics homepage: https://github.com/expipiplus1/vulkan#readme@@ -40,19 +38,25 @@ Vulkan.Utils.Initialization Vulkan.Utils.Misc Vulkan.Utils.QueueAssignment+ Vulkan.Utils.Requirements+ Vulkan.Utils.Requirements.TH Vulkan.Utils.ShaderQQ Vulkan.Utils.ShaderQQ.Interpolate Vulkan.Utils.ShaderQQ.Shaderc other-modules:- + Vulkan.Utils.Internal hs-source-dirs: src- 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+ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MagicHash NamedFieldPuns NoMonomorphismRestriction OverloadedStrings PartialTypeSignatures PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards RoleAnnotations ScopedTypeVariables StandaloneDeriving Strict TupleSections TypeApplications TypeFamilyDependencies TypeOperators TypeSynonymInstances ViewPatterns+ ghc-options: -Wall c-sources: cbits/DebugCallback.c build-depends: base <5 , bytestring+ , containers+ , dependent-map+ , dependent-sum , extra , file-embed , filepath@@ -62,8 +66,9 @@ , text , transformers , typed-process+ , unordered-containers , vector- , vulkan >=3.6.14 && <3.8+ , vulkan >=3.6.14 && <3.9 default-language: Haskell2010 test-suite doctests@@ -73,7 +78,8 @@ hs-source-dirs: test/doctest- 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+ default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies DuplicateRecordFields FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MagicHash NamedFieldPuns NoMonomorphismRestriction OverloadedStrings PartialTypeSignatures PatternSynonyms PolyKinds QuantifiedConstraints RankNTypes RecordWildCards RoleAnnotations ScopedTypeVariables StandaloneDeriving Strict TupleSections TypeApplications TypeFamilyDependencies TypeOperators TypeSynonymInstances ViewPatterns+ ghc-options: -Wall build-depends: base , doctest