{-# 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 (ReleaseKey, ResourceT, release)
import Data.List (maximum)
import Data.Tagged (Tagged(..))
import RIO.ByteString qualified as ByteString
import RIO.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist)
import RIO.Map qualified as Map
import RIO.Text qualified as Text
import RIO.Time (UTCTime, getCurrentTime)
import RIO.FilePath ((</>), (<.>))
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 (DsBindings, HasRenderPass)
import Engine.Worker qualified as Worker

type Process config = Worker.Timed () config

spawn
  :: ( Foldable stages
     , MonadUnliftIO m
     , MonadReader env m
     , HasLogFunc env
     )
  => (stages (Maybe FilePath) -> m stuff)
  -> Text
  -> stages (Maybe FilePath)
  -> (stuff -> config)
  -> m (Process config)
spawn :: forall (stages :: * -> *) (m :: * -> *) env stuff config.
(Foldable stages, MonadUnliftIO m, MonadReader env m,
 HasLogFunc env) =>
(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 =
  Bool
-> Either Int (() -> Int)
-> (() -> m (config, UTCTime))
-> (UTCTime -> () -> m (Maybe config, UTCTime))
-> ()
-> m (Timed () config)
forall (m :: * -> *) config output state.
MonadUnliftIO 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 Either Int (() -> Int)
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 = Int -> Either Int b
forall a b. a -> Either a b
Left Int
1e6

    initF :: () -> m (config, UTCTime)
initF () = do
      Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Starting pipeline watch on " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
label

      stuff
result <- stages (Maybe FilePath) -> m stuff
loader stages (Maybe FilePath)
stageFiles
      UTCTime
initialTime <- m UTCTime
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
      UTCTime -> [FilePath] -> m (Maybe UTCTime)
forall (io :: * -> *).
MonadIO io =>
UTCTime -> [FilePath] -> io (Maybe UTCTime)
checkTime UTCTime
oldTime ([Maybe FilePath] -> [FilePath]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FilePath] -> [FilePath]) -> [Maybe FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ stages (Maybe FilePath) -> [Maybe FilePath]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList stages (Maybe FilePath)
stageFiles) m (Maybe UTCTime)
-> (Maybe UTCTime -> m (Maybe config, UTCTime))
-> m (Maybe config, UTCTime)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe UTCTime
Nothing ->
          -- logDebug $ "Skipping pipeline update from " <> display label
          (Maybe config, UTCTime) -> m (Maybe config, UTCTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe config
forall a. Maybe a
Nothing, UTCTime
oldTime)
        Just UTCTime
newTime -> do
          Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Updating pipeline from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
label
          m stuff -> m (Either SomeException stuff)
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) m (Either SomeException stuff)
-> (Either SomeException stuff -> m (Maybe config, UTCTime))
-> m (Maybe config, UTCTime)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left (SomeException e
err) -> do
              Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ e -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow e
err
              pure (Maybe config
forall a. Maybe a
Nothing, UTCTime
newTime)
            Right stuff
result ->
              (Maybe config, UTCTime) -> m (Maybe config, UTCTime)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ( config -> Maybe config
forall a. a -> Maybe a
Just (config -> Maybe config) -> config -> Maybe config
forall a b. (a -> b) -> a -> b
$ stuff -> config
makeConfig stuff
result
                , UTCTime
newTime
                )

