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.Backend.Internal
import Vulkan.Utils.ShaderQQ.Backend.Shaderc
import qualified Vulkan.Utils.ShaderQQ.GLSL as GLSL
import qualified Vulkan.Utils.ShaderQQ.HLSL as HLSL
import Vulkan.Utils.ShaderQQ.ShaderType

-- * 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
  -> 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 :: Maybe String
-> ShaderType -> String -> Maybe String -> String -> Q Exp
compileShaderQ Maybe String
targetSpv ShaderType
shaderType String
stage Maybe String
entryPoint String
code = do
  loc <- Q 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
  -> 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 :: forall (m :: * -> *).
MonadIO m =>
Maybe Loc
-> Maybe String
-> ShaderType
-> String
-> Maybe String
-> String
-> m ([String], Either [String] ByteString)
compileShader Maybe Loc
loc Maybe String
targetSpv ShaderType
shaderType String
stage Maybe String
entryPoint String
code =
  IO ([String], Either [String] ByteString)
-> m ([String], Either [String] ByteString)
forall a. IO a -> m a
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 String
"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
$ \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
                ShaderType
GLSL -> String -> Loc -> String
GLSL.insertLineDirective String
code
                ShaderType
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
<> String
"/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
<> String
"/shader.spv"
    String -> String -> IO ()
writeFile String
shader String
codeWithLineDirective

    let
      targetArgs :: [String]
targetArgs = case Maybe String
targetSpv of
        Maybe String
Nothing -> []
        Just String
t -> [String
"--target-spv=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
t]
      -- https://github.com/google/shaderc/blob/01dd72d6079ebdc0f96859365ba7abb1b62758bf/glslc/src/main.cc#L64
      entryPointArgs :: [String]
entryPointArgs = case Maybe String
entryPoint of
        Maybe String
Nothing -> []
        Just String
name -> case ShaderType
shaderType of
          ShaderType
GLSL -> []
          ShaderType
HLSL -> [String
"-fentry-point=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name]
      args :: [String]
args = [String]
targetArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
entryPointArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-fshader-stage=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
stage, String
"-x", ShaderType -> String
forall a. Show a => a -> String
show ShaderType
shaderType, String
shader, String
"-o", String
spirv]
    (rc, out, 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 String
"glslc" [String]
args
    let (warnings, errors) = processShadercMessages (out <> err)
    case rc of
      ExitCode
ExitSuccess -> do
        bs <- String -> IO ByteString
BS.readFile String
spirv
        pure (warnings, Right bs)
      ExitFailure Int
_rc -> ([String], Either [String] ByteString)
-> IO ([String], Either [String] ByteString)
forall a. a -> IO a
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)