{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wall -fno-warn-tabs #-} module Gpu.Vulkan.ImageView.Middle.Internal ( I, CreateInfo(..), create, recreate, recreate', destroy, group, create', destroy', lookup, Group, iToCore ) where import Prelude hiding (lookup) import Foreign.Ptr import Foreign.Marshal import Foreign.Storable import Foreign.Storable.PeekPoke import Control.Concurrent.STM import Control.Concurrent.STM.TSem import Data.TypeLevel.Maybe qualified as TMaybe import Data.TypeLevel.ParMaybe qualified as TPMaybe import Data.Map qualified as M import Data.IORef import Gpu.Vulkan.Enum import Gpu.Vulkan.Exception.Middle.Internal import Gpu.Vulkan.Exception.Enum import Gpu.Vulkan.Component.Middle.Internal import Gpu.Vulkan.ImageView.Enum import Gpu.Vulkan.AllocationCallbacks.Middle.Internal qualified as AllocationCallbacks import qualified Gpu.Vulkan.Device.Middle.Types as Device import qualified Gpu.Vulkan.Image.Middle.Internal as Image import qualified Gpu.Vulkan.ImageView.Core as C data CreateInfo mn = CreateInfo { forall (mn :: Maybe (*)). CreateInfo mn -> M mn createInfoNext :: TMaybe.M mn, forall (mn :: Maybe (*)). CreateInfo mn -> CreateFlags createInfoFlags :: CreateFlags, forall (mn :: Maybe (*)). CreateInfo mn -> I createInfoImage :: Image.I, forall (mn :: Maybe (*)). CreateInfo mn -> Type createInfoViewType :: Type, forall (mn :: Maybe (*)). CreateInfo mn -> Format createInfoFormat :: Format, forall (mn :: Maybe (*)). CreateInfo mn -> Mapping createInfoComponents :: Mapping, forall (mn :: Maybe (*)). CreateInfo mn -> SubresourceRange createInfoSubresourceRange :: Image.SubresourceRange } createInfoToCore :: WithPoked (TMaybe.M mn) => CreateInfo mn -> (Ptr C.CreateInfo -> IO a) -> IO () createInfoToCore :: forall (mn :: Maybe (*)) a. WithPoked (M mn) => CreateInfo mn -> (Ptr CreateInfo -> IO a) -> IO () createInfoToCore CreateInfo { createInfoNext :: forall (mn :: Maybe (*)). CreateInfo mn -> M mn createInfoNext = M mn mnxt, createInfoFlags :: forall (mn :: Maybe (*)). CreateInfo mn -> CreateFlags createInfoFlags = CreateFlagBits Word32 flgs, createInfoImage :: forall (mn :: Maybe (*)). CreateInfo mn -> I createInfoImage = Image.I IORef (Extent3d, I) rimg, createInfoViewType :: forall (mn :: Maybe (*)). CreateInfo mn -> Type createInfoViewType = Type Word32 tp, createInfoFormat :: forall (mn :: Maybe (*)). CreateInfo mn -> Format createInfoFormat = Format Word32 fmt, createInfoComponents :: forall (mn :: Maybe (*)). CreateInfo mn -> Mapping createInfoComponents = Mapping cpns, createInfoSubresourceRange :: forall (mn :: Maybe (*)). CreateInfo mn -> SubresourceRange createInfoSubresourceRange = SubresourceRange srr } Ptr CreateInfo -> IO a f = M mn -> (forall s. PtrS s (M mn) -> IO ()) -> IO () forall a b. WithPoked a => a -> (forall s. PtrS s a -> IO b) -> IO b forall b. M mn -> (forall s. PtrS s (M mn) -> IO b) -> IO b withPoked' M mn mnxt \PtrS s (M mn) pnxt -> PtrS s (M mn) -> (Ptr (M mn) -> IO a) -> IO () forall s a b. PtrS s a -> (Ptr a -> IO b) -> IO () withPtrS PtrS s (M mn) pnxt \(Ptr (M mn) -> Ptr () forall a b. Ptr a -> Ptr b castPtr -> Ptr () pnxt') -> IORef (Extent3d, I) -> IO (Extent3d, I) forall a. IORef a -> IO a readIORef IORef (Extent3d, I) rimg IO (Extent3d, I) -> ((Extent3d, I) -> IO a) -> IO a forall a b. IO a -> (a -> IO b) -> IO b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \(Extent3d _, I img) -> let ci :: CreateInfo ci = C.CreateInfo { createInfoSType :: () C.createInfoSType = (), createInfoPNext :: Ptr () C.createInfoPNext = Ptr () pnxt', createInfoFlags :: Word32 C.createInfoFlags = Word32 flgs, createInfoImage :: I C.createInfoImage = I img, createInfoViewType :: Word32 C.createInfoViewType = Word32 tp, createInfoFormat :: Word32 C.createInfoFormat = Word32 fmt, createInfoComponents :: Mapping C.createInfoComponents = Mapping -> Mapping mappingToCore Mapping cpns, createInfoSubresourceRange :: SubresourceRange C.createInfoSubresourceRange = SubresourceRange -> SubresourceRange Image.subresourceRangeToCore SubresourceRange srr } in CreateInfo -> (Ptr CreateInfo -> IO a) -> IO a forall a b. Pokable a => a -> (Ptr a -> IO b) -> IO b withPoked CreateInfo ci Ptr CreateInfo -> IO a f newtype I = I (IORef C.I) instance Show I where show :: I -> String show I _ = String "Vk.ImageView.I" iToCore :: I -> IO C.I iToCore :: I -> IO I iToCore (I IORef I i) = IORef I -> IO I forall a. IORef a -> IO a readIORef IORef I i iFromCore :: C.I -> IO I iFromCore :: I -> IO I iFromCore I i = IORef I -> I I (IORef I -> I) -> IO (IORef I) -> IO I forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> I -> IO (IORef I) forall a. a -> IO (IORef a) newIORef I i create :: WithPoked (TMaybe.M mn) => Device.D -> CreateInfo mn -> TPMaybe.M AllocationCallbacks.A mc -> IO I create :: forall (mn :: Maybe (*)) (mc :: Maybe (*)). WithPoked (M mn) => D -> CreateInfo mn -> M A mc -> IO I create (Device.D D dvc) CreateInfo mn ci M A mc mac = I -> IO I iFromCore (I -> IO I) -> IO I -> IO I forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< (Ptr I -> IO I) -> IO I forall a b. Storable a => (Ptr a -> IO b) -> IO b alloca \Ptr I pView -> do CreateInfo mn -> (Ptr CreateInfo -> IO ()) -> IO () forall (mn :: Maybe (*)) a. WithPoked (M mn) => CreateInfo mn -> (Ptr CreateInfo -> IO a) -> IO () createInfoToCore CreateInfo mn ci \Ptr CreateInfo pci -> M A mc -> (Ptr A -> IO ()) -> IO () forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO () AllocationCallbacks.mToCore M A mc mac \Ptr A pac -> do Int32 r <- D -> Ptr CreateInfo -> Ptr A -> Ptr I -> IO Int32 C.create D dvc Ptr CreateInfo pci Ptr A pac Ptr I pView Result -> IO () throwUnlessSuccess (Result -> IO ()) -> Result -> IO () forall a b. (a -> b) -> a -> b $ Int32 -> Result Result Int32 r Ptr I -> IO I forall a. Storable a => Ptr a -> IO a peek Ptr I pView group :: Device.D -> TPMaybe.M AllocationCallbacks.A mc -> (forall s . Group s k -> IO a) -> IO a group :: forall (mc :: Maybe (*)) k a. D -> M A mc -> (forall s. Group s k -> IO a) -> IO a group D dvc M A mc mac forall s. Group s k -> IO a f = do (TSem sem, TVar (Map k I) mng) <- STM (TSem, TVar (Map k I)) -> IO (TSem, TVar (Map k I)) forall a. STM a -> IO a atomically (STM (TSem, TVar (Map k I)) -> IO (TSem, TVar (Map k I))) -> STM (TSem, TVar (Map k I)) -> IO (TSem, TVar (Map k I)) forall a b. (a -> b) -> a -> b $ (,) (TSem -> TVar (Map k I) -> (TSem, TVar (Map k I))) -> STM TSem -> STM (TVar (Map k I) -> (TSem, TVar (Map k I))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Integer -> STM TSem newTSem Integer 1 STM (TVar (Map k I) -> (TSem, TVar (Map k I))) -> STM (TVar (Map k I)) -> STM (TSem, TVar (Map k I)) forall a b. STM (a -> b) -> STM a -> STM b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Map k I -> STM (TVar (Map k I)) forall a. a -> STM (TVar a) newTVar Map k I forall k a. Map k a M.empty a rtn <- Group Any k -> IO a forall s. Group s k -> IO a f (Group Any k -> IO a) -> Group Any k -> IO a forall a b. (a -> b) -> a -> b $ TSem -> TVar (Map k I) -> Group Any k forall s k. TSem -> TVar (Map k I) -> Group s k Group TSem sem TVar (Map k I) mng ((\I iv -> D -> I -> M A mc -> IO () forall (md :: Maybe (*)). D -> I -> M A md -> IO () destroy D dvc I iv M A mc mac) (I -> IO ()) -> Map k I -> IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () `mapM_`) (Map k I -> IO ()) -> IO (Map k I) -> IO () forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< STM (Map k I) -> IO (Map k I) forall a. STM a -> IO a atomically (TVar (Map k I) -> STM (Map k I) forall a. TVar a -> STM a readTVar TVar (Map k I) mng) a -> IO a forall a. a -> IO a forall (f :: * -> *) a. Applicative f => a -> f a pure a rtn data Group s k = Group TSem (TVar (M.Map k I)) create' :: (Ord k, WithPoked (TMaybe.M mn)) => Device.D -> Group sm k -> k -> CreateInfo mn -> TPMaybe.M AllocationCallbacks.A mc -> IO (Either String I) create' :: forall k (mn :: Maybe (*)) sm (mc :: Maybe (*)). (Ord k, WithPoked (M mn)) => D -> Group sm k -> k -> CreateInfo mn -> M A mc -> IO (Either String I) create' (Device.D D dvc) (Group TSem sem TVar (Map k I) is) k k CreateInfo mn ci M A mc mac = do Bool ok <- STM Bool -> IO Bool forall a. STM a -> IO a atomically do Maybe I mx <- (k -> Map k I -> Maybe I forall k a. Ord k => k -> Map k a -> Maybe a M.lookup k k) (Map k I -> Maybe I) -> STM (Map k I) -> STM (Maybe I) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> TVar (Map k I) -> STM (Map k I) forall a. TVar a -> STM a readTVar TVar (Map k I) is case Maybe I mx of Maybe I Nothing -> TSem -> STM () waitTSem TSem sem STM () -> STM Bool -> STM Bool forall a b. STM a -> STM b -> STM b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> Bool -> STM Bool forall a. a -> STM a forall (f :: * -> *) a. Applicative f => a -> f a pure Bool True Just I _ -> Bool -> STM Bool forall a. a -> STM a forall (f :: * -> *) a. Applicative f => a -> f a pure Bool False if Bool ok then do I i <- I -> IO I iFromCore (I -> IO I) -> IO I -> IO I forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< (Ptr I -> IO I) -> IO I forall a b. Storable a => (Ptr a -> IO b) -> IO b alloca \Ptr I pView -> do CreateInfo mn -> (Ptr CreateInfo -> IO ()) -> IO () forall (mn :: Maybe (*)) a. WithPoked (M mn) => CreateInfo mn -> (Ptr CreateInfo -> IO a) -> IO () createInfoToCore CreateInfo mn ci \Ptr CreateInfo pci -> M A mc -> (Ptr A -> IO ()) -> IO () forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO () AllocationCallbacks.mToCore M A mc mac \Ptr A pac -> do Int32 r <- D -> Ptr CreateInfo -> Ptr A -> Ptr I -> IO Int32 C.create D dvc Ptr CreateInfo pci Ptr A pac Ptr I pView Result -> IO () throwUnlessSuccess (Result -> IO ()) -> Result -> IO () forall a b. (a -> b) -> a -> b $ Int32 -> Result Result Int32 r Ptr I -> IO I forall a. Storable a => Ptr a -> IO a peek Ptr I pView STM () -> IO () forall a. STM a -> IO a atomically (STM () -> IO ()) -> STM () -> IO () forall a b. (a -> b) -> a -> b $ TVar (Map k I) -> (Map k I -> Map k I) -> STM () forall a. TVar a -> (a -> a) -> STM () modifyTVar TVar (Map k I) is (k -> I -> Map k I -> Map k I forall k a. Ord k => k -> a -> Map k a -> Map k a M.insert k k I i) STM () -> STM () -> STM () forall a b. STM a -> STM b -> STM b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> TSem -> STM () signalTSem TSem sem Either String I -> IO (Either String I) forall a. a -> IO a forall (f :: * -> *) a. Applicative f => a -> f a pure (Either String I -> IO (Either String I)) -> Either String I -> IO (Either String I) forall a b. (a -> b) -> a -> b $ I -> Either String I forall a b. b -> Either a b Right I i else Either String I -> IO (Either String I) forall a. a -> IO a forall (f :: * -> *) a. Applicative f => a -> f a pure (Either String I -> IO (Either String I)) -> (String -> Either String I) -> String -> IO (Either String I) forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> Either String I forall a b. a -> Either a b Left (String -> IO (Either String I)) -> String -> IO (Either String I) forall a b. (a -> b) -> a -> b $ String "Gpu.Vulkan.ImageView.create': The key already exist" destroy' :: Ord k => Device.D -> Group sm k -> k -> TPMaybe.M AllocationCallbacks.A mc -> IO (Either String ()) destroy' :: forall k sm (mc :: Maybe (*)). Ord k => D -> Group sm k -> k -> M A mc -> IO (Either String ()) destroy' D dvc (Group TSem sem TVar (Map k I) is) k k M A mc mac = do Maybe I mi <- STM (Maybe I) -> IO (Maybe I) forall a. STM a -> IO a atomically do Maybe I mx <- (k -> Map k I -> Maybe I forall k a. Ord k => k -> Map k a -> Maybe a M.lookup k k) (Map k I -> Maybe I) -> STM (Map k I) -> STM (Maybe I) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> TVar (Map k I) -> STM (Map k I) forall a. TVar a -> STM a readTVar TVar (Map k I) is case Maybe I mx of Maybe I Nothing -> Maybe I -> STM (Maybe I) forall a. a -> STM a forall (f :: * -> *) a. Applicative f => a -> f a pure Maybe I forall a. Maybe a Nothing Just I _ -> TSem -> STM () waitTSem TSem sem STM () -> STM (Maybe I) -> STM (Maybe I) forall a b. STM a -> STM b -> STM b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> Maybe I -> STM (Maybe I) forall a. a -> STM a forall (f :: * -> *) a. Applicative f => a -> f a pure Maybe I mx case Maybe I mi of Maybe I Nothing -> Either String () -> IO (Either String ()) forall a. a -> IO a forall (f :: * -> *) a. Applicative f => a -> f a pure (Either String () -> IO (Either String ())) -> Either String () -> IO (Either String ()) forall a b. (a -> b) -> a -> b $ String -> Either String () forall a b. a -> Either a b Left String "Gpu.Vulkan.ImageView.destroy: No such key" Just I i -> do D -> I -> M A mc -> IO () forall (md :: Maybe (*)). D -> I -> M A md -> IO () destroy D dvc I i M A mc mac STM (Either String ()) -> IO (Either String ()) forall a. STM a -> IO a atomically do TVar (Map k I) -> (Map k I -> Map k I) -> STM () forall a. TVar a -> (a -> a) -> STM () modifyTVar TVar (Map k I) is (k -> Map k I -> Map k I forall k a. Ord k => k -> Map k a -> Map k a M.delete k k) TSem -> STM () signalTSem TSem sem Either String () -> STM (Either String ()) forall a. a -> STM a forall (f :: * -> *) a. Applicative f => a -> f a pure (Either String () -> STM (Either String ())) -> Either String () -> STM (Either String ()) forall a b. (a -> b) -> a -> b $ () -> Either String () forall a b. b -> Either a b Right () lookup :: Ord k => Group sm k -> k -> IO (Maybe I) lookup :: forall k sm. Ord k => Group sm k -> k -> IO (Maybe I) lookup (Group TSem _sem TVar (Map k I) is) k k = STM (Maybe I) -> IO (Maybe I) forall a. STM a -> IO a atomically (STM (Maybe I) -> IO (Maybe I)) -> STM (Maybe I) -> IO (Maybe I) forall a b. (a -> b) -> a -> b $ k -> Map k I -> Maybe I forall k a. Ord k => k -> Map k a -> Maybe a M.lookup k k (Map k I -> Maybe I) -> STM (Map k I) -> STM (Maybe I) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> TVar (Map k I) -> STM (Map k I) forall a. TVar a -> STM a readTVar TVar (Map k I) is recreate :: WithPoked (TMaybe.M mn) => Device.D -> CreateInfo mn -> TPMaybe.M AllocationCallbacks.A mc -> TPMaybe.M AllocationCallbacks.A md -> I -> IO () recreate :: forall (mn :: Maybe (*)) (mc :: Maybe (*)) (md :: Maybe (*)). WithPoked (M mn) => D -> CreateInfo mn -> M A mc -> M A md -> I -> IO () recreate (Device.D D dvc) CreateInfo mn ci M A mc macc M A md macd (I IORef I ri) = (Ptr I -> IO ()) -> IO () forall a b. Storable a => (Ptr a -> IO b) -> IO b alloca \Ptr I pView -> CreateInfo mn -> (Ptr CreateInfo -> IO ()) -> IO () forall (mn :: Maybe (*)) a. WithPoked (M mn) => CreateInfo mn -> (Ptr CreateInfo -> IO a) -> IO () createInfoToCore CreateInfo mn ci \Ptr CreateInfo pci -> M A mc -> (Ptr A -> IO ()) -> IO () forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO () AllocationCallbacks.mToCore M A mc macc \Ptr A pac -> do Int32 r <- D -> Ptr CreateInfo -> Ptr A -> Ptr I -> IO Int32 C.create D dvc Ptr CreateInfo pci Ptr A pac Ptr I pView Result -> IO () throwUnlessSuccess (Result -> IO ()) -> Result -> IO () forall a b. (a -> b) -> a -> b $ Int32 -> Result Result Int32 r I io <- IORef I -> IO I forall a. IORef a -> IO a readIORef IORef I ri M A md -> (Ptr A -> IO ()) -> IO () forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO () AllocationCallbacks.mToCore M A md macd ((Ptr A -> IO ()) -> IO ()) -> (Ptr A -> IO ()) -> IO () forall a b. (a -> b) -> a -> b $ D -> I -> Ptr A -> IO () C.destroy D dvc I io IORef I -> I -> IO () forall a. IORef a -> a -> IO () writeIORef IORef I ri (I -> IO ()) -> IO I -> IO () forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Ptr I -> IO I forall a. Storable a => Ptr a -> IO a peek Ptr I pView recreate' :: WithPoked (TMaybe.M mn) => Device.D -> CreateInfo mn -> TPMaybe.M AllocationCallbacks.A mc -> TPMaybe.M AllocationCallbacks.A md -> I -> IO a -> IO () recreate' :: forall (mn :: Maybe (*)) (mc :: Maybe (*)) (md :: Maybe (*)) a. WithPoked (M mn) => D -> CreateInfo mn -> M A mc -> M A md -> I -> IO a -> IO () recreate' (Device.D D dvc) CreateInfo mn ci M A mc macc M A md macd (I IORef I ri) IO a act = (Ptr I -> IO ()) -> IO () forall a b. Storable a => (Ptr a -> IO b) -> IO b alloca \Ptr I pView -> CreateInfo mn -> (Ptr CreateInfo -> IO ()) -> IO () forall (mn :: Maybe (*)) a. WithPoked (M mn) => CreateInfo mn -> (Ptr CreateInfo -> IO a) -> IO () createInfoToCore CreateInfo mn ci \Ptr CreateInfo pci -> M A mc -> (Ptr A -> IO a) -> IO () forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO () AllocationCallbacks.mToCore M A mc macc \Ptr A pac -> do Int32 r <- D -> Ptr CreateInfo -> Ptr A -> Ptr I -> IO Int32 C.create D dvc Ptr CreateInfo pci Ptr A pac Ptr I pView Result -> IO () throwUnlessSuccess (Result -> IO ()) -> Result -> IO () forall a b. (a -> b) -> a -> b $ Int32 -> Result Result Int32 r I io <- IORef I -> IO I forall a. IORef a -> IO a readIORef IORef I ri IORef I -> I -> IO () forall a. IORef a -> a -> IO () writeIORef IORef I ri (I -> IO ()) -> IO I -> IO () forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< Ptr I -> IO I forall a. Storable a => Ptr a -> IO a peek Ptr I pView a rtn <- IO a act M A md -> (Ptr A -> IO ()) -> IO () forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO () AllocationCallbacks.mToCore M A md macd ((Ptr A -> IO ()) -> IO ()) -> (Ptr A -> IO ()) -> IO () forall a b. (a -> b) -> a -> b $ D -> I -> Ptr A -> IO () C.destroy D dvc I io a -> IO a forall a. a -> IO a forall (f :: * -> *) a. Applicative f => a -> f a pure a rtn destroy :: Device.D -> I -> TPMaybe.M AllocationCallbacks.A md -> IO () destroy :: forall (md :: Maybe (*)). D -> I -> M A md -> IO () destroy (Device.D D dvc) I iv M A md mac = do I iv' <- I -> IO I iToCore I iv M A md -> (Ptr A -> IO ()) -> IO () forall (ma :: Maybe (*)) b. M A ma -> (Ptr A -> IO b) -> IO () AllocationCallbacks.mToCore M A md mac ((Ptr A -> IO ()) -> IO ()) -> (Ptr A -> IO ()) -> IO () forall a b. (a -> b) -> a -> b $ D -> I -> Ptr A -> IO () C.destroy D dvc I iv'