spawnReflect
  :: ( 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.
(MonadUnliftIO m, MonadReader env m, HasLogFunc env,
 StageInfo stages) =>
Text
-> stages (Maybe FilePath)
-> ((stages (Maybe ByteString), Reflect stages) -> config)
-> m (Process config)
spawnReflect = (stages (Maybe FilePath)
 -> m (stages (Maybe ByteString), Reflect stages))
-> Text
-> stages (Maybe FilePath)
-> ((stages (Maybe ByteString), Reflect stages) -> config)
-> m (Process config)
forall (stages :: * -> *) (m :: * -> *) env stuff config.
(Foldable stages, MonadUnliftIO m, MonadReader env m,
 HasLogFunc env) =>
(stages (Maybe FilePath) -> m stuff)
-> Text
-> stages (Maybe FilePath)
-> (stuff -> config)
-> m (Process config)
spawn stages (Maybe FilePath)
-> m (stages (Maybe ByteString), Reflect stages)
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 = ([UTCTime] -> Maybe UTCTime) -> io [UTCTime] -> io (Maybe UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [UTCTime] -> Maybe UTCTime
collect (io [UTCTime] -> io (Maybe UTCTime))
-> ([FilePath] -> io [UTCTime]) -> [FilePath] -> io (Maybe UTCTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> io UTCTime) -> [FilePath] -> io [UTCTime]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> io UTCTime
forall (m :: * -> *). MonadIO m => FilePath -> m UTCTime
getModificationTime
  where
    collect :: [UTCTime] -> Maybe UTCTime
collect = \case
      [] ->
        Maybe UTCTime
forall a. Maybe a
Nothing
      ([UTCTime] -> UTCTime
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum -> UTCTime
maxTime) ->
        if UTCTime
maxTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
oldTime then
          Maybe UTCTime
forall a. Maybe a
Nothing
        else
          UTCTime -> Maybe UTCTime
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 =
  stages (Maybe FilePath)
-> (Maybe FilePath -> io (Maybe ByteString))
-> io (stages (Maybe ByteString))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for stages (Maybe FilePath)
stageFiles ((Maybe FilePath -> io (Maybe ByteString))
 -> io (stages (Maybe ByteString)))
-> (Maybe FilePath -> io (Maybe ByteString))
-> io (stages (Maybe ByteString))
forall a b. (a -> b) -> a -> b
$
    (FilePath -> io ByteString)
-> Maybe FilePath -> io (Maybe ByteString)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> io ByteString
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 <- stages (Maybe FilePath) -> io (stages (Maybe ByteString))
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 <- stages (Maybe FilePath)
-> (Maybe FilePath -> io (Maybe Module))
-> io (stages (Maybe Module))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for stages (Maybe FilePath)
stageFiles ((Maybe FilePath -> io (Maybe Module))
 -> io (stages (Maybe Module)))
-> (Maybe FilePath -> io (Maybe Module))
-> io (stages (Maybe Module))
forall a b. (a -> b) -> a -> b
$
    (FilePath -> io Module) -> Maybe FilePath -> io (Maybe Module)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> io Module
forall (m :: * -> *). MonadIO m => FilePath -> m Module
Reflect.invoke

  BindMap BlockBinding
reflDS <- stages (Maybe Module) -> io (BindMap BlockBinding)
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

  StageInterface stages
reflIS <- stages (Maybe Module) -> io (StageInterface stages)
forall (m :: * -> *) (stages :: * -> *).
(MonadIO m, Traversable stages) =>
stages (Maybe Module) -> m (StageInterface stages)
Reflect.stagesInterfaceMap stages (Maybe Module)
stageRefl
  case StageInterface stages
-> Either
     (IncompatibleInterfaces FilePath) [CompatibleInterfaces FilePath]
forall (stages :: * -> *) label.
(StageInfo stages, IsString label) =>
StageInterface stages
-> Either
     (IncompatibleInterfaces label) [CompatibleInterfaces label]
Reflect.interfaceCompatible StageInterface stages
reflIS of
    Right [CompatibleInterfaces FilePath]
ok ->
      Utf8Builder -> io ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> io ()) -> Utf8Builder -> io ()
forall a b. (a -> b) -> a -> b
$ [CompatibleInterfaces FilePath] -> Utf8Builder
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 " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
outputStage FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" and " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
inputStage
        locInfo :: FilePath
locInfo = FilePath
"(location=" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
location FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
")"
      case Maybe (InterfaceSignature, InterfaceSignature)
err of
        Maybe (InterfaceSignature, InterfaceSignature)
Nothing ->
          FilePath -> io ()
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString (FilePath -> io ()) -> FilePath -> io ()
forall a b. (a -> b) -> a -> b
$
            [FilePath] -> FilePath
unwords [ FilePath
between, FilePath
"missing output ", FilePath
locInfo ]
        Just (InterfaceSignature
sigRequested, InterfaceSignature
sigProvided) ->
          FilePath -> io ()
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString (FilePath -> io ()) -> FilePath -> io ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines
            [ [FilePath] -> FilePath
unwords [ FilePath
between, FilePath
locInfo FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
":", FilePath
"incompatible signatures" ]
            , FilePath
"  requested: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> InterfaceSignature -> FilePath
forall a. Show a => a -> FilePath
show InterfaceSignature
sigRequested
            , FilePath
"  provided: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> InterfaceSignature -> FilePath
forall a. Show a => a -> FilePath
show InterfaceSignature
sigProvided
            ]

  (Text
inputStage, InterfaceBinds
inputs) <-
    case StageInterface stages -> Maybe (Text, InterfaceBinds)
forall (stages :: * -> *) label.
(StageInfo stages, IsString label) =>
StageInterface stages -> Maybe (label, InterfaceBinds)
Reflect.inputStageInterface StageInterface stages
reflIS of
      Maybe (Text, InterfaceBinds)
Nothing ->
        FilePath -> io (Text, InterfaceBinds)
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString FilePath
"No active stage"
      Just (Text, InterfaceBinds)
found ->
        (Text, InterfaceBinds) -> io (Text, InterfaceBinds)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text, InterfaceBinds)
