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