vulkan-utils 0.2 → 0.3

raw patch · 8 files changed

+491/−37 lines, 8 filesdep ~vulkanPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: vulkan

API changes (from Hackage documentation)

Files

• changelog.md +8/−0
• package.yaml +2/−2
• src/Vulkan/Utils/CommandCheck.hs +164/−0
• src/Vulkan/Utils/Initialization.hs +13/−20
• src/Vulkan/Utils/QueueAssignment.hs +13/−11
• src/Vulkan/Utils/ShaderQQ.hs +1/−1
• src/Vulkan/Utils/ShaderQQ/Shaderc.hs +285/−0
• vulkan-utils.cabal +5/−3

@@ -2,6 +2,14 @@  ## WIP +## [0.3] - 2020-11-24++- Change type of pickPhysicalDevice to return Nothing instead of throwing+- Add `checkCommandsExp` function to generate an expression checking specified+  commands for non-nullness+- Expose Queue family index for queues assigned with `assignQueues`+- Add `Vulkan.Utils.ShaderQQ.Shaderc` to compile HLSL shaders+ ## [0.2] - 2020-11-15  - Add `Vulkan.Utils.Misc` for handy functions used in Vulkan programs, but not

@@ -1,5 +1,5 @@ name: vulkan-utils-version: "0.2"+version: "0.3" synopsis: Utils for the vulkan package category: Graphics maintainer: Joe Hermaszewski <live.long.and.prosper@monoid.al>@@ -27,7 +27,7 @@     - transformers     - typed-process     - vector-    - vulkan >= 3.6.14+    - vulkan >= 3.6.14 && < 3.8  tests:   doctests:

