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