diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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` diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -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 diff --git a/src/Vulkan/Utils/ShaderQQ.hs b/src/Vulkan/Utils/ShaderQQ.hs deleted file mode 100644 --- a/src/Vulkan/Utils/ShaderQQ.hs +++ /dev/null @@ -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 (@@ 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 \"\"\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 diff --git a/src/Vulkan/Utils/ShaderQQ/Backend/Glslang.hs b/src/Vulkan/Utils/ShaderQQ/Backend/Glslang.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/ShaderQQ/Backend/Glslang.hs @@ -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 diff --git a/src/Vulkan/Utils/ShaderQQ/Backend/Glslang/Internal.hs b/src/Vulkan/Utils/ShaderQQ/Backend/Glslang/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/ShaderQQ/Backend/Glslang/Internal.hs @@ -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) diff --git a/src/Vulkan/Utils/ShaderQQ/Backend/Internal.hs b/src/Vulkan/Utils/ShaderQQ/Backend/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/ShaderQQ/Backend/Internal.hs @@ -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 diff --git a/src/Vulkan/Utils/ShaderQQ/Backend/Shaderc.hs b/src/Vulkan/Utils/ShaderQQ/Backend/Shaderc.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/ShaderQQ/Backend/Shaderc.hs @@ -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 diff --git a/src/Vulkan/Utils/ShaderQQ/Backend/Shaderc/Internal.hs b/src/Vulkan/Utils/ShaderQQ/Backend/Shaderc/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/ShaderQQ/Backend/Shaderc/Internal.hs @@ -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) diff --git a/src/Vulkan/Utils/ShaderQQ/GLSL.hs b/src/Vulkan/Utils/ShaderQQ/GLSL.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/ShaderQQ/GLSL.hs @@ -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 (@@ 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 \"\"\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 diff --git a/src/Vulkan/Utils/ShaderQQ/GLSL/Glslang.hs b/src/Vulkan/Utils/ShaderQQ/GLSL/Glslang.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/ShaderQQ/GLSL/Glslang.hs @@ -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 (@@ 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 \"\"\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 diff --git a/src/Vulkan/Utils/ShaderQQ/GLSL/Shaderc.hs b/src/Vulkan/Utils/ShaderQQ/GLSL/Shaderc.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/ShaderQQ/GLSL/Shaderc.hs @@ -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 (@@ 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 \"\"\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 diff --git a/src/Vulkan/Utils/ShaderQQ/HLSL.hs b/src/Vulkan/Utils/ShaderQQ/HLSL.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/ShaderQQ/HLSL.hs @@ -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 (@@ is from doctest): +-- +-- >>> let foo = 450 :: Int in [hlsl|const float foo = $foo|] +-- "#line 77 \"\"\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 diff --git a/src/Vulkan/Utils/ShaderQQ/HLSL/Glslang.hs b/src/Vulkan/Utils/ShaderQQ/HLSL/Glslang.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/ShaderQQ/HLSL/Glslang.hs @@ -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 (@@ is from doctest): +-- +-- >>> let foo = 450 :: Int in [hlsl|const float foo = $foo|] +-- "#line 37 \"\"\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 diff --git a/src/Vulkan/Utils/ShaderQQ/HLSL/Shaderc.hs b/src/Vulkan/Utils/ShaderQQ/HLSL/Shaderc.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/ShaderQQ/HLSL/Shaderc.hs @@ -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 (@@ is from doctest): +-- +-- >>> let foo = 450 :: Int in [hlsl|const float foo = $foo|] +-- "#line 57 \"\"\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 diff --git a/src/Vulkan/Utils/ShaderQQ/ShaderType.hs b/src/Vulkan/Utils/ShaderQQ/ShaderType.hs new file mode 100644 --- /dev/null +++ b/src/Vulkan/Utils/ShaderQQ/ShaderType.hs @@ -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" diff --git a/src/Vulkan/Utils/ShaderQQ/Shaderc.hs b/src/Vulkan/Utils/ShaderQQ/Shaderc.hs deleted file mode 100644 --- a/src/Vulkan/Utils/ShaderQQ/Shaderc.hs +++ /dev/null @@ -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 (@@ is from doctest): --- --- >>> let foo = 450 :: Int in [hlsl|const float foo = $foo|] --- "#line 31 \"\"\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" diff --git a/vulkan-utils.cabal b/vulkan-utils.cabal --- a/vulkan-utils.cabal +++ b/vulkan-utils.cabal @@ -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: