packages feed

vulkan-utils 0.4.2 → 0.5.0

raw patch · 17 files changed

+1279/−505 lines, 17 files

Files

changelog.md view
@@ -2,6 +2,22 @@  ## WIP +## [0.5.0] - 2021-02-24+- Refactor module `Vulkan.Utils.ShaderQQ`+  - Remove `Vulkan.Utils.ShaderQQ`+  - Remove `Vulkan.Utils.ShaderQQ.Shaderc`+  - Provide `glsl`/`hlsl`, `vert` .. `comp`, `rgen` .. `rcall`, `mesh`, `task`, `compileShaderQ`, `compileShader` in each ShaderQQ provider module under `Vulkan.Utils.ShaderQQ` for help compile shaders+  - Add `Vulkan.Utils.ShaderQQ.Backend.Glslang`to help process warning & error messages for glslangValidator+  - Add `Vulkan.Utils.ShaderQQ.Backend.Shaderc`to help process warning & error messages for glslc+  - Add `Vulkan.Utils.ShaderQQ.GLSL.Glslang` to compile glsl shaders for glslangValidator+  - Add `Vulkan.Utils.ShaderQQ.GLSL.Shaderc` to compile glsl shaders for glslc+  - Add `Vulkan.Utils.ShaderQQ.HLSL.Glslang` to compile hlsl shaders for glslangValidator+  - Add `Vulkan.Utils.ShaderQQ.HLSL.Shaderc` to compile hlsl shaders for glslc+- specify `--target-spv` for shaderc ray tracing shaders+- specify `--target-env` for glslang ray tracing shaders+- support pass hlsl entry point to glslangValidator and shaderc+- support pass glsl entry point to glslangValidator+ ## [0.4.2] - 2021-02-18 - Relax bounds on `vulkan`
package.yaml view
@@ -1,5 +1,5 @@ name: vulkan-utils-version: "0.4.2"+version: "0.5.0" synopsis: Utils for the vulkan package category: Graphics maintainer: Joe Hermaszewski <live.long.and.prosper@monoid.al>
− src/Vulkan/Utils/ShaderQQ.hs 
@@ -1,216 +0,0 @@-module Vulkan.Utils.ShaderQQ-  ( glsl-  , comp-  , frag-  , geom-  , tesc-  , tese-  , vert-  , GLSLError-  , GLSLWarning-  , compileShaderQ-  , compileShader-  , processValidatorMessages-  ) where--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.Char-import           Data.FileEmbed-import           Data.List.Extra-import           Language.Haskell.TH-import           Language.Haskell.TH.Quote-import           System.Exit-import           System.FilePath-import           System.IO.Temp-import           System.Process.Typed-import           Vulkan.Utils.Internal          ( badQQ )-import           Vulkan.Utils.ShaderQQ.Interpolate---- $setup--- >>> :set -XQuasiQuotes---- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@--- directives 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" [glsl|---   #version 450---   const float myConstant = ${myConstant};---   main (){---   }--- |])--- @------ 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 46 \"<interactive>\"\n"------ Note that line number will be thrown off if any of the interpolated--- variables contain newlines.-glsl :: QuasiQuoter-glsl = (badQQ "glsl")-  { 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" [glsl|...|])@ without--- interpolation support.-comp :: QuasiQuoter-comp = shaderQQ "comp"---- | QuasiQuoter for creating a fragment shader.------ Equivalent to calling @$(compileShaderQ "frag" [glsl|...|])@ without--- interpolation support.-frag :: QuasiQuoter-frag = shaderQQ "frag"---- | QuasiQuoter for creating a geometry shader.------ Equivalent to calling @$(compileShaderQ "geom" [glsl|...|])@ without--- interpolation support.-geom :: QuasiQuoter-geom = shaderQQ "geom"---- | QuasiQuoter for creating a tessellation control shader.------ Equivalent to calling @$(compileShaderQ "tesc" [glsl|...|])@ without--- interpolation support.-tesc :: QuasiQuoter-tesc = shaderQQ "tesc"---- | QuasiQuoter for creating a tessellation evaluation shader.------ Equivalent to calling @$(compileShaderQ "tese" [glsl|...|])@ without--- interpolation support.-tese :: QuasiQuoter-tese = shaderQQ "tese"---- | QuasiQuoter for creating a vertex shader.------ Equivalent to calling @$(compileShaderQ "vert" [glsl|...|])@ without--- interpolation support.-vert :: QuasiQuoter-vert = shaderQQ "vert"--shaderQQ :: String -> QuasiQuoter-shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ Nothing stage }---- * Utilities---- | Compile a glsl shader to spir-v using glslangValidator.------ Messages are converted to GHC warnings or errors depending on compilation success.-compileShaderQ-  :: Maybe String-  -- ^ Argument to pass to `--target-env`-  -> String-  -- ^ stage-  -> String-  -- ^ glsl code-  -> Q Exp-  -- ^ Spir-V bytecode-compileShaderQ targetEnv stage code = do-  loc                <- location-  (warnings, result) <- compileShader (Just loc) targetEnv stage code-  case warnings of-    []    -> pure ()-    _some -> reportWarning $ prepare warnings--  bs <- case result of-    Left []     -> fail "glslangValidator 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" $ "glslangValidator:" : map (mappend "        ") multiline--type GLSLError = String-type GLSLWarning = String---- | Compile a glsl shader to spir-v using glslangValidator-compileShader-  :: 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 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--    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-        bs <- BS.readFile spirv-        pure (warnings, Right bs)-      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)--  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.-insertLineDirective :: String -> Loc -> String-insertLineDirective code Loc {..} =-  let isVersionDirective = ("#version" `isPrefixOf`) . dropWhile isSpace-      codeLines = lines code-      (beforeVersion, afterVersion) = break isVersionDirective codeLines-      lineDirective =-        [ "#extension GL_GOOGLE_cpp_style_line_directive : enable"-        , "#line "-          <> show (fst loc_start + length beforeVersion + 1)-          <> " \""-          <> loc_filename-          <> "\""-        ]-  in  case afterVersion of-        []     -> code-        v : xs -> unlines $ beforeVersion <> [v] <> lineDirective <> xs
+ src/Vulkan/Utils/ShaderQQ/Backend/Glslang.hs view
@@ -0,0 +1,23 @@+module Vulkan.Utils.ShaderQQ.Backend.Glslang+  ( GlslangError+  , GlslangWarning+  , processGlslangMessages+  ) where++import qualified Data.ByteString.Lazy.Char8    as BSL+import           Data.List.Extra+import           System.FilePath++type GlslangError = String+type GlslangWarning = String++processGlslangMessages :: BSL.ByteString -> ([GlslangWarning], [GlslangError])+processGlslangMessages =+  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
+ src/Vulkan/Utils/ShaderQQ/Backend/Glslang/Internal.hs view
@@ -0,0 +1,90 @@+module Vulkan.Utils.ShaderQQ.Backend.Glslang.Internal+  ( compileShaderQ+  , compileShader+  ) where++import           Control.Monad.IO.Class+import           Data.ByteString                ( ByteString )+import qualified Data.ByteString               as BS+import           Data.FileEmbed+import           Language.Haskell.TH+import           System.Exit+import           System.IO.Temp+import           System.Process.Typed+import           Vulkan.Utils.ShaderQQ.ShaderType+import qualified Vulkan.Utils.ShaderQQ.GLSL    as GLSL+import qualified Vulkan.Utils.ShaderQQ.HLSL    as HLSL+import           Vulkan.Utils.ShaderQQ.Backend.Glslang+import           Vulkan.Utils.ShaderQQ.Backend.Internal++-- * Utilities++-- | Compile a GLSL/HLSL shader to spir-v using glslangValidator.+--+-- Messages are converted to GHC warnings or errors depending on compilation success.+compileShaderQ+  :: Maybe String+  -- ^ Argument to pass to `--target-env`+  -> ShaderType+  -- ^ Argument to specify between glsl/hlsl shader+  -> String+  -- ^ stage+  -> Maybe String+  -- ^ Argument to specify entry-point function name+  -> String+  -- ^ glsl or hlsl shader code+  -> Q Exp+  -- ^ Spir-V bytecode+compileShaderQ targetEnv shaderType stage entryPoint code = do+  loc                <- location+  (warnings, result) <- compileShader (Just loc) targetEnv shaderType stage entryPoint code+  bs <- messageProcess "glslangValidator" reportWarning fail (warnings, result)+  bsToExp bs++-- | Compile a GLSL/HLSL shader to spir-v using glslangValidator+compileShader+  :: MonadIO m+  => Maybe Loc+  -- ^ Source location+  -> Maybe String+  -- ^ Argument to pass to `--target-env`+  -> ShaderType+  -- ^ Argument to specify between glsl/hlsl shader+  -> String+  -- ^ stage+  -> Maybe String+  -- ^ Argument to specify entry-point function name+  -> String+  -- ^ glsl or hlsl shader code+  -> m ([GlslangWarning], Either [GlslangError] ByteString)+  -- ^ Spir-V bytecode with warnings or errors+compileShader loc targetEnv shaderType stage entryPoint code =+  liftIO $ withSystemTempDirectory "th-shader" $ \dir -> do+    let codeWithLineDirective = maybe code (case shaderType of+                                              GLSL -> GLSL.insertLineDirective code+                                              HLSL -> HLSL.insertLineDirective code+                                           ) loc+    let shader = dir <> "/shader." <> stage+        spirv  = dir <> "/shader.spv"+    writeFile shader codeWithLineDirective++    let targetArgs = case targetEnv of+          Nothing -> []+          Just t  -> ["--target-env", t]+        shaderTypeArgs = case shaderType of+          GLSL -> []+          HLSL -> ["-D"]+        -- https://github.com/KhronosGroup/glslang/issues/1045#issuecomment-328707953+        entryPointArgs = case entryPoint of+          Nothing -> []+          Just name -> case shaderType of+            GLSL -> ["-e", name, "--source-entry-point", "main"]+            HLSL -> ["-e", name]+        args = targetArgs ++ shaderTypeArgs ++ entryPointArgs ++ ["-S", stage, "-V", shader, "-o", spirv]+    (rc, out, err) <- readProcess $ proc "glslangValidator" args+    let (warnings, errors) = processGlslangMessages (out <> err)+    case rc of+      ExitSuccess -> do+        bs <- BS.readFile spirv+        pure (warnings, Right bs)+      ExitFailure _rc -> pure (warnings, Left errors)
+ src/Vulkan/Utils/ShaderQQ/Backend/Internal.hs view
@@ -0,0 +1,33 @@+module Vulkan.Utils.ShaderQQ.Backend.Internal+  ( messageProcess+  ) where++import           Data.ByteString                ( ByteString )+import           Data.List.Extra++messageProcess+  :: (Applicative m, Monad m)+  => String+  -- ^ tool name+  -> (String -> m ())+  -- ^ warning+  -> (String -> m ByteString)+  -- ^ error+  -> ([String], Either [String] ByteString)+  -- ^ Spir-V bytecode with warnings or errors+  -> m ByteString+  -- ^ Spir-V bytecode+messageProcess tool warn err (warnings, result) = do+  case warnings of+    []    -> pure ()+    _some -> warn $ prepare warnings+  case result of+    Left []     -> err $ tool ++ " failed with no errors"+    Left errors -> do+      _ <- err $ prepare errors+      pure mempty+    Right bs -> pure bs+  where+    prepare [singleLine] = singleLine+    prepare multiline =+      intercalate "\n" $ (tool ++ ":") : map (mappend "        ") multiline
+ src/Vulkan/Utils/ShaderQQ/Backend/Shaderc.hs view
@@ -0,0 +1,97 @@+module Vulkan.Utils.ShaderQQ.Backend.Shaderc+  ( ShadercError+  , ShadercWarning+  , processShadercMessages+  ) where++import           Control.Monad                  ( void )+import qualified Data.ByteString.Lazy.Char8    as BSL+import           Data.Foldable                  ( asum )+import           Text.ParserCombinators.ReadP++type ShadercError = String+type ShadercWarning = String++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
+ src/Vulkan/Utils/ShaderQQ/Backend/Shaderc/Internal.hs view
@@ -0,0 +1,87 @@+module Vulkan.Utils.ShaderQQ.Backend.Shaderc.Internal+  ( compileShaderQ+  , compileShader+  ) where++import           Control.Monad.IO.Class+import           Data.ByteString                ( ByteString )+import qualified Data.ByteString               as BS+import           Data.FileEmbed+import           Language.Haskell.TH+import           System.Exit+import           System.IO.Temp+import           System.Process.Typed+import           Vulkan.Utils.ShaderQQ.ShaderType+import qualified Vulkan.Utils.ShaderQQ.GLSL    as GLSL+import qualified Vulkan.Utils.ShaderQQ.HLSL    as HLSL+import           Vulkan.Utils.ShaderQQ.Backend.Shaderc+import           Vulkan.Utils.ShaderQQ.Backend.Internal++-- * Utilities++-- | Compile a GLSL/HLSL shader to SPIR-V using glslc (from the shaderc project)+--+-- Messages are converted to GHC warnings or errors depending on compilation success.+compileShaderQ+  :: Maybe String+  -- ^ Argument to pass to `--target-spv`+  -> ShaderType+  -- ^ Argument to specify between glsl/hlsl shader+  -> String+  -- ^ stage+  -> Maybe String+  -- ^ Argument to specify entry-point function name for hlsl+  -> String+  -- ^ glsl or hlsl shader code+  -> Q Exp+  -- ^ Spir-V bytecode+compileShaderQ targetSpv shaderType stage entryPoint code = do+  loc                <- location+  (warnings, result) <- compileShader (Just loc) targetSpv shaderType stage entryPoint code+  bs <- messageProcess "glslc" reportWarning fail (warnings, result)+  bsToExp bs++-- | Compile a GLSL/HLSL shader to spir-v using glslc+compileShader+  :: MonadIO m+  => Maybe Loc+  -- ^ Source location+  -> Maybe String+  -- ^ Argument to pass to `--target-spv`+  -> ShaderType+  -- ^ Argument to specify between glsl/hlsl shader+  -> String+  -- ^ stage+  -> Maybe String+  -- ^ Argument to specify entry-point function name for hlsl+  -> String+  -- ^ glsl or hlsl shader code+  -> m ([ShadercWarning], Either [ShadercError] ByteString)+  -- ^ Spir-V bytecode with warnings or errors+compileShader loc targetSpv shaderType stage entryPoint code =+  liftIO $ withSystemTempDirectory "th-shader" $ \dir -> do+    let codeWithLineDirective = maybe code (case shaderType of+                                              GLSL -> GLSL.insertLineDirective code+                                              HLSL -> HLSL.insertLineDirective code+                                           ) loc+    let shader = dir <> "/shader." <> stage+        spirv  = dir <> "/shader.spv"+    writeFile shader codeWithLineDirective++    let targetArgs = case targetSpv of+          Nothing -> []+          Just t  -> ["--target-spv=" <> t]+        -- https://github.com/google/shaderc/blob/01dd72d6079ebdc0f96859365ba7abb1b62758bf/glslc/src/main.cc#L64+        entryPointArgs = case entryPoint of+          Nothing -> []+          Just name -> case shaderType of+            GLSL -> []+            HLSL -> ["-fentry-point=" <> name] +        args = targetArgs ++ entryPointArgs ++ ["-fshader-stage=" <> stage, "-x", show shaderType, shader, "-o", spirv]+    (rc, out, err) <- readProcess $ proc "glslc" args+    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)
+ src/Vulkan/Utils/ShaderQQ/GLSL.hs view
@@ -0,0 +1,59 @@+module Vulkan.Utils.ShaderQQ.GLSL+  ( glsl+  , insertLineDirective+  ) where++import           Language.Haskell.TH+import           Language.Haskell.TH.Quote+import           Vulkan.Utils.Internal                  ( badQQ )+import           Vulkan.Utils.ShaderQQ.Interpolate+import           Data.Char+import           Data.List.Extra++-- $setup+-- >>> :set -XQuasiQuotes++-- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@+-- directives 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 @\\$@+--+-- 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 72 \"<interactive>\"\n"+--+-- Note that line number will be thrown off if any of the interpolated+-- variables contain newlines.+glsl :: QuasiQuoter+glsl = (badQQ "glsl")+  { 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+  }++-- If possible, insert a #line directive after the #version directive (as well+-- as the extension which allows filenames in line directives.+insertLineDirective :: String -> Loc -> String+insertLineDirective code Loc {..} =+  let isVersionDirective = ("#version" `isPrefixOf`) . dropWhile isSpace+      codeLines = lines code+      (beforeVersion, afterVersion) = break isVersionDirective codeLines+      lineDirective =+        [ "#extension GL_GOOGLE_cpp_style_line_directive : enable"+        , "#line "+          <> show (fst loc_start + length beforeVersion + 1)+          <> " \""+          <> loc_filename+          <> "\""+        ]+  in  case afterVersion of+        []     -> code+        v : xs -> unlines $ beforeVersion <> [v] <> lineDirective <> xs
+ src/Vulkan/Utils/ShaderQQ/GLSL/Glslang.hs view
@@ -0,0 +1,202 @@+module Vulkan.Utils.ShaderQQ.GLSL.Glslang+  ( glsl+  , comp+  , frag+  , geom+  , tesc+  , tese+  , vert+  , rgen+  , rint+  , rahit+  , rchit+  , rmiss+  , rcall+  , task+  , mesh+  , compileShaderQ+  , compileShader+  ) where++import           Control.Monad.IO.Class+import           Data.ByteString                                 ( ByteString )+import           Language.Haskell.TH+import           Language.Haskell.TH.Quote+import           Vulkan.Utils.Internal                           ( badQQ )+import           Vulkan.Utils.ShaderQQ.ShaderType+import           Vulkan.Utils.ShaderQQ.Backend.Glslang           ( GlslangError, GlslangWarning )+import qualified Vulkan.Utils.ShaderQQ.Backend.Glslang.Internal as Glslang+import qualified Vulkan.Utils.ShaderQQ.GLSL                     as GLSL++-- $setup+-- >>> :set -XQuasiQuotes++-- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@+-- directives 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 Nothing "frag" Nothing [glsl|+--   #version 450+--   const float myConstant = ${myConstant};+--   main (){+--   }+-- |])+-- @+--+-- 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"+--+-- Note that line number will be thrown off if any of the interpolated+-- variables contain newlines.+glsl :: QuasiQuoter+glsl = GLSL.glsl++-- | QuasiQuoter for creating a compute shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "comp" Nothing [glsl|...|])@ without+-- interpolation support.+comp :: QuasiQuoter+comp = shaderQQ "comp"++-- | QuasiQuoter for creating a fragment shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "frag" Nothing [glsl|...|])@ without+-- interpolation support.+frag :: QuasiQuoter+frag = shaderQQ "frag"++-- | QuasiQuoter for creating a geometry shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "geom" Nothing [glsl|...|])@ without+-- interpolation support.+geom :: QuasiQuoter+geom = shaderQQ "geom"++-- | QuasiQuoter for creating a tessellation control shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "tesc" Nothing [glsl|...|])@ without+-- interpolation support.+tesc :: QuasiQuoter+tesc = shaderQQ "tesc"++-- | QuasiQuoter for creating a tessellation evaluation shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "tese" Nothing [glsl|...|])@ without+-- interpolation support.+tese :: QuasiQuoter+tese = shaderQQ "tese"++-- | QuasiQuoter for creating a vertex shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "vert" Nothing [glsl|...|])@ without+-- interpolation support.+vert :: QuasiQuoter+vert = shaderQQ "vert"++-- | QuasiQuoter for creating a ray generation shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rgen" Nothing [glsl|...|])@ without+-- interpolation support.+rgen :: QuasiQuoter+rgen = rayShaderQQ "rgen"++-- | QuasiQuoter for creating an intersection shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rint" Nothing [glsl|...|])@ without+-- interpolation support.+rint :: QuasiQuoter+rint = rayShaderQQ "rint"++-- | QuasiQuoter for creating an any-hit shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rahit" Nothing [glsl|...|])@ without+-- interpolation support.+rahit :: QuasiQuoter+rahit = rayShaderQQ "rahit"++-- | QuasiQuoter for creating a closest hit shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rchit" Nothing [glsl|...|])@ without+-- interpolation support.+rchit :: QuasiQuoter+rchit = rayShaderQQ "rchit"++-- | QuasiQuoter for creating a miss shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rmiss" Nothing [glsl|...|])@ without+-- interpolation support.+rmiss :: QuasiQuoter+rmiss = rayShaderQQ "rmiss"++-- | QuasiQuoter for creating a callable shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rcall" Nothing [glsl|...|])@ without+-- interpolation support.+rcall :: QuasiQuoter+rcall = rayShaderQQ "rcall"++-- | QuasiQuoter for creating a task shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "task" Nothing [glsl|...|])@ without+-- interpolation support.+task :: QuasiQuoter+task = shaderQQ "task"++-- | QuasiQuoter for creating a mesh shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "mesh" Nothing [glsl|...|])@ without+-- interpolation support.+mesh :: QuasiQuoter+mesh = shaderQQ "mesh"++shaderQQ :: String -> QuasiQuoter+shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ Nothing stage Nothing }++rayShaderQQ :: String -> QuasiQuoter+rayShaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ (Just "spirv1.4") stage Nothing }++-- * Utilities++-- | Compile a GLSL shader to spir-v using glslangValidator.+--+-- Messages are converted to GHC warnings or errors depending on compilation success.+compileShaderQ+  :: Maybe String+  -- ^ Argument to pass to `--target-env`+  -> String+  -- ^ stage+  -> Maybe String+  -- ^ Argument name to pass to `-e name --source-entry-point main` to specify entry-point function name+  -> String+  -- ^ glsl shader code+  -> Q Exp+  -- ^ Spir-V bytecode+compileShaderQ targetEnv = Glslang.compileShaderQ targetEnv GLSL++-- | Compile a GLSL shader to spir-v using glslangValidator.+compileShader+  :: MonadIO m+  => Maybe Loc+  -- ^ Source location+  -> Maybe String+  -- ^ Argument to pass to `--target-env`+  -> String+  -- ^ stage+  -> Maybe String+  -- ^ Argument name to pass to `-e name --source-entry-point main` to specify entry-point function name+  -> String+  -- ^ glsl shader code+  -> m ([GlslangWarning], Either [GlslangError] ByteString)+  -- ^ Spir-V bytecode with warnings or errors+compileShader loc targetEnv = Glslang.compileShader loc targetEnv GLSL
+ src/Vulkan/Utils/ShaderQQ/GLSL/Shaderc.hs view
@@ -0,0 +1,198 @@+module Vulkan.Utils.ShaderQQ.GLSL.Shaderc+  ( glsl+  , comp+  , frag+  , geom+  , tesc+  , tese+  , vert+  , rgen+  , rint+  , rahit+  , rchit+  , rmiss+  , rcall+  , task+  , mesh+  , compileShaderQ+  , compileShader+  ) where++import           Control.Monad.IO.Class+import           Data.ByteString                                 ( ByteString )+import           Language.Haskell.TH+import           Language.Haskell.TH.Quote+import           Vulkan.Utils.Internal                           ( badQQ )+import           Vulkan.Utils.ShaderQQ.ShaderType+import           Vulkan.Utils.ShaderQQ.Backend.Shaderc           ( ShadercError, ShadercWarning )+import qualified Vulkan.Utils.ShaderQQ.Backend.Shaderc.Internal as Shaderc+import qualified Vulkan.Utils.ShaderQQ.GLSL                     as GLSL++-- $setup+-- >>> :set -XQuasiQuotes++-- | 'glsl' is a QuasiQuoter which produces GLSL source code with @#line@+-- directives 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 Nothing "frag" [glsl|+--   #version 450+--   const float myConstant = ${myConstant};+--   main (){+--   }+-- |])+-- @+--+-- 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 52 \"<interactive>\"\n"+--+-- Note that line number will be thrown off if any of the interpolated+-- variables contain newlines.+glsl :: QuasiQuoter+glsl = GLSL.glsl++-- | QuasiQuoter for creating a compute shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "comp" [glsl|...|])@ without+-- interpolation support.+comp :: QuasiQuoter+comp = shaderQQ "comp"++-- | QuasiQuoter for creating a fragment shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "frag" [glsl|...|])@ without+-- interpolation support.+frag :: QuasiQuoter+frag = shaderQQ "frag"++-- | QuasiQuoter for creating a geometry shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "geom" [glsl|...|])@ without+-- interpolation support.+geom :: QuasiQuoter+geom = shaderQQ "geom"++-- | QuasiQuoter for creating a tessellation control shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "tesc" [glsl|...|])@ without+-- interpolation support.+tesc :: QuasiQuoter+tesc = shaderQQ "tesc"++-- | QuasiQuoter for creating a tessellation evaluation shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "tese" [glsl|...|])@ without+-- interpolation support.+tese :: QuasiQuoter+tese = shaderQQ "tese"++-- | QuasiQuoter for creating a vertex shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "vert" [glsl|...|])@ without+-- interpolation support.+vert :: QuasiQuoter+vert = shaderQQ "vert"++-- | QuasiQuoter for creating a ray generation shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rgen" [glsl|...|])@ without+-- interpolation support.+rgen :: QuasiQuoter+rgen = rayShaderQQ "rgen"++-- | QuasiQuoter for creating an intersection shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rint" [glsl|...|])@ without+-- interpolation support.+rint :: QuasiQuoter+rint = rayShaderQQ "rint"++-- | QuasiQuoter for creating an any-hit shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rahit" [glsl|...|])@ without+-- interpolation support.+rahit :: QuasiQuoter+rahit = rayShaderQQ "rahit"++-- | QuasiQuoter for creating a closest hit shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rchit" [glsl|...|])@ without+-- interpolation support.+rchit :: QuasiQuoter+rchit = rayShaderQQ "rchit"++-- | QuasiQuoter for creating a miss shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rmiss" [glsl|...|])@ without+-- interpolation support.+rmiss :: QuasiQuoter+rmiss = rayShaderQQ "rmiss"++-- | QuasiQuoter for creating a callable shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rcall" [glsl|...|])@ without+-- interpolation support.+rcall :: QuasiQuoter+rcall = rayShaderQQ "rcall"++-- | QuasiQuoter for creating a task shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "task" [glsl|...|])@ without+-- interpolation support.+task :: QuasiQuoter+task = shaderQQ "task"++-- | QuasiQuoter for creating a mesh shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "mesh" [glsl|...|])@ without+-- interpolation support.+mesh :: QuasiQuoter+mesh = shaderQQ "mesh"++shaderQQ :: String -> QuasiQuoter+shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ Nothing stage }++rayShaderQQ :: String -> QuasiQuoter+rayShaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ (Just "spv1.4") stage }++-- * Utilities++-- | Compile a GLSL shader to spir-v using glslc.+--+-- Messages are converted to GHC warnings or errors depending on compilation success.+compileShaderQ+  :: Maybe String+  -- ^ Argument to pass to `--target-env`+  -> String+  -- ^ stage+  -> String+  -- ^ glsl shader code+  -> Q Exp+  -- ^ Spir-V bytecode+compileShaderQ targetEnv stage = Shaderc.compileShaderQ targetEnv GLSL stage Nothing++-- | Compile a GLSL shader to spir-v using glslc.+compileShader+  :: MonadIO m+  => Maybe Loc+  -- ^ Source location+  -> Maybe String+  -- ^ Argument to pass to `--target-env`+  -> String+  -- ^ stage+  -> String+  -- ^ glsl shader code+  -> m ([ShadercWarning], Either [ShadercError] ByteString)+  -- ^ Spir-V bytecode with warnings or errors+compileShader loc targetEnv stage = Shaderc.compileShader loc targetEnv GLSL stage Nothing
+ src/Vulkan/Utils/ShaderQQ/HLSL.hs view
@@ -0,0 +1,42 @@+module Vulkan.Utils.ShaderQQ.HLSL+  ( hlsl+  , insertLineDirective+  ) where++import           Language.Haskell.TH+import           Language.Haskell.TH.Quote+import           Vulkan.Utils.Internal                  ( badQQ )+import           Vulkan.Utils.ShaderQQ.Interpolate++-- | '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 @\\$@+--+-- An explicit example (@<interactive>@ is from doctest):+--+-- >>> let foo = 450 :: Int in [hlsl|const float foo = $foo|]+-- "#line 77 \"<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+  }++-- 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
+ src/Vulkan/Utils/ShaderQQ/HLSL/Glslang.hs view
@@ -0,0 +1,199 @@+module Vulkan.Utils.ShaderQQ.HLSL.Glslang+  ( hlsl+  , comp+  , frag+  , geom+  , tesc+  , tese+  , vert+  , rgen+  , rint+  , rahit+  , rchit+  , rmiss+  , rcall+  , task+  , mesh+  , compileShaderQ+  , compileShader+  ) where++import           Control.Monad.IO.Class+import           Data.ByteString                                 ( ByteString )+import           Language.Haskell.TH+import           Language.Haskell.TH.Quote+import           Vulkan.Utils.Internal                           ( badQQ )+import           Vulkan.Utils.ShaderQQ.ShaderType+import           Vulkan.Utils.ShaderQQ.Backend.Glslang           ( GlslangError, GlslangWarning )+import qualified Vulkan.Utils.ShaderQQ.Backend.Glslang.Internal as Glslang+import qualified Vulkan.Utils.ShaderQQ.HLSL                     as HLSL++-- | '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 Nothing "frag" (Just "main") [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 37 \"<interactive>\"\nconst float foo = 450"+--+-- Note that line number will be thrown off if any of the interpolated+-- variables contain newlines.+hlsl :: QuasiQuoter+hlsl = HLSL.hlsl++-- | QuasiQuoter for creating a compute shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "comp" (Just "main") [hlsl|...|])@ without+-- interpolation support.+comp :: QuasiQuoter+comp = shaderQQ "comp"++-- | QuasiQuoter for creating a fragment shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "frag" (Just "main") [hlsl|...|])@ without+-- interpolation support.+frag :: QuasiQuoter+frag = shaderQQ "frag"++-- | QuasiQuoter for creating a geometry shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "geom" (Just "main") [hlsl|...|])@ without+-- interpolation support.+geom :: QuasiQuoter+geom = shaderQQ "geom"++-- | QuasiQuoter for creating a tessellation control shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "tesc" (Just "main") [hlsl|...|])@ without+-- interpolation support.+tesc :: QuasiQuoter+tesc = shaderQQ "tesc"++-- | QuasiQuoter for creating a tessellation evaluation shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "tese" (Just "main") [hlsl|...|])@ without+-- interpolation support.+tese :: QuasiQuoter+tese = shaderQQ "tese"++-- | QuasiQuoter for creating a vertex shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "vert" (Just "main") [hlsl|...|])@ without+-- interpolation support.+vert :: QuasiQuoter+vert = shaderQQ "vert"++-- | QuasiQuoter for creating a ray generation shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rgen" (Just "main") [hlsl|...|])@ without+-- interpolation support.+rgen :: QuasiQuoter+rgen = rayShaderQQ "rgen"++-- | QuasiQuoter for creating an intersection shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rint" (Just "main") [hlsl|...|])@ without+-- interpolation support.+rint :: QuasiQuoter+rint = rayShaderQQ "rint"++-- | QuasiQuoter for creating an any-hit shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rahit" (Just "main") [hlsl|...|])@ without+-- interpolation support.+rahit :: QuasiQuoter+rahit = rayShaderQQ "rahit"++-- | QuasiQuoter for creating a closest hit shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rchit" (Just "main") [hlsl|...|])@ without+-- interpolation support.+rchit :: QuasiQuoter+rchit = rayShaderQQ "rchit"++-- | QuasiQuoter for creating a miss shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rmiss" (Just "main") [hlsl|...|])@ without+-- interpolation support.+rmiss :: QuasiQuoter+rmiss = rayShaderQQ "rmiss"++-- | QuasiQuoter for creating a callable shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spirv1.4") "rcall" (Just "main") [hlsl|...|])@ without+-- interpolation support.+rcall :: QuasiQuoter+rcall = rayShaderQQ "rcall"++-- | QuasiQuoter for creating a task shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "task" (Just "main") [hlsl|...|])@ without+-- interpolation support.+task :: QuasiQuoter+task = shaderQQ "task"++-- | QuasiQuoter for creating a mesh shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "mesh" (Just "main") [hlsl|...|])@ without+-- interpolation support.+mesh :: QuasiQuoter+mesh = shaderQQ "mesh"++shaderQQ :: String -> QuasiQuoter+shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ Nothing stage (Just "main") }++rayShaderQQ :: String -> QuasiQuoter+rayShaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ (Just "spirv1.4") stage (Just "main") }++-- * Utilities++-- | Compile a HLSL shader to spir-v using glslangValidator.+--+-- Messages are converted to GHC warnings or errors depending on compilation success.+compileShaderQ+  :: Maybe String+  -- ^ Argument to pass to `--target-env`+  -> String+  -- ^ stage+  -> Maybe String+  -- ^ Argument name to pass to `-e name` to specify entry-point function name+  -> String+  -- ^ hlsl shader code+  -> Q Exp+  -- ^ Spir-V bytecode+compileShaderQ targetEnv = Glslang.compileShaderQ targetEnv HLSL++-- | Compile a HLSL shader to spir-v using glslangValidator.+compileShader+  :: MonadIO m+  => Maybe Loc+  -- ^ Source location+  -> Maybe String+  -- ^ Argument to pass to `--target-env`+  -> String+  -- ^ stage+  -> Maybe String+  -- ^ Argument name to pass to `-e name` to specify entry-point function name+  -> String+  -- ^ hlsl shader code+  -> m ([GlslangWarning], Either [GlslangError] ByteString)+  -- ^ Spir-V bytecode with warnings or errors+compileShader loc targetEnv = Glslang.compileShader loc targetEnv HLSL
+ src/Vulkan/Utils/ShaderQQ/HLSL/Shaderc.hs view
@@ -0,0 +1,199 @@+module Vulkan.Utils.ShaderQQ.HLSL.Shaderc+  ( hlsl+  , comp+  , frag+  , geom+  , tesc+  , tese+  , vert+  , rgen+  , rint+  , rahit+  , rchit+  , rmiss+  , rcall+  , task+  , mesh+  , compileShaderQ+  , compileShader+  ) where++import           Control.Monad.IO.Class+import           Data.ByteString                                 ( ByteString )+import           Language.Haskell.TH+import           Language.Haskell.TH.Quote+import           Vulkan.Utils.Internal                           ( badQQ )+import           Vulkan.Utils.ShaderQQ.ShaderType+import           Vulkan.Utils.ShaderQQ.Backend.Shaderc           ( ShadercError, ShadercWarning )+import qualified Vulkan.Utils.ShaderQQ.Backend.Shaderc.Internal as Shaderc+import qualified Vulkan.Utils.ShaderQQ.HLSL                     as HLSL++-- | '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 Nothing "frag" Nothing [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 57 \"<interactive>\"\nconst float foo = 450"+--+-- Note that line number will be thrown off if any of the interpolated+-- variables contain newlines.+hlsl :: QuasiQuoter+hlsl = HLSL.hlsl++-- | QuasiQuoter for creating a compute shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "comp" Nothing [hlsl|...|])@ without+-- interpolation support.+comp :: QuasiQuoter+comp = shaderQQ "comp"++-- | QuasiQuoter for creating a fragment shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "frag" Nothing [hlsl|...|])@ without+-- interpolation support.+frag :: QuasiQuoter+frag = shaderQQ "frag"++-- | QuasiQuoter for creating a geometry shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "geom" Nothing [hlsl|...|])@ without+-- interpolation support.+geom :: QuasiQuoter+geom = shaderQQ "geom"++-- | QuasiQuoter for creating a tessellation control shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "tesc" Nothing [hlsl|...|])@ without+-- interpolation support.+tesc :: QuasiQuoter+tesc = shaderQQ "tesc"++-- | QuasiQuoter for creating a tessellation evaluation shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "tese" Nothing [hlsl|...|])@ without+-- interpolation support.+tese :: QuasiQuoter+tese = shaderQQ "tese"++-- | QuasiQuoter for creating a vertex shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "vert" Nothing [hlsl|...|])@ without+-- interpolation support.+vert :: QuasiQuoter+vert = shaderQQ "vert"++-- | QuasiQuoter for creating a ray generation shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rgen" Nothing [hlsl|...|])@ without+-- interpolation support.+rgen :: QuasiQuoter+rgen = rayShaderQQ "rgen"++-- | QuasiQuoter for creating an intersection shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rint" Nothing [hlsl|...|])@ without+-- interpolation support.+rint :: QuasiQuoter+rint = rayShaderQQ "rint"++-- | QuasiQuoter for creating an any-hit shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rahit" Nothing [hlsl|...|])@ without+-- interpolation support.+rahit :: QuasiQuoter+rahit = rayShaderQQ "rahit"++-- | QuasiQuoter for creating a closest hit shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rchit" Nothing [hlsl|...|])@ without+-- interpolation support.+rchit :: QuasiQuoter+rchit = rayShaderQQ "rchit"++-- | QuasiQuoter for creating a miss shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rmiss" Nothing [hlsl|...|])@ without+-- interpolation support.+rmiss :: QuasiQuoter+rmiss = rayShaderQQ "rmiss"++-- | QuasiQuoter for creating a callable shader.+--+-- Equivalent to calling @$(compileShaderQ (Just "spv1.4") "rcall" Nothing [hlsl|...|])@ without+-- interpolation support.+rcall :: QuasiQuoter+rcall = rayShaderQQ "rcall"++-- | QuasiQuoter for creating a task shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "task" Nothing [hlsl|...|])@ without+-- interpolation support.+task :: QuasiQuoter+task = shaderQQ "task"++-- | QuasiQuoter for creating a mesh shader.+--+-- Equivalent to calling @$(compileShaderQ Nothing "mesh" Nothing [hlsl|...|])@ without+-- interpolation support.+mesh :: QuasiQuoter+mesh = shaderQQ "mesh"++shaderQQ :: String -> QuasiQuoter+shaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ Nothing stage Nothing }++rayShaderQQ :: String -> QuasiQuoter+rayShaderQQ stage = (badQQ stage) { quoteExp = compileShaderQ (Just "spv1.4") stage Nothing }++-- * Utilities++-- | Compile a HLSL shader to spir-v using glslc.+--+-- Messages are converted to GHC warnings or errors depending on compilation success.+compileShaderQ+  :: Maybe String+  -- ^ Argument to pass to `--target-env`+  -> String+  -- ^ stage+  -> Maybe String+  -- ^ Argument to pass to `-fentry-point=` to specify entry-point function name+  -> String+  -- ^ hlsl shader code+  -> Q Exp+  -- ^ Spir-V bytecode+compileShaderQ targetEnv = Shaderc.compileShaderQ targetEnv HLSL++-- | Compile a HLSL shader to spir-v using glslc.+compileShader+  :: MonadIO m+  => Maybe Loc+  -- ^ Source location+  -> Maybe String+  -- ^ Argument to pass to `--target-env`+  -> String+  -- ^ stage+  -> Maybe String+  -- ^ Argument to pass to `-fentry-point=` to specify entry-point function name+  -> String+  -- ^ hlsl shader code+  -> m ([ShadercWarning], Either [ShadercError] ByteString)+  -- ^ Spir-V bytecode with warnings or errors+compileShader loc targetEnv = Shaderc.compileShader loc targetEnv HLSL
+ src/Vulkan/Utils/ShaderQQ/ShaderType.hs view
@@ -0,0 +1,20 @@+module Vulkan.Utils.ShaderQQ.ShaderType+  ( ShaderType (..)+  ) where++import           Data.String (IsString (..))++data ShaderType+  = GLSL+  | HLSL++instance IsString ShaderType where+  fromString = \case+    "glsl" -> GLSL+    "hlsl" -> HLSL+    t -> error $ "not support '" ++ t ++ "' shader"++instance Show ShaderType where+  show = \case+    GLSL -> "glsl"+    HLSL -> "hlsl"
− src/Vulkan/Utils/ShaderQQ/Shaderc.hs 
@@ -1,285 +0,0 @@-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"
vulkan-utils.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           vulkan-utils-version:        0.4.2+version:        0.5.0 synopsis:       Utils for the vulkan package category:       Graphics homepage:       https://github.com/expipiplus1/vulkan#readme@@ -40,9 +40,19 @@       Vulkan.Utils.QueueAssignment       Vulkan.Utils.Requirements       Vulkan.Utils.Requirements.TH-      Vulkan.Utils.ShaderQQ+      Vulkan.Utils.ShaderQQ.Backend.Glslang+      Vulkan.Utils.ShaderQQ.Backend.Glslang.Internal+      Vulkan.Utils.ShaderQQ.Backend.Internal+      Vulkan.Utils.ShaderQQ.Backend.Shaderc+      Vulkan.Utils.ShaderQQ.Backend.Shaderc.Internal+      Vulkan.Utils.ShaderQQ.GLSL+      Vulkan.Utils.ShaderQQ.GLSL.Glslang+      Vulkan.Utils.ShaderQQ.GLSL.Shaderc+      Vulkan.Utils.ShaderQQ.HLSL+      Vulkan.Utils.ShaderQQ.HLSL.Glslang+      Vulkan.Utils.ShaderQQ.HLSL.Shaderc       Vulkan.Utils.ShaderQQ.Interpolate-      Vulkan.Utils.ShaderQQ.Shaderc+      Vulkan.Utils.ShaderQQ.ShaderType   other-modules:       Vulkan.Utils.Internal   hs-source-dirs: