module Resource.Model.Observer
( newCoherent
, observeCoherent
, VertexBuffers(..)
, genericCreateInitial
, genericDestroyCurrent
, UpdateCoherent(..)
, genericUpdateCoherent
) where
import RIO
import GHC.Generics
import Control.Monad.Trans.Resource (ResourceT)
import Control.Monad.Trans.Resource qualified as Resource
import Data.Kind (Type)
import Data.Text qualified as Text
import Data.Vector.Storable qualified as Storable
import Vulkan.Core10 qualified as Vk
import Engine.Types ()
import Engine.Vulkan.Types (HasVulkan, MonadVulkan)
import Engine.Worker qualified as Worker
import Resource.Buffer qualified as Buffer
newCoherent
:: ( VertexBuffers res
, MonadVulkan env m
)
=> Int
-> Text
-> ResourceT m (Worker.ObserverIO res)
newCoherent :: forall res env (m :: * -> *).
(VertexBuffers res, MonadVulkan env m) =>
Int -> Text -> ResourceT m (ObserverIO res)
newCoherent Int
initialSize Text
label = do
res
initial <- forall a env (m :: * -> *).
(VertexBuffers a, MonadVulkan env m) =>
Int -> Text -> ResourceT m a
createInitial Int
initialSize Text
label
ObserverIO res
observer <- forall (m :: * -> *) a. MonadIO m => a -> m (ObserverIO a)
Worker.newObserverIO res
initial
env
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$! forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register do
res
current <- forall (m :: * -> *) a.
MonadUnliftIO m =>
IORef (Versioned a) -> m a
Worker.readObservedIO ObserverIO res
observer
forall a env. (VertexBuffers a, HasVulkan env) => env -> a -> IO ()
destroyCurrent env
context res
current
pure ObserverIO res
observer
observeCoherent
:: ( MonadVulkan env m
, Worker.HasOutput output
, UpdateCoherent bufs (Worker.GetOutput output)
)
=> output
-> Worker.ObserverIO bufs
-> m ()
observeCoherent :: forall env (m :: * -> *) output bufs.
(MonadVulkan env m, HasOutput output,
UpdateCoherent bufs (GetOutput output)) =>
output -> ObserverIO bufs -> m ()
observeCoherent output
process ObserverIO bufs
observer =
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
process ObserverIO bufs
observer forall bufs stores env (m :: * -> *).
(UpdateCoherent bufs stores, MonadVulkan env m) =>
bufs -> stores -> m bufs
updateCoherent
class VertexBuffers a where
createInitial :: forall env m . MonadVulkan env m => Int -> Text -> ResourceT m a
default createInitial
:: forall env m
. ( Generic a
, GVertexBuffers (Rep a)
, MonadVulkan env m
)
=> Int
-> Text
-> ResourceT m a
createInitial = forall a env (m :: * -> *).
(Generic a, GVertexBuffers (Rep a), MonadVulkan env m) =>
Int -> Text -> ResourceT m a
genericCreateInitial
destroyCurrent :: forall env . HasVulkan env => env -> a -> IO ()
default destroyCurrent
:: forall env
. ( Generic a
, GVertexBuffers (Rep a)
, HasVulkan env
)
=> env
-> a
-> IO ()
destroyCurrent = forall a env.
(Generic a, GVertexBuffers (Rep a), HasVulkan env) =>
env -> a -> IO ()
genericDestroyCurrent
instance Storable a => VertexBuffers (Buffer.Allocated 'Buffer.Coherent a) where
createInitial :: forall env (m :: * -> *).
MonadVulkan env m =>
Int -> Text -> ResourceT m (Allocated 'Coherent a)
createInitial Int
initialCapacity Text
label =
forall a env (m :: * -> *).
(MonadVulkan env m, Storable a) =>
Maybe Text
-> BufferUsageFlagBits
-> Int
-> Vector a
-> m (Allocated 'Coherent a)
Buffer.createCoherent
(forall a. a -> Maybe a
Just Text
label)
BufferUsageFlagBits
Vk.BUFFER_USAGE_VERTEX_BUFFER_BIT
Int
initialCapacity
forall a. Monoid a => a
mempty
destroyCurrent :: forall env. HasVulkan env => env -> Allocated 'Coherent a -> IO ()
destroyCurrent env
ctx Allocated 'Coherent a
buf = forall (io :: * -> *) context (s :: Store) a.
(MonadUnliftIO io, HasVulkan context) =>
context -> Allocated s a -> io ()
Buffer.destroy env
ctx Allocated 'Coherent a
buf
genericCreateInitial
:: ( Generic a
, GVertexBuffers (Rep a)
, MonadVulkan env m
)
=> Int
-> Text
-> ResourceT m a
genericCreateInitial :: forall a env (m :: * -> *).
(Generic a, GVertexBuffers (Rep a), MonadVulkan env m) =>
Int -> Text -> ResourceT m a
genericCreateInitial Int
size Text
label =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a x. Generic a => Rep a x -> a
GHC.Generics.to (forall (f :: * -> *) env (m :: * -> *) a.
(GVertexBuffers f, MonadVulkan env m) =>
Int -> Text -> ResourceT m (f a)
gcreate Int
size Text
label)
genericDestroyCurrent
:: ( Generic a
, GVertexBuffers (Rep a)
, HasVulkan env
)
=> env
-> a
-> IO ()
genericDestroyCurrent :: forall a env.
(Generic a, GVertexBuffers (Rep a), HasVulkan env) =>
env -> a -> IO ()
genericDestroyCurrent env
env = forall (f :: * -> *) env a.
(GVertexBuffers f, HasVulkan env) =>
env -> f a -> IO ()
gdestroy env
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
GHC.Generics.from
class GVertexBuffers (f :: Type -> Type) where
gcreate :: forall env m a . MonadVulkan env m => Int -> Text -> ResourceT m (f a)
gdestroy :: forall env a . HasVulkan env => env -> f a -> IO ()
instance GVertexBuffers f => GVertexBuffers (D1 c f) where
gcreate :: forall env (m :: * -> *) a.
MonadVulkan env m =>
Int -> Text -> ResourceT m (D1 c f a)
gcreate Int
size Text
label = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) env (m :: * -> *) a.
(GVertexBuffers f, MonadVulkan env m) =>
Int -> Text -> ResourceT m (f a)
gcreate Int
size Text
label
gdestroy :: forall env a. HasVulkan env => env -> D1 c f a -> IO ()
gdestroy env
env (M1 f a
a) = forall (f :: * -> *) env a.
(GVertexBuffers f, HasVulkan env) =>
env -> f a -> IO ()
gdestroy env
env f a
a
instance GVertexBuffers f => GVertexBuffers (C1 c f) where
gcreate :: forall env (m :: * -> *) a.
MonadVulkan env m =>
Int -> Text -> ResourceT m (C1 c f a)
gcreate Int
size Text
label = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) env (m :: * -> *) a.
(GVertexBuffers f, MonadVulkan env m) =>
Int -> Text -> ResourceT m (f a)
gcreate Int
size Text
label
gdestroy :: forall env a. HasVulkan env => env -> C1 c f a -> IO ()
gdestroy env
env (M1 f a
a) = forall (f :: * -> *) env a.
(GVertexBuffers f, HasVulkan env) =>
env -> f a -> IO ()
gdestroy env
env f a
a
instance (GVertexBuffers l, GVertexBuffers r) => GVertexBuffers (l :*: r) where
gcreate :: forall env (m :: * -> *) a.
MonadVulkan env m =>
Int -> Text -> ResourceT m ((:*:) l r a)
gcreate Int
size Text
label = forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) env (m :: * -> *) a.
(GVertexBuffers f, MonadVulkan env m) =>
Int -> Text -> ResourceT m (f a)
gcreate Int
size Text
label
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) env (m :: * -> *) a.
(GVertexBuffers f, MonadVulkan env m) =>
Int -> Text -> ResourceT m (f a)
gcreate Int
size Text
label
gdestroy :: forall env a. HasVulkan env => env -> (:*:) l r a -> IO ()
gdestroy env
env (l a
l :*: r a
r) =
forall (f :: * -> *) env a.
(GVertexBuffers f, HasVulkan env) =>
env -> f a -> IO ()
gdestroy env
env r a
r forall a. Semigroup a => a -> a -> a
<>
forall (f :: * -> *) env a.
(GVertexBuffers f, HasVulkan env) =>
env -> f a -> IO ()
gdestroy env
env l a
l
instance (GVertexBuffers f, Selector c) => GVertexBuffers (M1 S c f) where
gcreate :: forall env (m :: * -> *) a.
MonadVulkan env m =>
Int -> Text -> ResourceT m (M1 S c f a)
gcreate Int
size Text
label =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) env (m :: * -> *) a.
(GVertexBuffers f, MonadVulkan env m) =>
Int -> Text -> ResourceT m (f a)
gcreate Int
size forall a b. (a -> b) -> a -> b
$
Text -> [Text] -> Text
Text.intercalate Text
"."
[ Text
label
, forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName (forall a. HasCallStack => a
undefined :: t c f a)
]
gdestroy :: forall env a. HasVulkan env => env -> M1 S c f a -> IO ()
gdestroy env
env (M1 f a
a) = forall (f :: * -> *) env a.
(GVertexBuffers f, HasVulkan env) =>
env -> f a -> IO ()
gdestroy env
env f a
a
instance VertexBuffers a => GVertexBuffers (K1 r a) where
gcreate :: forall env (m :: * -> *) a.
MonadVulkan env m =>
Int -> Text -> ResourceT m (K1 r a a)
gcreate Int
size Text
label = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i c (p :: k). c -> K1 i c p
K1 forall a b. (a -> b) -> a -> b
$ forall a env (m :: * -> *).
(VertexBuffers a, MonadVulkan env m) =>
Int -> Text -> ResourceT m a
createInitial Int
size Text
label
gdestroy :: forall env a. HasVulkan env => env -> K1 r a a -> IO ()
gdestroy env
env (K1 a
a) = forall a env. (VertexBuffers a, HasVulkan env) => env -> a -> IO ()
destroyCurrent env
env a
a
class UpdateCoherent bufs stores where
updateCoherent :: forall env m . MonadVulkan env m => bufs -> stores -> m bufs
default updateCoherent
:: forall env m
. ( Generic bufs
, Generic stores
, GUpdateCoherent (Rep bufs) (Rep stores)
, MonadVulkan env m
)
=> bufs
-> stores
-> m bufs
updateCoherent = forall bufs stores env (m :: * -> *).
(Generic bufs, Generic stores,
GUpdateCoherent (Rep bufs) (Rep stores), MonadVulkan env m) =>
bufs -> stores -> m bufs
genericUpdateCoherent
genericUpdateCoherent
:: ( Generic bufs
, Generic stores
, GUpdateCoherent (Rep bufs) (Rep stores)
, MonadVulkan env m
)
=> bufs
-> stores
-> m bufs
genericUpdateCoherent :: forall bufs stores env (m :: * -> *).
(Generic bufs, Generic stores,
GUpdateCoherent (Rep bufs) (Rep stores), MonadVulkan env m) =>
bufs -> stores -> m bufs
genericUpdateCoherent bufs
bufs stores
stores =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a x. Generic a => Rep a x -> a
GHC.Generics.to forall a b. (a -> b) -> a -> b
$
forall (fb :: * -> *) (fs :: * -> *) env (m :: * -> *) b s.
(GUpdateCoherent fb fs, MonadVulkan env m) =>
fb b -> fs s -> m (fb b)
gUpdateCoherent
(forall a x. Generic a => a -> Rep a x
GHC.Generics.from bufs
bufs)
(forall a x. Generic a => a -> Rep a x
GHC.Generics.from stores
stores)
instance Storable a => UpdateCoherent (Buffer.Allocated 'Buffer.Coherent a) (Storable.Vector a) where
updateCoherent :: forall env (m :: * -> *).
MonadVulkan env m =>
Allocated 'Coherent a -> Vector a -> m (Allocated 'Coherent a)
updateCoherent = forall env (m :: * -> *) a.
(MonadVulkan env m, Storable a) =>
Allocated 'Coherent a -> Vector a -> m (Allocated 'Coherent a)
Buffer.updateCoherentResize_
class GUpdateCoherent (fb :: Type -> Type) (fs :: Type -> Type) where
gUpdateCoherent :: forall env m b s . MonadVulkan env m => fb b -> fs s -> m (fb b)
instance GUpdateCoherent fb fs => GUpdateCoherent (M1 c cb fb) (M1 c cs fs) where
gUpdateCoherent :: forall env (m :: * -> *) b s.
MonadVulkan env m =>
M1 c cb fb b -> M1 c cs fs s -> m (M1 c cb fb b)
gUpdateCoherent (M1 fb b
gb) (M1 fs s
gs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall a b. (a -> b) -> a -> b
$ forall (fb :: * -> *) (fs :: * -> *) env (m :: * -> *) b s.
(GUpdateCoherent fb fs, MonadVulkan env m) =>
fb b -> fs s -> m (fb b)
gUpdateCoherent fb b
gb fs s
gs
instance (GUpdateCoherent fbl fsl, GUpdateCoherent fbr fsr) => GUpdateCoherent (fbl :*: fbr) (fsl :*: fsr) where
gUpdateCoherent :: forall env (m :: * -> *) b s.
MonadVulkan env m =>
(:*:) fbl fbr b -> (:*:) fsl fsr s -> m ((:*:) fbl fbr b)
gUpdateCoherent (fbl b
bl :*: fbr b
br) (fsl s
sl :*: fsr s
sr) = forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (fb :: * -> *) (fs :: * -> *) env (m :: * -> *) b s.
(GUpdateCoherent fb fs, MonadVulkan env m) =>
fb b -> fs s -> m (fb b)
gUpdateCoherent fbl b
bl fsl s
sl
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (fb :: * -> *) (fs :: * -> *) env (m :: * -> *) b s.
(GUpdateCoherent fb fs, MonadVulkan env m) =>
fb b -> fs s -> m (fb b)
gUpdateCoherent fbr b
br fsr s
sr
instance UpdateCoherent ba sa => GUpdateCoherent (K1 br ba) (K1 sr sa) where
gUpdateCoherent :: forall env (m :: * -> *) b s.
MonadVulkan env m =>
K1 br ba b -> K1 sr sa s -> m (K1 br ba b)
gUpdateCoherent (K1 ba
gb) (K1 sa
gs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i c (p :: k). c -> K1 i c p
K1 forall a b. (a -> b) -> a -> b
$ forall bufs stores env (m :: * -> *).
(UpdateCoherent bufs stores, MonadVulkan env m) =>
bufs -> stores -> m bufs
updateCoherent ba
gb sa
gs