@@ -0,0 +1,164 @@+{-# language TemplateHaskell #-}+{-# language NoMonadComprehensions #-}+{-# language MultiWayIf #-}+{-# language QuasiQuotes #-}++module Vulkan.Utils.CommandCheck+  ( checkCommandsExp+  ) where++import           Control.Applicative            ( (<|>) )+import           Control.Arrow                  ( (&&&) )+import           Data.Char+import           Data.Functor                   ( (<&>) )+import           Data.List                      ( isPrefixOf+                                                , isSuffixOf+                                                , nub+                                                )+import           Data.List.Extra                ( dropEnd )+import           Data.Maybe                     ( catMaybes )+import           Foreign.Ptr+import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax+import           Vulkan.Core10 (Instance(..), Device(..))+import           Vulkan.Dynamic++-- | Create an expression which checks the function pointers for all the Vulkan+-- commands depended upon by the specified list of function names.+--+-- It returns a list of function names corresponding to those functions with+-- null pointers.+--+-- Your program can use this function to fail early if a command couldn't be+-- loaded for some reason (missing extension or layer for example).+--+-- One can create a function called @checkCommands@ with the following:+-- @+-- [d| checkCommands = $(checkCommandsExp ['withInstance, 'cmdDraw, ...]) |]+-- @+--+-- It has the type @IsString a => Instance -> Device -> [a]@+--+-- It looks basically like+--+-- @+-- \inst dev ->+--   [ name+--   | True <- [ nullFunPtr == pVkCreateDevice inst+--             , nullFunPtr == pVkCreateFence dev+--               ..+--             ]+--   | name <- [ "vkCreateDevice"+--             , "vkCreateFence"+--               ..+--             ]+--   ]+-- @+checkCommandsExp+  :: [Name]+  -- ^ The names of functions from the @vulkan@ package. Unknown commands are+  -- ignored+  -> Q Exp+checkCommandsExp requestedCommands = do+  instAccessors   <- accessorNames ''InstanceCmds+  deviceAccessors <- accessorNames ''DeviceCmds+  let vkCommandNames =+        nub . commandNames instAccessors deviceAccessors =<< requestedCommands+  inst   <- newName "inst"+  device <- newName "device"+  let isNull = \case+        InstanceCmd i -> [|nullFunPtr == $(varE i) $(varE inst)|]+        DeviceCmd   i -> [|nullFunPtr == $(varE i) $(varE device)|]+  [| \(Instance _ $(varP inst)) (Device _ $(varP device)) ->+      [ name+      | (True, name) <- zip+          $(listE (isNull <$> vkCommandNames))+          $(lift (commandString <$> vkCommandNames))+      ]+    |]++-- | Given instance and device accessors and a function, find the function+-- pointer accessor names which it depends on+--+-- >>> commandNames ['pVkCreateDevice, 'pVkDestroyDevice] ['pVkCreateFence] (mkName "withDevice")+-- [InstanceCmd Vulkan.Dynamic.pVkCreateDevice,InstanceCmd Vulkan.Dynamic.pVkDestroyDevice]+commandNames :: [Name] -> [Name] -> Name -> [DeviceOrInstanceCommand]+commandNames instAccessors deviceAccessors =+  let instNames   = (nameBase &&& id) <$> instAccessors+      deviceNames = (nameBase &&& id) <$> deviceAccessors+      findCommand :: String -> Maybe DeviceOrInstanceCommand+      findCommand command =+        (InstanceCmd <$> lookup command instNames)+          <|> (DeviceCmd <$> lookup command deviceNames)+  in  \n ->+        let candidates = commandCandidates (nameBase n)+        in  catMaybes $ findCommand <$> candidates++data DeviceOrInstanceCommand+  = DeviceCmd Name+  | InstanceCmd Name+  deriving (Eq, Show)++-- | Get the C name of a function+--+-- >>> commandString (DeviceCmd (mkName "pVkCreateInstance"))+-- "vkCreateInstance"+commandString :: DeviceOrInstanceCommand -> String+commandString = unPtrName . nameBase . \case+  InstanceCmd n -> n+  DeviceCmd   n -> n++-- | A list of potential sets of vulkan commands this name depends on, not all+-- of them will be valid names.+--+-- >>> commandCandidates "withDevice"+-- ["pVkAllocateDevice","pVkFreeDevice","pVkCreateDevice","pVkDestroyDevice"]+--+-- >>> commandCandidates "waitSemaphoresSafe"+-- ["pVkWaitSemaphores"]+--+-- >>> commandCandidates "useCmdBuffer"+-- ["pVkBeginCmdBuffer","pVkEndCmdBuffer"]+--+-- >>> commandCandidates "withSemaphore"+-- ["pVkAllocateSemaphore","pVkFreeSemaphore","pVkCreateSemaphore","pVkDestroySemaphore"]+commandCandidates :: String -> [String]+commandCandidates n = if+  | "Safe" `isSuffixOf` n+  -> commandCandidates (dropEnd 4 n)+  | Just u <- stripPrefix "with"+  -> (<> u) <$> ["pVkAllocate", "pVkFree", "pVkCreate", "pVkDestroy"]+  | Just u <- stripPrefix "withMapped"+  -> (<> u) <$> ["pVkMap", "pVkUnmap"]+  | Just u <- stripPrefix "use"+  -> (<> u) <$> ["pVkBegin", "pVkEnd"]+  | Just u <- stripPrefix "cmdUse"+  -> (<> u) <$> ["pVkCmdBegin", "pVkCmdEnd"]+  | otherwise+  -> ["pVk" <> upperCaseFirst n]+ where+  stripPrefix p = if p `isPrefixOf` n+    then Just (upperCaseFirst (drop (length p) n))+    else Nothing++-- | Get the record accessors of a type+--+-- >>> $(lift . fmap show =<< accessorNames ''Device)+-- ["Vulkan.Core10.Handles.deviceHandle","Vulkan.Core10.Handles.deviceCmds"]+accessorNames :: Name -> Q [Name]+accessorNames record = reify record <&> \case+  TyConI (DataD _ _ _ _ [con] _)+    | RecC _ vars <- con       -> firstOfThree <$> vars+    | RecGadtC _ vars _ <- con -> firstOfThree <$> vars+  _ -> fail "Name wasn't a TyConI"+  where firstOfThree (a, _, _) = a++unPtrName :: String -> String+unPtrName = \case+  'p' : 'V' : xs -> 'v' : xs+  s              -> s++upperCaseFirst :: String -> String+upperCaseFirst = \case+  x:xs -> toUpper x : xs+  [] -> []

@@ -8,7 +8,6 @@   , createDeviceWithExtensions   ) where -import           Control.Exception              ( throwIO ) import           Control.Monad.IO.Class import           Control.Monad.Trans.Resource import           Data.Bits@@ -19,9 +18,6 @@ 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@@ -148,30 +144,31 @@ -- | 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.+-- spirit of parse-don't-validate. Also provide a function to compare these+-- results for sorting multiple suitable 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.+-- As an example, the suitability 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. Consider using+-- 'Vulkan.Utils.QueueAssignment.assignQueues' to find your desired queues in+-- the suitability function. ----- If no devices are deemed suitable then an 'IOError' is thrown.+-- If no devices are deemed suitable then a 'NoSuchThing' '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 suitability funcion for a 'PhysicalDevice', 'Nothing' if it is not to+  -- be chosen.   -> (a -> b)   -- ^ Scoring function to rate this result-  -> m (a, PhysicalDevice)+  -> m (Maybe (a, PhysicalDevice))   -- ^ The score and the device pickPhysicalDevice inst devInfo score = do   (_, devs) <- enumeratePhysicalDevices inst-  infos    <- catMaybes+  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+  pure $ maximumByMay (comparing (score . fst)) infos  -- | Extract the name of a 'PhysicalDevice' with 'getPhysicalDeviceProperties' physicalDeviceName :: MonadIO m => PhysicalDevice -> m Text@@ -222,10 +219,6 @@ ---------------------------------------------------------------- -- 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)