found

  let
    reflect :: Reflect stages
reflect = Reflect :: forall (stages :: * -> *).
BindMap BlockBinding
-> StageInterface stages
-> Text
-> InterfaceBinds
-> Reflect stages
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 <- worker -> ResourceT (StageRIO rs) (GetOutput worker)
forall worker (m :: * -> *).
(HasOutput worker, MonadIO m) =>
worker -> m (GetOutput worker)
Worker.getOutputData worker
process

  (ReleaseKey, pipeline)
initial <- Maybe Extent2D
-> SampleCountFlagBits
-> Config
     dsl
     vertices
     instances
     (Specialization (Pipeline dsl vertices instances))
-> renderpass
-> ResourceT (StageRIO rs) (ReleaseKey, pipeline)
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
    Maybe Extent2D
forall a. Maybe a
Nothing
    SampleCountFlagBits
msaa
    Config
  dsl
  vertices
  instances
  (Specialization (Pipeline dsl vertices instances))
initialConfig
    renderpass
rp

  (ReleaseKey, pipeline)
-> ResourceT (StageRIO rs) (Observer pipeline)
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 [DsBindings]
  -> 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 [DsBindings]
-> output
-> ObserverIO (ReleaseKey, pipeline)
-> StageFrameRIO rp p fr rs ()
observeGraphics renderpass
rp SampleCountFlagBits
msaa Tagged dsl [DsBindings]
sceneBinds output
configP ObserverIO (ReleaseKey, pipeline)
output =
  RIO (App GlobalHandles rs, Frame rp p fr) (ReleaseKey, pipeline)
-> RIO (App GlobalHandles rs, Frame rp p fr) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO (App GlobalHandles rs, Frame rp p fr) (ReleaseKey, pipeline)
 -> RIO (App GlobalHandles rs, Frame rp p fr) ())
-> RIO (App GlobalHandles rs, Frame rp p fr) (ReleaseKey, pipeline)
-> RIO (App GlobalHandles rs, Frame rp p fr) ()
forall a b. (a -> b) -> a -> b
$! output
-> ObserverIO (ReleaseKey, pipeline)
-> ((ReleaseKey, pipeline)
    -> GetOutput output
    -> RIO
         (App GlobalHandles rs, Frame rp p fr) (ReleaseKey, pipeline))
-> RIO (App GlobalHandles rs, Frame rp p fr) (ReleaseKey, pipeline)
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
    Utf8Builder -> RIO (App GlobalHandles rs, Frame rp p fr) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Rebuilding pipeline"
    ReleaseKey -> RIO (App GlobalHandles rs, Frame rp p fr) ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
