Compile.hs

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(..), targetEnv)
import Engine.Vulkan.Pipeline.Stages qualified as Stages

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

    exists <- doesFileExist shaderFile
    same <-
      if exists then do
        oldBytes <- ByteString.readFile shaderFile
        pure $ oldBytes == outBytes
      else
        pure False

    unless same do
      ByteString.writeFile shaderFile outBytes
      (_out, _err) <- proc
        "glslangValidator"
        [ "--target-env", targetEnv
        , "-S", Text.unpack stage
        , "-V", shaderFile
        , "-o", outFile
        ]
        readProcess_
      logDebug $ displayShow (_out, _err)
  where
    withDir action =
      case outdir of
        Nothing ->
          withSystemTempDirectory "keid-shader" action
        Just dir -> do
          createDirectoryIfMissing True dir
          action dir

glslStages
  :: ( Stages.StageInfo stages
     , HasLogFunc env
     , HasProcessContext env
     )
  => Maybe FilePath
  -> Text
  -> stages (Maybe Code)
  -> RIO env ()
glslStages outdir basename stages =
  for_ (Stages.withLabels stages) \(label, mstage) ->
    traverse_ (glsl outdir basename label) mstage

glslPipelines
  :: ( Stages.StageInfo stages
     , HasLogFunc env
     , HasProcessContext env
     )
  => Maybe FilePath
  -> Map Text (stages (Maybe Code))
  -> RIO env ()
glslPipelines outdir = traverse_ compile . Map.toList
  where
    compile (label, stages) = glslStages outdir label stages