@@ -8,7 +8,7 @@   , isGraphicsQueueFamily   , isTransferQueueFamily   , isTransferOnlyQueueFamily-  , isPresentQueue+  , isPresentQueueFamily   ) where  import           Control.Applicative@@ -78,10 +78,10 @@ -- your queues like: -- -- @--- data MyQueues a = MyQueues---   { computeQueue            :: a---   , graphicsAndPresentQueue :: a---   , transferQueue           :: a+-- data MyQueues q = MyQueues+--   { computeQueue            :: q+--   , graphicsAndPresentQueue :: q+--   , transferQueue           :: q --   } -- -- myQueueSpecs :: MyQueues QueueSpec@@ -102,7 +102,9 @@   -- ^ A set of requirements for 'Queue's to be created   -> m        ( Maybe-           (Vector (DeviceQueueCreateInfo '[]), Device -> n (f Queue))+           ( Vector (DeviceQueueCreateInfo '[])+           , Device -> n (f (QueueFamilyIndex, Queue))+           )        )   -- ^   -- - A set of 'DeviceQueueCreateInfo's to pass to 'createDevice'@@ -177,11 +179,11 @@         ]        -- Get-      extractQueues :: Device -> n (f Queue)+      extractQueues :: Device -> n (f (QueueFamilyIndex, Queue))       extractQueues dev =         for specsWithQueueIndex-          $ \(_, QueueFamilyIndex familyIndex, QueueIndex index) ->-              getDeviceQueue dev familyIndex index+          $ \(_, i@(QueueFamilyIndex familyIndex), QueueIndex index) ->+              (i, ) <$> getDeviceQueue dev familyIndex index    pure (queueCreateInfos, extractQueues) @@ -208,9 +210,9 @@     == QUEUE_TRANSFER_BIT  -- | Can this queue family present to this surface on this device-isPresentQueue+isPresentQueueFamily   :: MonadIO m => PhysicalDevice -> SurfaceKHR -> QueueFamilyIndex -> m Bool-isPresentQueue phys surf (QueueFamilyIndex i) =+isPresentQueueFamily phys surf (QueueFamilyIndex i) =   getPhysicalDeviceSurfaceSupportKHR phys i surf  ----------------------------------------------------------------

