module Engine.SpirV.Compile
  ( glsl
  , glslStages
  , glslPipelines
  ) where

import RIO

import RIO.ByteString qualified as ByteString
import RIO.Directory (createDirectoryIfMissing, doesFileExist)
import RIO.FilePath ((<.>), (</>))
import RIO.Map qualified as Map
import RIO.Process (HasProcessContext, proc, readProcess_)
import RIO.Text qualified as Text

import Render.Code (Code(..))
import Engine.Vulkan.Pipeline.Stages qualified as Stages

glsl
  :: ( HasLogFunc env
     , HasProcessContext env
     )
  => Maybe FilePath
  -> Text
  -> Text
  -> Code
  -> RIO env ()
glsl :: forall env.
(HasLogFunc env, HasProcessContext env) =>
Maybe FilePath -> Text -> Text -> Code -> RIO env ()
glsl Maybe FilePath
outdir Text
basename Text
stage (Code Text
source) = do
  (FilePath -> RIO env ()) -> RIO env ()
withDir \FilePath
dir -> do
    let
      shaderFile :: FilePath
shaderFile = FilePath
dir FilePath -> FilePath -> FilePath
</> Text -> FilePath
Text.unpack Text
basename FilePath -> FilePath -> FilePath
<.> Text -> FilePath
Text.unpack Text
stage
      outFile :: FilePath
outFile  = FilePath
shaderFile FilePath -> FilePath -> FilePath
<.> FilePath
"spv"
      outBytes :: ByteString
outBytes = Text -> ByteString
encodeUtf8 Text
source

    Bool
exists <- forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesFileExist FilePath
shaderFile
    Bool
same <-
      if Bool
exists then do
        ByteString
oldBytes <- forall (m :: * -> *). MonadIO m => FilePath -> m ByteString
ByteString.readFile FilePath
shaderFile
        pure $ ByteString
oldBytes forall a. Eq a => a -> a -> Bool
== ByteString
outBytes
      else
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
same do
      forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
ByteString.writeFile FilePath
shaderFile ByteString
outBytes
      (ByteString
_out, ByteString
_err) <- forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
FilePath -> [FilePath] -> (ProcessConfig () () () -> m a) -> m a
proc
        FilePath
"glslangValidator"
        [ FilePath
"--target-env", FilePath
"vulkan1.2"
        , FilePath
"-S", Text -> FilePath
Text.unpack Text
stage
        , FilePath
"-V", FilePath
shaderFile
        , FilePath
"-o", FilePath
outFile
        ]
        forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Utf8Builder
displayShow (ByteString
_out, ByteString
_err)
  where
    withDir :: (FilePath -> RIO env ()) -> RIO env ()
withDir FilePath -> RIO env ()
action =
      case Maybe FilePath
outdir of
        Maybe FilePath
Nothing ->
          forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"keid-shader" FilePath -> RIO env ()
action
        Just FilePath
dir -> do
          forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
createDirectoryIfMissing Bool
True FilePath
dir
          FilePath -> RIO env ()
action FilePath
dir

glslStages
  :: ( Stages.StageInfo stages
     , HasLogFunc env
     , HasProcessContext env
     )
  => Maybe FilePath
  -> Text
  -> stages (Maybe Code)
  -> RIO env ()
glslStages :: forall (stages :: * -> *) env.
(StageInfo stages, HasLogFunc env, HasProcessContext env) =>
Maybe FilePath -> Text -> stages (Maybe Code) -> RIO env ()
glslStages Maybe FilePath
outdir Text
basename stages (Maybe Code)
stages =
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall (t :: * -> *) label a.
(StageInfo t, IsString label) =>
t a -> t (label, a)
Stages.withLabels stages (Maybe Code)
stages) \(Text
label, Maybe Code
mstage) ->
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall env.
(HasLogFunc env, HasProcessContext env) =>
Maybe FilePath -> Text -> Text -> Code -> RIO env ()
glsl Maybe FilePath
outdir Text
basename Text
label) Maybe Code
mstage

glslPipelines
  :: ( Stages.StageInfo stages
     , HasLogFunc env
     , HasProcessContext env
     )
  => Maybe FilePath
  -> Map Text (stages (Maybe Code))
  -> RIO env ()
glslPipelines :: forall (stages :: * -> *) env.
(StageInfo stages, HasLogFunc env, HasProcessContext env) =>
Maybe FilePath -> Map Text (stages (Maybe Code)) -> RIO env ()
glslPipelines Maybe FilePath
outdir = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Text, stages (Maybe Code)) -> RIO env ()
compile forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList
  where
    compile :: (Text, stages (Maybe Code)) -> RIO env ()
compile (Text
label, stages (Maybe Code)
stages) = forall (stages :: * -> *) env.
(StageInfo stages, HasLogFunc env, HasProcessContext env) =>
Maybe FilePath -> Text -> stages (Maybe Code) -> RIO env ()
glslStages Maybe FilePath
outdir Text
label stages (Maybe Code)
stages