{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}
module Engine.Vulkan.Pipeline.External
( Process
, spawn
, spawnReflect
, loadConfig
, loadConfigReflect
, Observer
, newObserverGraphics
, observeGraphics
, newObserverCompute
, observeCompute
, type (^)
, ConfigureGraphics
, ConfigureCompute
, Observers
, observeField
, dumpPipelines
) where
import RIO
import Control.Monad.Trans.Resource (ResourceT)
import Data.List (maximum)
import Data.Tagged (Tagged(..))
import RIO.ByteString qualified as ByteString
import RIO.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist)
import RIO.FilePath ((</>), (<.>))
import RIO.Map qualified as Map
import RIO.Text qualified as Text
import RIO.Time (UTCTime, getCurrentTime)
import UnliftIO.Resource (MonadResource, ReleaseKey)
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk
import Render.Code (Code(..))
import Engine.SpirV.Reflect qualified as Reflect
import Engine.Types (StageFrameRIO, StageRIO)
import Engine.Vulkan.Pipeline.Compute (Compute)
import Engine.Vulkan.Pipeline.Compute qualified as Compute
import Engine.Vulkan.Pipeline.Graphics qualified as Graphics
import Engine.Vulkan.Pipeline.Stages (StageInfo(..))
import Engine.Vulkan.Shader qualified as Shader
import Engine.Vulkan.Types (DsLayoutBindings, HasRenderPass)
import Engine.Worker qualified as Worker
type Process config = Worker.Timed () config
spawn
:: ( Foldable stages
, MonadReader env m
, HasLogFunc env
, MonadResource m
, MonadUnliftIO m
)
=> (stages (Maybe FilePath) -> m stuff)
-> Text
-> stages (Maybe FilePath)
-> (stuff -> config)
-> m (Process config)
spawn :: forall (stages :: * -> *) env (m :: * -> *) stuff config.
(Foldable stages, MonadReader env m, HasLogFunc env,
MonadResource m, MonadUnliftIO m) =>
(stages (Maybe FilePath) -> m stuff)
-> Text
-> stages (Maybe FilePath)
-> (stuff -> config)
-> m (Process config)
spawn stages (Maybe FilePath) -> m stuff
loader Text
label stages (Maybe FilePath)
stageFiles stuff -> config
makeConfig =
forall (m :: * -> *) config output state.
(MonadUnliftIO m, MonadResource m) =>
Bool
-> Either Int (config -> Int)
-> (config -> m (output, state))
-> (state -> config -> m (Maybe output, state))
-> config
-> m (Timed config output)
Worker.spawnTimed Bool
startActive forall {b}. Either Int b
dtF () -> m (config, UTCTime)
initF UTCTime -> () -> m (Maybe config, UTCTime)
stepF ()
where
startActive :: Bool
startActive = Bool
True
dtF :: Either Int b
dtF = forall a b. a -> Either a b
Left Int
1e6
initF :: () -> m (config, UTCTime)
initF () = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Starting pipeline watch on " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
label
stuff
result <- stages (Maybe FilePath) -> m stuff
loader stages (Maybe FilePath)
stageFiles
UTCTime
initialTime <- forall (m :: * -> *). MonadIO m => m UTCTime
getCurrentTime
pure (stuff -> config
makeConfig stuff
result, UTCTime
initialTime)
stepF :: UTCTime -> () -> m (Maybe config, UTCTime)
stepF UTCTime
oldTime () = do
forall (io :: * -> *).
MonadIO io =>
UTCTime -> [FilePath] -> io (Maybe UTCTime)
checkTime UTCTime
oldTime (forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList stages (Maybe FilePath)
stageFiles) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe UTCTime
Nothing ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, UTCTime
oldTime)
Just UTCTime
newTime -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Updating pipeline from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
label
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (stages (Maybe FilePath) -> m stuff
loader stages (Maybe FilePath)
stageFiles) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left (SomeException e
err) -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Utf8Builder
displayShow e
err
pure (forall a. Maybe a
Nothing, UTCTime
newTime)
Right stuff
result ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ stuff -> config
makeConfig stuff
result
, UTCTime
newTime
)
spawnReflect
:: ( MonadResource m
, MonadUnliftIO m
, MonadReader env m
, HasLogFunc env
, StageInfo stages
)
=> Text
-> stages (Maybe FilePath)
-> ((stages (Maybe ByteString), Reflect.Reflect stages) -> config)
-> m (Process config)
spawnReflect :: forall (m :: * -> *) env (stages :: * -> *) config.
(MonadResource m, MonadUnliftIO m, MonadReader env m,
HasLogFunc env, StageInfo stages) =>
Text
-> stages (Maybe FilePath)
-> ((stages (Maybe ByteString), Reflect stages) -> config)
-> m (Process config)
spawnReflect = forall (stages :: * -> *) env (m :: * -> *) stuff config.
(Foldable stages, MonadReader env m, HasLogFunc env,
MonadResource m, MonadUnliftIO m) =>
(stages (Maybe FilePath) -> m stuff)
-> Text
-> stages (Maybe FilePath)
-> (stuff -> config)
-> m (Process config)
spawn forall (stages :: * -> *) (io :: * -> *) env.
(StageInfo stages, MonadIO io, MonadReader env io,
HasLogFunc env) =>
stages (Maybe FilePath)
-> io (stages (Maybe ByteString), Reflect stages)
loadConfigReflect
checkTime
:: MonadIO io
=> UTCTime
-> [FilePath]
-> io (Maybe UTCTime)
checkTime :: forall (io :: * -> *).
MonadIO io =>
UTCTime -> [FilePath] -> io (Maybe UTCTime)
checkTime UTCTime
oldTime = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [UTCTime] -> Maybe UTCTime
collect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *). MonadIO m => FilePath -> m UTCTime
getModificationTime
where
collect :: [UTCTime] -> Maybe UTCTime
collect = \case
[] ->
forall a. Maybe a
Nothing
(forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum -> UTCTime
maxTime) ->
if UTCTime
maxTime forall a. Ord a => a -> a -> Bool
<= UTCTime
oldTime then
forall a. Maybe a
Nothing
else
forall a. a -> Maybe a
Just UTCTime
maxTime
loadConfig
:: ( Traversable stages
, MonadIO io
)
=> stages (Maybe FilePath)
-> io (stages (Maybe ByteString))
loadConfig :: forall (stages :: * -> *) (io :: * -> *).
(Traversable stages, MonadIO io) =>
stages (Maybe FilePath) -> io (stages (Maybe ByteString))
loadConfig stages (Maybe FilePath)
stageFiles =
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for stages (Maybe FilePath)
stageFiles forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *). MonadIO m => FilePath -> m ByteString
ByteString.readFile
loadConfigReflect
:: ( StageInfo stages
, MonadIO io
, MonadReader env io
, HasLogFunc env
)
=> stages (Maybe FilePath)
-> io (stages (Maybe ByteString), Reflect.Reflect stages)
loadConfigReflect :: forall (stages :: * -> *) (io :: * -> *) env.
(StageInfo stages, MonadIO io, MonadReader env io,
HasLogFunc env) =>
stages (Maybe FilePath)
-> io (stages (Maybe ByteString), Reflect stages)
loadConfigReflect stages (Maybe FilePath)
stageFiles = do
stages (Maybe ByteString)
stageCode <- forall (stages :: * -> *) (io :: * -> *).
(Traversable stages, MonadIO io) =>
stages (Maybe FilePath) -> io (stages (Maybe ByteString))
loadConfig stages (Maybe FilePath)
stageFiles
stages (Maybe Module)
stageRefl <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for stages (Maybe FilePath)
stageFiles forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *). MonadIO m => FilePath -> m Module
Reflect.invoke
BindMap BlockBinding
reflDS <- forall (m :: * -> *) env (stages :: * -> *).
(MonadIO m, MonadReader env m, HasLogFunc env, StageInfo stages) =>
stages (Maybe Module) -> m (BindMap BlockBinding)
Reflect.stagesBindMap stages (Maybe Module)
stageRefl
let reflIS :: StageInterface stages
reflIS = forall (stages :: * -> *).
Traversable stages =>
stages (Maybe Module) -> StageInterface stages
Reflect.stagesInterfaceMap stages (Maybe Module)
stageRefl
case forall (stages :: * -> *) label.
(StageInfo stages, IsString label) =>
StageInterface stages
-> Either
(IncompatibleInterfaces label) [CompatibleInterfaces label]
Reflect.interfaceCompatible StageInterface stages
reflIS of
Right [CompatibleInterfaces FilePath]
ok ->
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 [CompatibleInterfaces FilePath]
ok
Left (FilePath
inputStage, FilePath
outputStage, Int
location, Maybe (InterfaceSignature, InterfaceSignature)
err) -> do
let
between :: FilePath
between = FilePath
"Between " forall a. Semigroup a => a -> a -> a
<> FilePath
outputStage forall a. Semigroup a => a -> a -> a
<> FilePath
" and " forall a. Semigroup a => a -> a -> a
<> FilePath
inputStage
locInfo :: FilePath
locInfo = FilePath
"(location=" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Int
location forall a. Semigroup a => a -> a -> a
<> FilePath
")"
case Maybe (InterfaceSignature, InterfaceSignature)
err of
Maybe (InterfaceSignature, InterfaceSignature)
Nothing ->
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString forall a b. (a -> b) -> a -> b
$
[FilePath] -> FilePath
unwords [ FilePath
between, FilePath
"missing output ", FilePath
locInfo ]
Just (InterfaceSignature
sigRequested, InterfaceSignature
sigProvided) ->
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines
[ [FilePath] -> FilePath
unwords [ FilePath
between, FilePath
locInfo forall a. Semigroup a => a -> a -> a
<> FilePath
":", FilePath
"incompatible signatures" ]
, FilePath
" requested: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show InterfaceSignature
sigRequested
, FilePath
" provided: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show InterfaceSignature
sigProvided
]
(Text
inputStage, InterfaceBinds
inputs) <-
case forall (stages :: * -> *) label.
(StageInfo stages, IsString label) =>
StageInterface stages -> Maybe (label, InterfaceBinds)
Reflect.inputStageInterface StageInterface stages
reflIS of
Maybe (Text, InterfaceBinds)
Nothing ->
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString FilePath
"No active stage"
Just (Text, InterfaceBinds)
found ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text, InterfaceBinds)
found
let
reflect :: Reflect stages
reflect = Reflect.Reflect
{ $sel:bindMap:Reflect :: BindMap BlockBinding
bindMap = BindMap BlockBinding
reflDS
, $sel:interfaces:Reflect :: StageInterface stages
interfaces = StageInterface stages
reflIS
, $sel:inputStage:Reflect :: Text
inputStage = Text
inputStage
, $sel:inputs:Reflect :: InterfaceBinds
inputs = InterfaceBinds
inputs
}
pure
( stages (Maybe ByteString)
stageCode
, Reflect stages
reflect
)
type Observer pipeline = Worker.ObserverIO (ReleaseKey, pipeline)
newObserverGraphics
:: ( pipeline ~ Graphics.Pipeline dsl vertices instances
, Worker.HasOutput worker
, Shader.Specialization (Graphics.Specialization pipeline)
, HasRenderPass renderpass
, Worker.GetOutput worker ~ Graphics.Configure pipeline
)
=> renderpass
-> Vk.SampleCountFlagBits
-> worker
-> ResourceT (StageRIO rs) (Observer pipeline)
newObserverGraphics :: forall pipeline (dsl :: [*]) vertices instances worker renderpass
rs.
(pipeline ~ Pipeline dsl vertices instances, HasOutput worker,
Specialization (Specialization pipeline), HasRenderPass renderpass,
GetOutput worker ~ Configure pipeline) =>
renderpass
-> SampleCountFlagBits
-> worker
-> ResourceT (StageRIO rs) (Observer pipeline)
newObserverGraphics renderpass
rp SampleCountFlagBits
msaa worker
process = do
Config
dsl
vertices
instances
(Specialization (Pipeline dsl vertices instances))
initialConfig <- forall worker (m :: * -> *).
(HasOutput worker, MonadIO m) =>
worker -> m (GetOutput worker)
Worker.getOutputData worker
process
(ReleaseKey, pipeline)
initial <- forall config pipeline (dsl :: [*]) vertices instances spec env
(m :: * -> *) renderpass.
(config ~ Configure pipeline,
pipeline ~ Pipeline dsl vertices instances,
spec ~ Specialization pipeline, Specialization spec, HasCallStack,
MonadVulkan env m, MonadResource m, HasRenderPass renderpass) =>
Maybe Extent2D
-> SampleCountFlagBits
-> Config dsl vertices instances spec
-> renderpass
-> m (ReleaseKey, pipeline)
Graphics.allocate
forall a. Maybe a
Nothing
SampleCountFlagBits
msaa
Config
dsl
vertices
instances
(Specialization (Pipeline dsl vertices instances))
initialConfig
renderpass
rp
forall (m :: * -> *) a. MonadIO m => a -> m (ObserverIO a)
Worker.newObserverIO (ReleaseKey, pipeline)
initial
observeGraphics
:: ( HasRenderPass renderpass
, Worker.HasOutput output
, Worker.GetOutput output ~ Graphics.Configure pipeline
, pipeline ~ Graphics.Pipeline dsl vertices instances
, spec ~ Graphics.Specialization pipeline
, Shader.Specialization spec
)
=> renderpass
-> Vk.SampleCountFlagBits
-> Tagged dsl [DsLayoutBindings]
-> output
-> Worker.ObserverIO (ReleaseKey, pipeline)
-> StageFrameRIO rp p fr rs ()
observeGraphics :: forall renderpass output pipeline (dsl :: [*]) vertices instances
spec rp p fr rs.
(HasRenderPass renderpass, HasOutput output,
GetOutput output ~ Configure pipeline,
pipeline ~ Pipeline dsl vertices instances,
spec ~ Specialization pipeline, Specialization spec) =>
renderpass
-> SampleCountFlagBits
-> Tagged dsl [DsLayoutBindings]
-> output
-> ObserverIO (ReleaseKey, pipeline)
-> StageFrameRIO rp p fr rs ()
observeGraphics renderpass
rp SampleCountFlagBits
msaa Tagged dsl [DsLayoutBindings]
sceneBinds output
configP ObserverIO (ReleaseKey, pipeline)
output =
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$! forall (m :: * -> *) output a.
(MonadUnliftIO m, HasOutput output) =>
output -> ObserverIO a -> (a -> GetOutput output -> m a) -> m a
Worker.observeIO output
configP ObserverIO (ReleaseKey, pipeline)
output \(ReleaseKey
oldKey, pipeline
_old) GetOutput output
config -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Rebuilding pipeline"
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release ReleaseKey
oldKey
forall outer inner a.
(outer -> inner) -> RIO inner a -> RIO outer a
mapRIO forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall config pipeline (dsl :: [*]) vertices instances spec env
(m :: * -> *) renderpass.
(config ~ Configure pipeline,
pipeline ~ Pipeline dsl vertices instances,
spec ~ Specialization pipeline, Specialization spec, HasCallStack,
MonadVulkan env m, MonadResource m, HasRenderPass renderpass) =>
Maybe Extent2D
-> SampleCountFlagBits
-> Config dsl vertices instances spec
-> renderpass
-> m (ReleaseKey, pipeline)
Graphics.allocate
forall a. Maybe a
Nothing
SampleCountFlagBits
msaa
( GetOutput output
config
{ $sel:cDescLayouts:Config :: Tagged dsl [DsLayoutBindings]
Graphics.cDescLayouts = Tagged dsl [DsLayoutBindings]
sceneBinds
}
)
renderpass
rp
newObserverCompute
:: ( config ~ Compute.Configure pipeline ()
, pipeline ~ Compute.Pipeline dsl Compute Compute
)
=> Process config
-> ResourceT (StageRIO rs) (Observer pipeline)
newObserverCompute :: forall config pipeline (dsl :: [*]) rs.
(config ~ Configure pipeline (),
pipeline ~ Pipeline dsl Compute Compute) =>
Process config -> ResourceT (StageRIO rs) (Observer pipeline)
newObserverCompute Process config
process = do
Config dsl ()
initialConfig <- forall worker (m :: * -> *).
(HasOutput worker, MonadIO m) =>
worker -> m (GetOutput worker)
Worker.getOutputData Process config
process
(ReleaseKey, Pipeline dsl Compute Compute)
initial <- forall env (m :: * -> *) spec (dsl :: [*]).
(MonadVulkan env m, MonadResource m, HasCallStack,
Specialization spec) =>
Config dsl spec -> m (ReleaseKey, Pipeline dsl Compute Compute)
Compute.allocate Config dsl ()
initialConfig
forall (m :: * -> *) a. MonadIO m => a -> m (ObserverIO a)
Worker.newObserverIO (ReleaseKey, Pipeline dsl Compute Compute)
initial
observeCompute
:: ( Worker.HasOutput output
, Worker.GetOutput output ~ config
, Shader.Specialization spec
, config ~ Compute.Configure pipeline spec
, pipeline ~ Compute.Pipeline dsl Compute Compute
)
=> Tagged dsl [DsLayoutBindings]
-> output
-> Worker.ObserverIO (ReleaseKey, pipeline)
-> StageFrameRIO rp p fr rs ()
observeCompute :: forall output config spec pipeline (dsl :: [*]) rp p fr rs.
(HasOutput output, GetOutput output ~ config, Specialization spec,
config ~ Configure pipeline spec,
pipeline ~ Pipeline dsl Compute Compute) =>
Tagged dsl [DsLayoutBindings]
-> output
-> ObserverIO (ReleaseKey, pipeline)
-> StageFrameRIO rp p fr rs ()
observeCompute Tagged dsl [DsLayoutBindings]
binds output
configP ObserverIO (ReleaseKey, pipeline)
output =
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$! forall (m :: * -> *) output a.
(MonadUnliftIO m, HasOutput output) =>
output -> ObserverIO a -> (a -> GetOutput output -> m a) -> m a
Worker.observeIO output
configP ObserverIO (ReleaseKey, pipeline)
output \(ReleaseKey
oldKey, pipeline
_old) GetOutput output
config -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Rebuilding pipeline"
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release ReleaseKey
oldKey
forall outer inner a.
(outer -> inner) -> RIO inner a -> RIO outer a
mapRIO forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) spec (dsl :: [*]).
(MonadVulkan env m, MonadResource m, HasCallStack,
Specialization spec) =>
Config dsl spec -> m (ReleaseKey, Pipeline dsl Compute Compute)
Compute.allocate GetOutput output
config
{ $sel:cDescLayouts:Config :: Tagged dsl [DsLayoutBindings]
Compute.cDescLayouts = Tagged dsl [DsLayoutBindings]
binds
}
data ConfigureGraphics p
data ConfigureCompute p
data Observers p
type family f ^ p where
Identity ^ p = p
ConfigureGraphics ^ p = Process (Graphics.Configure p)
ConfigureCompute ^ p = Process (Compute.Configure p ())
Observers ^ p = Observer p
f ^ p = f p
observeField
:: forall
pf
p
renderpass
dsl
s vs is
rps ps fr rs
. ( p ~ Graphics.Pipeline s vs is
, Shader.Specialization (Graphics.Specialization p)
, HasRenderPass renderpass
)
=> renderpass
-> Vk.SampleCountFlagBits
-> Tagged dsl DsLayoutBindings
-> pf ConfigureGraphics
-> pf Observers
-> (forall a . pf a -> a ^ p)
-> StageFrameRIO rps ps fr rs ()
observeField :: forall (pf :: (* -> *) -> *) p renderpass dsl (s :: [*]) vs is rps
ps fr rs.
(p ~ Pipeline s vs is, Specialization (Specialization p),
HasRenderPass renderpass) =>
renderpass
-> SampleCountFlagBits
-> Tagged dsl DsLayoutBindings
-> pf ConfigureGraphics
-> pf Observers
-> (forall (a :: * -> *). pf a -> a ^ p)
-> StageFrameRIO rps ps fr rs ()
observeField renderpass
rp SampleCountFlagBits
msaa Tagged dsl DsLayoutBindings
binds pf ConfigureGraphics
workers pf Observers
observers forall (a :: * -> *). pf a -> a ^ p
field =
forall renderpass output pipeline (dsl :: [*]) vertices instances
spec rp p fr rs.
(HasRenderPass renderpass, HasOutput output,
GetOutput output ~ Configure pipeline,
pipeline ~ Pipeline dsl vertices instances,
spec ~ Specialization pipeline, Specialization spec) =>
renderpass
-> SampleCountFlagBits
-> Tagged dsl [DsLayoutBindings]
-> output
-> ObserverIO (ReleaseKey, pipeline)
-> StageFrameRIO rp p fr rs ()
observeGraphics
renderpass
rp
SampleCountFlagBits
msaa
(forall {k} (s :: k) b. b -> Tagged s b
Tagged [forall {k} (s :: k) b. Tagged s b -> b
unTagged Tagged dsl DsLayoutBindings
binds])
(forall (a :: * -> *). pf a -> a ^ p
field @ConfigureGraphics pf ConfigureGraphics
workers)
(forall (a :: * -> *). pf a -> a ^ p
field @Observers pf Observers
observers)
dumpPipelines
:: StageInfo t
=> MonadIO io
=> FilePath
-> Map Text (t (Maybe Code))
-> io ()
dumpPipelines :: forall (t :: * -> *) (io :: * -> *).
(StageInfo t, MonadIO io) =>
FilePath -> Map Text (t (Maybe Code)) -> io ()
dumpPipelines FilePath
prefix Map Text (t (Maybe Code))
pipelines = do
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
createDirectoryIfMissing Bool
True FilePath
prefix
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Map k a -> [(k, a)]
Map.toList Map Text (t (Maybe Code))
pipelines) \(Text
pipeline, t (Maybe Code)
stageCode) -> do
let stages :: t (FilePath, Maybe Code)
stages = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) label.
(StageInfo t, IsString label) =>
t label
stageNames forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t (Maybe Code)
stageCode
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ t (FilePath, Maybe Code)
stages \(FilePath
stage, Maybe Code
mcode) ->
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Code
mcode \(Code Text
code) -> do
let
file :: FilePath
file = FilePath
prefix FilePath -> FilePath -> FilePath
</> Text -> FilePath
Text.unpack Text
pipeline FilePath -> FilePath -> FilePath
<.> FilePath
stage
bytes :: ByteString
bytes = Text -> ByteString
encodeUtf8 Text
code
Bool
exists <- forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesFileExist FilePath
file
if Bool
exists then do
ByteString
old <- forall (m :: * -> *). MonadIO m => FilePath -> m ByteString
ByteString.readFile FilePath
file
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
bytes forall a. Eq a => a -> a -> Bool
== ByteString
old) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
ByteString.writeFile FilePath
file ByteString
bytes
else
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
ByteString.writeFile FilePath
file ByteString
bytes