@@ -55,7 +55,7 @@ -- An explicit example (@<interactive>@ is from doctest): -- -- >>> let version = 450 :: Int in [glsl|#version $version|]--- "#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line 32 \"<interactive>\"\n"+-- "#version 450\n#extension GL_GOOGLE_cpp_style_line_directive : enable\n#line 46 \"<interactive>\"\n" -- -- Note that line number will be thrown off if any of the interpolated -- variables contain newlines.

@@ -0,0 +1,285 @@+module Vulkan.Utils.ShaderQQ.Shaderc+  ( hlsl+  , comp+  , frag+  , geom+  , tesc+  , tese+  , vert+  , ShadercError+  , ShadercWarning+  , compileShaderQ+  , compileShader+  , processShadercMessages+  ) where++import           Control.Monad                  ( void )+import           Control.Monad.IO.Class+import           Data.ByteString                ( ByteString )+import qualified Data.ByteString               as BS+import qualified Data.ByteString.Lazy.Char8    as BSL+import           Data.FileEmbed+import           Data.Foldable                  ( asum )+import           Data.List.Extra+import           Language.Haskell.TH+import           Language.Haskell.TH.Quote+import           System.Exit+import           System.IO.Temp+import           System.Process.Typed+import           Text.ParserCombinators.ReadP+import           Vulkan.Utils.ShaderQQ.Interpolate++-- $setup+-- >>> :set -XQuasiQuotes++-- | 'hlsl' is a QuasiQuoter which produces HLSL source code with a @#line@+-- directive inserted so that error locations point to the correct location in+-- the Haskell source file. It also permits basic string interpolation.+--+-- - Interpolated variables are prefixed with @$@+-- - They can optionally be surrounded with braces like @${foo}@+-- - Interpolated variables are converted to strings with 'show'+-- - To escape a @$@ use @\\$@+--+-- It is intended to be used in concert with 'compileShaderQ' like so+--+-- @+-- myConstant = 3.141 -- Note that this will have to be in a different module+-- myFragmentShader = $(compileShaderQ "frag" [hlsl|+--   static const float myConstant = ${myConstant};+--   float main (){+--     return myConstant;+--   }+-- |])+-- @+--+-- An explicit example (@<interactive>@ is from doctest):+--+-- >>> let foo = 450 :: Int in [hlsl|const float foo = $foo|]+-- "#line 31 \"<interactive>\"\nconst float foo = 450"+--+-- Note that line number will be thrown off if any of the interpolated+-- variables contain newlines.+hlsl :: QuasiQuoter+hlsl = (badQQ "hlsl")+  { quoteExp = \s -> do+                 loc <- location+                 -- Insert the directive here, `compileShaderQ` will insert+                 -- another one, but it's before this one, so who cares.+                 let codeWithLineDirective = insertLineDirective s loc+                 interpExp codeWithLineDirective+  }++-- | QuasiQuoter for creating a compute shader.+--+-- Equivalent to calling @$(compileShaderQ "comp" [hlsl|...|])@ without+-- interpolation support.+comp :: QuasiQuoter+comp = shaderQQ "comp"++-- | QuasiQuoter for creating a fragment shader.+--+-- Equivalent to calling @$(compileShaderQ "frag" [hlsl|...|])@ without+-- interpolation support.+frag :: QuasiQuoter+frag = shaderQQ "frag"++-- | QuasiQuoter for creating a geometry shader.+--+-- Equivalent to calling @$(compileShaderQ "geom" [hlsl|...|])@ without+-- interpolation support.+geom :: QuasiQuoter+geom = shaderQQ "geom"++-- | QuasiQuoter for creating a tessellation control shader.+--+-- Equivalent to calling @$(compileShaderQ "tesc" [hlsl|...|])@ without+-- interpolation support.+tesc :: QuasiQuoter+tesc = shaderQQ "tesc"++-- | QuasiQuoter for creating a tessellation evaluation shader.+--+-- Equivalent to calling @$(compileShaderQ "tese" [hlsl|...|])@ without+-- interpolation support.+tese :: QuasiQuoter+tese = shaderQQ "tese"++-- | QuasiQuoter for creating a vertex shader.+--+-- Equivalent to calling @$(compileShaderQ "vert" [hlsl|...|])@ without+-- interpolation support.+vert :: QuasiQuoter+vert = shaderQQ "vert"++shaderQQ :: String -> QuasiQuoter+shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ stage }++-- * Utilities++-- | Compile a HLSL shader to SPIR-V using glslc (from the shaderc project)+--+-- Messages are converted to GHC warnings or errors depending on compilation success.+compileShaderQ+  :: String+  -- ^ stage+  -> String+  -- ^ glsl or code+  -> Q Exp+  -- ^ Spir-V bytecode+compileShaderQ stage code = do+  loc                <- location+  (warnings, result) <- compileShader (Just loc) stage code+  case warnings of+    []    -> pure ()+    _some -> reportWarning $ prepare warnings++  bs <- case result of+    Left []     -> fail "glslc failed with no errors"+    Left errors -> do+      reportError $ prepare errors+      pure mempty+    Right bs -> pure bs++  bsToExp bs++ where+  prepare [singleLine] = singleLine+  prepare multiline =+    intercalate "\n" $ "glslc:" : map (mappend "        ") multiline++type ShadercError = String+type ShadercWarning = String++-- | Compile a HLSL shader to spir-v using glslc+compileShader+  :: MonadIO m+  => Maybe Loc+  -- ^ Source location+  -> String+  -- ^ stage+  -> String+  -- ^ HLSL code+  -> m ([ShadercWarning], Either [ShadercError] ByteString)+  -- ^ Spir-V bytecode with warnings or errors+compileShader loc stage code =+  liftIO $ withSystemTempDirectory "th-shader" $ \dir -> do+    let codeWithLineDirective = maybe code (insertLineDirective code) loc+    let shader = dir <> "/shader.hlsl"+        spirv  = dir <> "/shader.spv"+    writeFile shader codeWithLineDirective++    (rc, out, err) <- readProcess $ proc+      "glslc"+      ["-fshader-stage=" <> stage, "-x", "hlsl", shader, "-o", spirv]+    let (warnings, errors) = processShadercMessages (out <> err)+    case rc of+      ExitSuccess -> do+        bs <- BS.readFile spirv+        pure (warnings, Right bs)+      ExitFailure _rc -> pure (warnings, Left errors)++processShadercMessages :: BSL.ByteString -> ([ShadercWarning], [ShadercError])+processShadercMessages = foldMap parseMsg . lines . BSL.unpack++-- >>> parseMsg "blah"+-- ([],[])+--+-- >>> parseMsg "blah"+-- ([],["blah"])+--+-- >>> parseMsg "foo:2: error: unknown var"+-- ([],["foo:2: unknown var"])+--+-- >>> parseMsg "foo:2: warning: unknown var"+-- (["foo:2: unknown var"],[])+--+-- >>> parseMsg "bar:2: error: 'a' : unknown variable"+-- ([],["bar:2: 'a' : unknown variable"])+--+-- >>> parseMsg "f:o: error: f:o:2: 'a' : unknown variable"+-- ([],["f:o:2: 'a' : unknown variable"])+--+-- >>> parseMsg "f:o: error: f:o:2: 'return' : type does not match, or is not convertible to, the function's return type"+-- ([],["f:o:2: 'return' : type does not match, or is not convertible to, the function's return type"])+--+-- >>> parseMsg "foo: foo(1): error at column 3, HLSL parsing failed."+-- ([],["foo:1: error at column 3, HLSL parsing failed."])+parseMsg :: String -> ([ShadercWarning], [ShadercError])+parseMsg = runParser $ foldl1+  (<++)+  [ do+    f    <- filename+    line <- between colon colon number+    skipSpaces+    t   <- msgType+    msg <- manyTill get eof+    pure $ formatMsg t f line msg+  , do+    f <- filename+    colon *> skipSpaces+    t    <- msgType+    _    <- string f+    line <- between (char ':') (char ':') number+    skipSpaces+    msg <- manyTill get eof+    pure $ formatMsg t f line msg+  , do+    f <- filename+    colon *> skipSpaces+    _    <- string f+    line <- between (char '(') (char ')') number+    colon *> skipSpaces+    let t x = ([], [x])+    msg <- manyTill get eof+    pure $ formatMsg t f line msg+  , do+    _ <- number+    skipSpaces+    _ <- string "errors generated"+    eof+    pure ([], [])+  , do+    -- Unknown format+    msg <- manyTill get eof+    eof+    pure ([], [msg])+  ]+ where+  formatMsg t f line msg = t (f <> ":" <> show line <> ": " <> msg)+  filename = many1 get+  number   = readS_to_P (reads @Integer)+  colon    = void $ char ':'+  msgType =+    asum+        [ (\x -> ([], [x])) <$ string "error"+        , (\x -> ([x], [])) <$ string "warning"+        ]+      <* colon+      <* skipSpaces++runParser :: Monoid p => ReadP p -> String -> p+runParser p s = case readP_to_S p s of+  [(r, "")] -> r+  _         -> mempty++-- Insert a #line directive with the specified location at the top of the file+insertLineDirective :: String -> Loc -> String+insertLineDirective code Loc {..} =+  let lineDirective =+        "#line " <> show (fst loc_start) <> " \"" <> loc_filename <> "\""+  in  lineDirective <> "\n" <> code++----------------------------------------------------------------+-- 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"

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 2b51403e73e2f406342411ce5b6dd2e2f8db703ba97dd8c135df3d0e3a9b51bc+-- hash: 03fd72b5674b4b85451005687d857d0e9328528b514e5ba805729e54ad6ae761  name:           vulkan-utils-version:        0.2+version:        0.3 synopsis:       Utils for the vulkan package category:       Graphics homepage:       https://github.com/expipiplus1/vulkan#readme@@ -34,6 +34,7 @@  library   exposed-modules:+      Vulkan.Utils.CommandCheck       Vulkan.Utils.Debug       Vulkan.Utils.FromGL       Vulkan.Utils.Initialization@@ -41,6 +42,7 @@       Vulkan.Utils.QueueAssignment       Vulkan.Utils.ShaderQQ       Vulkan.Utils.ShaderQQ.Interpolate+      Vulkan.Utils.ShaderQQ.Shaderc   other-modules:          hs-source-dirs:@@ -61,7 +63,7 @@     , transformers     , typed-process     , vector-    , vulkan >=3.6.14+    , vulkan >=3.6.14 && <3.8   default-language: Haskell2010  test-suite doctests