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

    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
same do
      FilePath -> ByteString -> RIO env ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
ByteString.writeFile FilePath
shaderFile ByteString
outBytes
      (ByteString
_out, ByteString
_err) <- FilePath
-> [FilePath]
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, ByteString)
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
        ]
        ProcessConfig () () () -> RIO env (ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString) -> Utf8Builder
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 ->
          FilePath -> (FilePath -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> (FilePath -> m a) -> m a
withSystemTempDirectory FilePath
"keid-shader" FilePath -> RIO env ()
action
        Just FilePath
dir -> do
          Bool -> FilePath -> RIO env ()
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 =
  stages (Text, Maybe Code)
-> ((Text, Maybe Code) -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (stages (Maybe Code) -> stages (Text, Maybe Code)
forall (t :: * -> *) label a.
(StageInfo t, IsString label) =>
t a -> t (label, a)
Stages.withLabels stages (Maybe Code)
stages) \(Text
label, Maybe Code
mstage) ->
    (Code -> RIO env ()) -> Maybe Code -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Maybe FilePath -> Text -> Text -> Code -> RIO env ()
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 = ((Text, stages (Maybe Code)) -> RIO env ())
-> [(Text, stages (Maybe Code))] -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Text, stages (Maybe Code)) -> RIO env ()
compile ([(Text, stages (Maybe Code))] -> RIO env ())
-> (Map Text (stages (Maybe Code))
    -> [(Text, stages (Maybe Code))])
-> Map Text (stages (Maybe Code))
-> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text (stages (Maybe Code)) -> [(Text, stages (Maybe Code))]
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) = Maybe FilePath -> Text -> stages (Maybe Code) -> RIO env ()
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