{-# 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 ->
          -- logDebug $ "Skipping pipeline update from " <> display label
          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

  -- TODO: use stageCode?
  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
      }

-- * HKD wrappers

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