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.ShaderQQ.Interpolate
glsl :: QuasiQuoter
glsl :: QuasiQuoter
glsl = (String -> QuasiQuoter
badQQ "glsl")
{ quoteExp :: String -> Q Exp
quoteExp = \s :: String
s -> do
Loc
loc <- Q Loc
location
let codeWithLineDirective :: String
codeWithLineDirective = String -> Loc -> String
insertLineDirective String
s Loc
loc
String -> Q Exp
interpExp String
codeWithLineDirective
}
comp :: QuasiQuoter
comp :: QuasiQuoter
comp = String -> QuasiQuoter
shaderQQ "comp"
frag :: QuasiQuoter
frag :: QuasiQuoter
frag = String -> QuasiQuoter
shaderQQ "frag"
geom :: QuasiQuoter
geom :: QuasiQuoter
geom = String -> QuasiQuoter
shaderQQ "geom"
tesc :: QuasiQuoter
tesc :: QuasiQuoter
tesc = String -> QuasiQuoter
shaderQQ "tesc"
tese :: QuasiQuoter
tese :: QuasiQuoter
tese = String -> QuasiQuoter
shaderQQ "tese"
vert :: QuasiQuoter
vert :: QuasiQuoter
vert = String -> QuasiQuoter
shaderQQ "vert"
shaderQQ :: String -> QuasiQuoter
shaderQQ :: String -> QuasiQuoter
shaderQQ stage :: String
stage = (String -> QuasiQuoter
badQQ String
stage) { quoteExp :: String -> Q Exp
quoteExp = String -> String -> Q Exp
compileShaderQ String
stage }
compileShaderQ
:: String
-> String
-> Q Exp
compileShaderQ :: String -> String -> Q Exp
compileShaderQ stage :: String
stage code :: String
code = do
Loc
loc <- Q Loc
location
(warnings :: [String]
warnings, result :: Either [String] ByteString
result) <- Maybe Loc
-> String -> String -> Q ([String], Either [String] ByteString)
forall (m :: * -> *).
MonadIO m =>
Maybe Loc
-> String -> String -> m ([String], Either [String] ByteString)
compileShader (Loc -> Maybe Loc
forall a. a -> Maybe a
Just Loc
loc) String
stage String
code
case [String]
warnings of
[] -> () -> Q ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
_some :: [String]
_some -> String -> Q ()
reportWarning (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
prepare [String]
warnings
ByteString
bs <- case Either [String] ByteString
result of
Left [] -> String -> Q ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "glslangValidator failed with no errors"
Left errors :: [String]
errors -> do
String -> Q ()
reportError (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
prepare [String]
errors
ByteString -> Q ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
forall a. Monoid a => a
mempty
Right bs :: ByteString
bs -> ByteString -> Q ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
ByteString -> Q Exp
bsToExp ByteString
bs
where
prepare :: [String] -> String
prepare [singleLine :: String
singleLine] = String
singleLine
prepare multiline :: [String]
multiline =
String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ "glslangValidator:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a. Monoid a => a -> a -> a
mappend " ") [String]
multiline
type GLSLError = String
type GLSLWarning = String
compileShader
:: MonadIO m
=> Maybe Loc
-> String
-> String
-> m ([GLSLWarning], Either [GLSLError] ByteString)
compileShader :: Maybe Loc
-> String -> String -> m ([String], Either [String] ByteString)
compileShader loc :: Maybe Loc
loc stage :: String
stage 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 (String -> Loc -> String
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
(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" ["-S", String
stage, "-V", String
shader, "-o", String
spirv]
let (warnings :: [String]
warnings, errors :: [String]
errors) = ByteString -> ([String], [String])
processValidatorMessages (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)
processValidatorMessages :: BSL.ByteString -> ([GLSLWarning], [GLSLError])
processValidatorMessages :: ByteString -> ([String], [String])
processValidatorMessages = (String -> ([String], [String]) -> ([String], [String]))
-> ([String], [String]) -> [String] -> ([String], [String])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr String -> ([String], [String]) -> ([String], [String])
grep ([], []) ([String] -> ([String], [String]))
-> (ByteString -> [String]) -> ByteString -> ([String], [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String])
-> (ByteString -> [String]) -> ByteString -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String])
-> (ByteString -> String) -> ByteString -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BSL.unpack
where
grep :: String -> ([String], [String]) -> ([String], [String])
grep line :: String
line (ws :: [String]
ws, es :: [String]
es)
| "WARNING: " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
line = (String -> String
cut String
line String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
ws, [String]
es)
| "ERROR: " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
line = ([String]
ws, String -> String
cut String
line String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
es)
| Bool
otherwise = ([String]
ws, [String]
es)
cut :: String -> String
cut line :: String
line = String -> String
takeFileName String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg
where
(path :: String
path, msg :: String
msg) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ':') (String -> (String, String))
-> (String -> String) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop 1 (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ' ') String
line
insertLineDirective :: String -> Loc -> String
insertLineDirective :: String -> Loc -> String
insertLineDirective code :: String
code Loc {..} =
let isVersionDirective :: String -> Bool
isVersionDirective = ("#version" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace
codeLines :: [String]
codeLines = String -> [String]
lines String
code
(beforeVersion :: [String]
beforeVersion, afterVersion :: [String]
afterVersion) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break String -> Bool
isVersionDirective [String]
codeLines
lineDirective :: [String]
lineDirective =
[ "#extension GL_GOOGLE_cpp_style_line_directive : enable"
, "#line "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (CharPos -> Int
forall a b. (a, b) -> a
fst CharPos
loc_start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
beforeVersion Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> " \""
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
loc_filename
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "\""
]
in case [String]
afterVersion of
[] -> String
code
v :: String
v : xs :: [String]
xs -> [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
beforeVersion [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String
v] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
lineDirective [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
xs
badQQ :: String -> QuasiQuoter
badQQ :: String -> QuasiQuoter
badQQ name :: String
name = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter (String -> String -> Q Exp
forall a. String -> a
bad "expression")
(String -> String -> Q Pat
forall a. String -> a
bad "pattern")
(String -> String -> Q Type
forall a. String -> a
bad "type")
(String -> String -> Q [Dec]
forall a. String -> a
bad "declaration")
where
bad :: String -> a
bad :: String -> a
bad context :: String
context =
String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ "Can't use " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> " quote in a " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
context String -> String -> String
forall a. Semigroup a => a -> a -> a
<> " context"