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
compileShaderQ
:: Maybe String
-> ShaderType
-> String
-> Maybe String
-> String
-> Q Exp
compileShaderQ :: Maybe String
-> ShaderType -> String -> Maybe String -> String -> Q Exp
compileShaderQ targetEnv :: Maybe String
targetEnv shaderType :: ShaderType
shaderType stage :: String
stage entryPoint :: Maybe String
entryPoint code :: String
code = do
Loc
loc <- Q Loc
location
(warnings :: [String]
warnings, result :: Either [String] ByteString
result) <- Maybe Loc
-> Maybe String
-> ShaderType
-> String
-> Maybe String
-> String
-> Q ([String], Either [String] ByteString)
forall (m :: * -> *).
MonadIO m =>
Maybe Loc
-> Maybe String
-> ShaderType
-> String
-> Maybe String
-> String
-> m ([String], Either [String] ByteString)
compileShader (Loc -> Maybe Loc
forall a. a -> Maybe a
Just Loc
loc) Maybe String
targetEnv ShaderType
shaderType String
stage Maybe String
entryPoint String
code
ByteString
bs <- String
-> (String -> Q ())
-> (String -> Q ByteString)
-> ([String], Either [String] ByteString)
-> Q ByteString
forall (m :: * -> *).
(Applicative m, Monad m) =>
String
-> (String -> m ())
-> (String -> m ByteString)
-> ([String], Either [String] ByteString)
-> m ByteString
messageProcess "glslangValidator" String -> Q ()
reportWarning String -> Q ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ([String]
warnings, Either [String] ByteString
result)
ByteString -> Q Exp
bsToExp ByteString
bs
compileShader
:: MonadIO m
=> Maybe Loc
-> Maybe String
-> ShaderType
-> String
-> Maybe String
-> String
-> m ([GlslangWarning], Either [GlslangError] ByteString)
compileShader :: Maybe Loc
-> Maybe String
-> ShaderType
-> String
-> Maybe String
-> String
-> m ([String], Either [String] ByteString)
compileShader loc :: Maybe Loc
loc targetEnv :: Maybe String
targetEnv shaderType :: ShaderType
shaderType stage :: String
stage entryPoint :: Maybe String
entryPoint code :: String
code =
IO ([String], Either [String] ByteString)
-> m ([String], Either [String] ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([String], Either [String] ByteString)
-> m ([String], Either [String] ByteString))
-> IO ([String], Either [String] ByteString)
-> m ([String], Either [String] ByteString)
forall a b. (a -> b) -> a -> b
$ String
-> (String -> IO ([String], Either [String] ByteString))
-> IO ([String], Either [String] ByteString)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory "th-shader" ((String -> IO ([String], Either [String] ByteString))
-> IO ([String], Either [String] ByteString))
-> (String -> IO ([String], Either [String] ByteString))
-> IO ([String], Either [String] ByteString)
forall a b. (a -> b) -> a -> b
$ \dir :: String
dir -> do
let codeWithLineDirective :: String
codeWithLineDirective = String -> (Loc -> String) -> Maybe Loc -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
code (case ShaderType
shaderType of
GLSL -> String -> Loc -> String
GLSL.insertLineDirective String
code
HLSL -> String -> Loc -> String
HLSL.insertLineDirective String
code
) Maybe Loc
loc
let shader :: String
shader = String
dir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "/shader." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
stage
spirv :: String
spirv = String
dir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "/shader.spv"
String -> String -> IO ()
writeFile String
shader String
codeWithLineDirective
let targetArgs :: [String]
targetArgs = case Maybe String
targetEnv of
Nothing -> []
Just t :: String
t -> ["--target-env", String
t]
shaderTypeArgs :: [String]
shaderTypeArgs = case ShaderType
shaderType of
GLSL -> []
HLSL -> ["-D"]
entryPointArgs :: [String]
entryPointArgs = case Maybe String
entryPoint of
Nothing -> []
Just name :: String
name -> case ShaderType
shaderType of
GLSL -> ["-e", String
name, "--source-entry-point", "main"]
HLSL -> ["-e", String
name]
args :: [String]
args = [String]
targetArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
shaderTypeArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
entryPointArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["-S", String
stage, "-V", String
shader, "-o", String
spirv]
(rc :: ExitCode
rc, out :: ByteString
out, err :: ByteString
err) <- ProcessConfig () () () -> IO (ExitCode, ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, ByteString, ByteString)
readProcess (ProcessConfig () () () -> IO (ExitCode, ByteString, ByteString))
-> ProcessConfig () () () -> IO (ExitCode, ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> ProcessConfig () () ()
proc "glslangValidator" [String]
args
let (warnings :: [String]
warnings, errors :: [String]
errors) = ByteString -> ([String], [String])
processGlslangMessages (ByteString
out ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
err)
case ExitCode
rc of
ExitSuccess -> do
ByteString
bs <- String -> IO ByteString
BS.readFile String
spirv
([String], Either [String] ByteString)
-> IO ([String], Either [String] ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String]
warnings, ByteString -> Either [String] ByteString
forall a b. b -> Either a b
Right ByteString
bs)
ExitFailure _rc :: Int
_rc -> ([String], Either [String] ByteString)
-> IO ([String], Either [String] ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String]
warnings, [String] -> Either [String] ByteString
forall a b. a -> Either a b
Left [String]
errors)