oldKey
    ((App GlobalHandles rs, Frame rp p fr) -> App GlobalHandles rs)
-> RIO (App GlobalHandles rs) (ReleaseKey, pipeline)
-> RIO (App GlobalHandles rs, Frame rp p fr) (ReleaseKey, pipeline)
forall outer inner a.
(outer -> inner) -> RIO inner a -> RIO outer a
mapRIO (App GlobalHandles rs, Frame rp p fr) -> App GlobalHandles rs
forall a b. (a, b) -> a
fst (RIO (App GlobalHandles rs) (ReleaseKey, pipeline)
 -> RIO
      (App GlobalHandles rs, Frame rp p fr) (ReleaseKey, pipeline))
-> RIO (App GlobalHandles rs) (ReleaseKey, pipeline)
-> RIO (App GlobalHandles rs, Frame rp p fr) (ReleaseKey, pipeline)
forall a b. (a -> b) -> a -> b
$ Maybe Extent2D
-> SampleCountFlagBits
-> Config dsl vertices instances spec
-> renderpass
-> RIO (App GlobalHandles rs) (ReleaseKey, pipeline)
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
      Maybe Extent2D
forall a. Maybe a
Nothing
      SampleCountFlagBits
msaa
      ( GetOutput output
Config dsl vertices instances spec
config
          { $sel:cDescLayouts:Config :: Tagged dsl [DsBindings]
Graphics.cDescLayouts = Tagged dsl [DsBindings]
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 <- Process config
-> ResourceT (StageRIO rs) (GetOutput (Process config))
forall worker (m :: * -> *).
(HasOutput worker, MonadIO m) =>
worker -> m (GetOutput worker)
Worker.getOutputData Process config
process

  (ReleaseKey, Pipeline dsl Compute Compute)
initial <- Config dsl ()
-> ResourceT
     (StageRIO rs) (ReleaseKey, Pipeline dsl Compute Compute)
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

  (ReleaseKey, Pipeline dsl Compute Compute)
-> ResourceT
     (StageRIO rs)
     (ObserverIO (ReleaseKey, Pipeline dsl Compute Compute))
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 [DsBindings]
  -> 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 [DsBindings]
-> output
-> ObserverIO (ReleaseKey, pipeline)
-> StageFrameRIO rp p fr rs ()
observeCompute Tagged dsl [DsBindings]
binds output
configP ObserverIO (ReleaseKey, pipeline)
output =
  RIO (App GlobalHandles rs, Frame rp p fr) (ReleaseKey, pipeline)
-> RIO (App GlobalHandles rs, Frame rp p fr) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO (App GlobalHandles rs, Frame rp p fr) (ReleaseKey, pipeline)
 -> RIO (App GlobalHandles rs, Frame rp p fr) ())
-> RIO (App GlobalHandles rs, Frame rp p fr) (ReleaseKey, pipeline)
-> RIO (App GlobalHandles rs, Frame rp p fr) ()
forall a b. (a -> b) -> a -> b
$! output
-> ObserverIO (ReleaseKey, pipeline)
-> ((ReleaseKey, pipeline)
    -> GetOutput output
    -> RIO
         (App GlobalHandles rs, Frame rp p fr) (ReleaseKey, pipeline))
-> RIO (App GlobalHandles rs, Frame rp p fr) (ReleaseKey, pipeline)
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
    Utf8Builder -> RIO (App GlobalHandles rs, Frame rp p fr) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Rebuilding pipeline"
    ReleaseKey -> RIO (App GlobalHandles rs, Frame rp p fr) ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
release ReleaseKey
oldKey
    ((App GlobalHandles rs, Frame rp p fr) -> App GlobalHandles rs)
-> RIO
     (App GlobalHandles rs) (ReleaseKey, Pipeline dsl Compute Compute)
-> RIO
     (App GlobalHandles rs, Frame rp p fr)
     (ReleaseKey, Pipeline dsl Compute Compute)
forall outer inner a.
(outer -> inner) -> RIO inner a -> RIO outer a
mapRIO (App GlobalHandles rs, Frame rp p fr) -> App GlobalHandles rs
forall a b. (a, b) -> a
fst (RIO
   (App GlobalHandles rs) (ReleaseKey, Pipeline dsl Compute Compute)
 -> RIO
      (App GlobalHandles rs, Frame rp p fr)
      (ReleaseKey, Pipeline dsl Compute Compute))
-> RIO
     (App GlobalHandles rs) (ReleaseKey, Pipeline dsl Compute Compute)
-> RIO
     (App GlobalHandles rs, Frame rp p fr)
     (ReleaseKey, Pipeline dsl Compute Compute)
forall a b. (a -> b) -> a -> b
$ Config dsl spec
-> RIO
     (App GlobalHandles rs) (ReleaseKey, Pipeline dsl Compute Compute)
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 dsl spec
config
      { $sel:cDescLayouts:Config :: Tagged dsl [DsBindings]
Compute.cDescLayouts = Tagged dsl [DsBindings]
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 DsBindings
  -> 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 DsBindings
-> pf ConfigureGraphics
-> pf Observers
-> (forall (a :: * -> *). pf a -> a ^ p)
-> StageFrameRIO rps ps fr rs ()
observeField renderpass
rp SampleCountFlagBits
msaa Tagged dsl DsBindings
binds pf ConfigureGraphics
workers pf Observers
observers forall (a :: * -> *). pf a -> a ^ p
field =
  renderpass
-> SampleCountFlagBits
-> Tagged s [DsBindings]
-> Process (Config s vs is (Specialization (Pipeline s vs is)))
-> ObserverIO (ReleaseKey, Pipeline s vs is)
-> StageFrameRIO rps ps fr rs ()
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 [DsBindings]
-> output
-> ObserverIO (ReleaseKey, pipeline)
-> StageFrameRIO rp p fr rs ()
observeGraphics
    renderpass
rp
    SampleCountFlagBits
msaa
    ([DsBindings] -> Tagged s [DsBindings]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Tagged dsl DsBindings -> DsBindings
forall {k} (s :: k) b. Tagged s b -> b
unTagged Tagged dsl DsBindings
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
  Bool -> FilePath -> io ()
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
createDirectoryIfMissing Bool
True FilePath
prefix
  [(Text, t (Maybe Code))]
-> ((Text, t (Maybe Code)) -> io ()) -> io ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map Text (t (Maybe Code)) -> [(Text, t (Maybe Code))]
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 = (,) (FilePath -> Maybe Code -> (FilePath, Maybe Code))
-> t FilePath -> t (Maybe Code -> (FilePath, Maybe Code))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t FilePath
forall (t :: * -> *) label.
(StageInfo t, IsString label) =>
t label
stageNames t (Maybe Code -> (FilePath, Maybe Code))
-> t (Maybe Code) -> t (FilePath, Maybe Code)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t (Maybe Code)
stageCode
    t (FilePath, Maybe Code)
-> ((FilePath, Maybe Code) -> io ()) -> io ()
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) ->
      Maybe Code -> (Code -> io ()) -> io ()
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 <- FilePath -> io Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesFileExist FilePath
file
        if Bool
exists then do
          ByteString
old <- FilePath -> io ByteString
forall (m :: * -> *). MonadIO m => FilePath -> m ByteString
ByteString.readFile FilePath
file
          Bool -> io () -> io ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
bytes ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
old) (io () -> io ()) -> io () -> io ()
forall a b. (a -> b) -> a -> b
$
            FilePath -> ByteString -> io ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
ByteString.writeFile FilePath
file ByteString
bytes
        else
          FilePath -> ByteString -> io ()
forall (m :: * -> *). MonadIO m => FilePath -> ByteString -> m ()
ByteString.writeFile FilePath
file ByteString
bytes