{-# LANGUAGE AllowAmbiguousTypes #-}
module Resource.Texture
( Texture(..)
, destroy
, TextureError(..)
, Flat
, CubeMap
, ArrayOf
, TextureLayers(..)
, allocateCollectionWith
, allocateTextureWith
, debugNameCollection
, TextureLoader
, createImageView
, imageCI
, imageAllocationCI
, stageBufferCI
, stageAllocationCI
) where
import RIO
import Data.Bits ((.|.))
import Data.List qualified as List
import GHC.Stack (withFrozenCallStack)
import GHC.TypeLits (Nat, KnownNat, natVal)
import RIO.FilePath (takeBaseName)
import UnliftIO.Resource qualified as Resource
import Vulkan.Core10 qualified as Vk
import Vulkan.NamedType ((:::))
import Vulkan.Utils.Debug qualified as Debug
import Vulkan.Zero (zero)
import VulkanMemoryAllocator qualified as VMA
import Engine.Vulkan.Types (HasVulkan(getDevice), MonadVulkan, Queues)
import Resource.Collection qualified as Collection
import Resource.Image (AllocatedImage(..))
import Resource.Image qualified as Image
data TextureError
= LoadError Int64 Text
| LayerError Word32 Word32
| MipLevelsError Word32 Int
| ArrayError Word32 Word32
deriving (TextureError -> TextureError -> Bool
(TextureError -> TextureError -> Bool)
-> (TextureError -> TextureError -> Bool) -> Eq TextureError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextureError -> TextureError -> Bool
$c/= :: TextureError -> TextureError -> Bool
== :: TextureError -> TextureError -> Bool
$c== :: TextureError -> TextureError -> Bool
Eq, Eq TextureError
Eq TextureError
-> (TextureError -> TextureError -> Ordering)
-> (TextureError -> TextureError -> Bool)
-> (TextureError -> TextureError -> Bool)
-> (TextureError -> TextureError -> Bool)
-> (TextureError -> TextureError -> Bool)
-> (TextureError -> TextureError -> TextureError)
-> (TextureError -> TextureError -> TextureError)
-> Ord TextureError
TextureError -> TextureError -> Bool
TextureError -> TextureError -> Ordering
TextureError -> TextureError -> TextureError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TextureError -> TextureError -> TextureError
$cmin :: TextureError -> TextureError -> TextureError
max :: TextureError -> TextureError -> TextureError
$cmax :: TextureError -> TextureError -> TextureError
>= :: TextureError -> TextureError -> Bool
$c>= :: TextureError -> TextureError -> Bool
> :: TextureError -> TextureError -> Bool
$c> :: TextureError -> TextureError -> Bool
<= :: TextureError -> TextureError -> Bool
$c<= :: TextureError -> TextureError -> Bool
< :: TextureError -> TextureError -> Bool
$c< :: TextureError -> TextureError -> Bool
compare :: TextureError -> TextureError -> Ordering
$ccompare :: TextureError -> TextureError -> Ordering
$cp1Ord :: Eq TextureError
Ord, Int -> TextureError -> ShowS
[TextureError] -> ShowS
TextureError -> String
(Int -> TextureError -> ShowS)
-> (TextureError -> String)
-> ([TextureError] -> ShowS)
-> Show TextureError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextureError] -> ShowS
$cshowList :: [TextureError] -> ShowS
show :: TextureError -> String
$cshow :: TextureError -> String
showsPrec :: Int -> TextureError -> ShowS
$cshowsPrec :: Int -> TextureError -> ShowS
Show)
instance Exception TextureError
data Texture a = Texture
{ Texture a -> Format
tFormat :: Vk.Format
, Texture a -> Word32
tMipLevels :: Word32
, Texture a -> Word32
tLayers :: Word32
, Texture a -> AllocatedImage
tAllocatedImage :: AllocatedImage
}
deriving (Int -> Texture a -> ShowS
[Texture a] -> ShowS
Texture a -> String
(Int -> Texture a -> ShowS)
-> (Texture a -> String)
-> ([Texture a] -> ShowS)
-> Show (Texture a)
forall a. Int -> Texture a -> ShowS
forall a. [Texture a] -> ShowS
forall a. Texture a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Texture a] -> ShowS
$cshowList :: forall a. [Texture a] -> ShowS
show :: Texture a -> String
$cshow :: forall a. Texture a -> String
showsPrec :: Int -> Texture a -> ShowS
$cshowsPrec :: forall a. Int -> Texture a -> ShowS
Show)
data CubeMap
data Flat
data ArrayOf (layers :: Nat)
class TextureLayers a where
textureLayers :: Word32
instance TextureLayers CubeMap where
textureLayers :: Word32
textureLayers = Word32
6
instance TextureLayers Flat where
textureLayers :: Word32
textureLayers = Word32
1
instance KnownNat n => TextureLayers (ArrayOf n) where
textureLayers :: Word32
textureLayers = Integer -> Word32
forall a. Num a => Integer -> a
fromInteger (Integer -> Word32) -> Integer -> Word32
forall a b. (a -> b) -> a -> b
$ Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy @n)
type TextureLoader m layers = Vk.Format -> Queues Vk.CommandPool -> FilePath -> m (Texture layers)
type TextureLoaderAction src m layers = src -> m (Texture layers)
allocateCollectionWith
:: (Resource.MonadResource m, MonadVulkan env m, Traversable t)
=> TextureLoaderAction src m layers
-> t src
-> m (Resource.ReleaseKey, t (Texture layers))
allocateCollectionWith :: TextureLoaderAction src m layers
-> t src -> m (ReleaseKey, t (Texture layers))
allocateCollectionWith TextureLoaderAction src m layers
action t src
collection = do
t (ReleaseKey, Texture layers)
res <- (src -> m (ReleaseKey, Texture layers))
-> t src -> m (t (ReleaseKey, Texture layers))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (TextureLoaderAction src m layers
-> src -> m (ReleaseKey, Texture layers)
forall (m :: * -> *) env src layers.
(MonadResource m, MonadVulkan env m) =>
TextureLoaderAction src m layers
-> src -> m (ReleaseKey, Texture layers)
allocateTextureWith TextureLoaderAction src m layers
action) t src
collection
ReleaseKey
key <- IO () -> m ReleaseKey
forall (m :: * -> *). MonadResource m => IO () -> m ReleaseKey
Resource.register (IO () -> m ReleaseKey) -> IO () -> m ReleaseKey
forall a b. (a -> b) -> a -> b
$
((ReleaseKey, Texture layers) -> IO ())
-> t (ReleaseKey, Texture layers) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ReleaseKey -> IO ()
forall (m :: * -> *). MonadIO m => ReleaseKey -> m ()
Resource.release (ReleaseKey -> IO ())
-> ((ReleaseKey, Texture layers) -> ReleaseKey)
-> (ReleaseKey, Texture layers)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReleaseKey, Texture layers) -> ReleaseKey
forall a b. (a, b) -> a
fst) t (ReleaseKey, Texture layers)
res
pure (ReleaseKey
key, ((ReleaseKey, Texture layers) -> Texture layers)
-> t (ReleaseKey, Texture layers) -> t (Texture layers)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ReleaseKey, Texture layers) -> Texture layers
forall a b. (a, b) -> b
snd t (ReleaseKey, Texture layers)
res)
allocateTextureWith
:: (Resource.MonadResource m, MonadVulkan env m)
=> TextureLoaderAction src m layers
-> src
-> m (Resource.ReleaseKey, Texture layers)
allocateTextureWith :: TextureLoaderAction src m layers
-> src -> m (ReleaseKey, Texture layers)
allocateTextureWith TextureLoaderAction src m layers
action src
path = do
env
context <- m env
forall r (m :: * -> *). MonadReader r m => m r
ask
IO (Texture layers)
createTexture <- m (Texture layers) -> m (IO (Texture layers))
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (IO a)
toIO (m (Texture layers) -> m (IO (Texture layers)))
-> m (Texture layers) -> m (IO (Texture layers))
forall a b. (a -> b) -> a -> b
$ TextureLoaderAction src m layers
action src
path
IO (Texture layers)
-> (Texture layers -> IO ()) -> m (ReleaseKey, Texture layers)
forall (m :: * -> *) a.
MonadResource m =>
IO a -> (a -> IO ()) -> m (ReleaseKey, a)
Resource.allocate IO (Texture layers)
createTexture (env -> Texture layers -> IO ()
forall (io :: * -> *) context a.
(MonadIO io, HasVulkan context) =>
context -> Texture a -> io ()
destroy env
context)
debugNameCollection
:: ( Traversable t
, MonadVulkan env m
, HasLogFunc env
, HasCallStack
)
=> t (Texture layers)
-> t FilePath
-> m ()
debugNameCollection :: t (Texture layers) -> t String -> m ()
debugNameCollection t (Texture layers)
textures t String
paths = do
Device
device <- (env -> Device) -> m Device
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Device
forall a. HasVulkan a => a -> Device
getDevice
[((Natural, String), Texture layers)]
-> (((Natural, String), Texture layers) -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [((Natural, String), Texture layers)]
names \((Natural
ix, String
path), Texture{AllocatedImage
tAllocatedImage :: AllocatedImage
$sel:tAllocatedImage:Texture :: forall a. Texture a -> AllocatedImage
tAllocatedImage}) -> do
m () -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (m () -> m ()) -> (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
$ (Natural, String) -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (Natural
ix, String
path)
Device -> Image -> ByteString -> m ()
forall a (m :: * -> *).
(HasObjectType a, MonadIO m) =>
Device -> a -> ByteString -> m ()
Debug.nameObject Device
device (AllocatedImage -> Image
Image.aiImage AllocatedImage
tAllocatedImage) (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$
String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Natural -> String
forall a. Show a => a -> String
show @Natural Natural
ix String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
takeBaseName String
path
where
names :: [((Natural, String), Texture layers)]
names = [(Natural, String)]
-> [Texture layers] -> [((Natural, String), Texture layers)]
forall a b. [a] -> [b] -> [(a, b)]
List.zip
(t (Natural, String) -> [(Natural, String)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (t (Natural, String) -> [(Natural, String)])
-> t (Natural, String) -> [(Natural, String)]
forall a b. (a -> b) -> a -> b
$ t String -> t (Natural, String)
forall (t :: * -> *) ix a.
(Traversable t, Num ix) =>
t a -> t (ix, a)
Collection.enumerate t String
paths)
(t (Texture layers) -> [Texture layers]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (Texture layers)
textures)
destroy :: (MonadIO io, HasVulkan context) => context -> Texture a -> io ()
destroy :: context -> Texture a -> io ()
destroy context
context Texture{AllocatedImage
tAllocatedImage :: AllocatedImage
$sel:tAllocatedImage:Texture :: forall a. Texture a -> AllocatedImage
tAllocatedImage} =
context -> AllocatedImage -> io ()
forall (io :: * -> *) context.
(MonadIO io, HasVulkan context) =>
context -> AllocatedImage -> io ()
Image.destroy context
context AllocatedImage
tAllocatedImage
createImageView
:: (MonadIO io, HasVulkan context)
=> context
-> Vk.Image
-> Vk.Format
-> "mip levels" ::: Word32
-> "array layers" ::: Word32
-> io Vk.ImageView
createImageView :: context -> Image -> Format -> Word32 -> Word32 -> io ImageView
createImageView context
context Image
image Format
format Word32
mipLevels Word32
arrayLayers =
Device
-> ImageViewCreateInfo '[]
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ImageView
forall (a :: [*]) (io :: * -> *).
(Extendss ImageViewCreateInfo a, PokeChain a, MonadIO io) =>
Device
-> ImageViewCreateInfo a
-> ("allocator" ::: Maybe AllocationCallbacks)
-> io ImageView
Vk.createImageView (context -> Device
forall a. HasVulkan a => a -> Device
getDevice context
context) ImageViewCreateInfo '[]
imageViewCI "allocator" ::: Maybe AllocationCallbacks
forall a. Maybe a
Nothing
where
imageViewCI :: ImageViewCreateInfo '[]
imageViewCI = ImageViewCreateInfo '[]
forall a. Zero a => a
zero
{ $sel:image:ImageViewCreateInfo :: Image
Vk.image = Image
image
, $sel:viewType:ImageViewCreateInfo :: ImageViewType
Vk.viewType = ImageViewType
viewType
, $sel:format:ImageViewCreateInfo :: Format
Vk.format = Format
format
, $sel:components:ImageViewCreateInfo :: ComponentMapping
Vk.components = ComponentMapping
forall a. Zero a => a
zero
, $sel:subresourceRange:ImageViewCreateInfo :: ImageSubresourceRange
Vk.subresourceRange = ImageSubresourceRange
colorRange
}
viewType :: ImageViewType
viewType =
if Word32
arrayLayers Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
6 then
ImageViewType
Vk.IMAGE_VIEW_TYPE_CUBE
else
ImageViewType
Vk.IMAGE_VIEW_TYPE_2D
colorRange :: ImageSubresourceRange
colorRange =
ImageAspectFlags -> Word32 -> Word32 -> ImageSubresourceRange
Image.subresource ImageAspectFlags
Vk.IMAGE_ASPECT_COLOR_BIT Word32
mipLevels Word32
arrayLayers
imageCI :: Vk.Format -> Vk.Extent3D -> Word32 -> Word32 -> Vk.ImageCreateInfo '[]
imageCI :: Format -> Extent3D -> Word32 -> Word32 -> ImageCreateInfo '[]
imageCI Format
format Extent3D
extent Word32
mipLevels Word32
arrayLayers = ImageCreateInfo '[]
forall a. Zero a => a
zero
{ $sel:flags:ImageCreateInfo :: ImageCreateFlags
Vk.flags = ImageCreateFlags
flags
, $sel:imageType:ImageCreateInfo :: ImageType
Vk.imageType = ImageType
Vk.IMAGE_TYPE_2D
, $sel:format:ImageCreateInfo :: Format
Vk.format = Format
format
, $sel:extent:ImageCreateInfo :: Extent3D
Vk.extent = Extent3D
extent
, $sel:mipLevels:ImageCreateInfo :: Word32
Vk.mipLevels = Word32
mipLevels
, $sel:arrayLayers:ImageCreateInfo :: Word32
Vk.arrayLayers = if Bool
isCube then Word32
6 else Word32
arrayLayers
, $sel:tiling:ImageCreateInfo :: ImageTiling
Vk.tiling = ImageTiling
Vk.IMAGE_TILING_OPTIMAL
, $sel:initialLayout:ImageCreateInfo :: ImageLayout
Vk.initialLayout = ImageLayout
Vk.IMAGE_LAYOUT_UNDEFINED
, $sel:usage:ImageCreateInfo :: ImageUsageFlags
Vk.usage = ImageUsageFlags
usage
, $sel:sharingMode:ImageCreateInfo :: SharingMode
Vk.sharingMode = SharingMode
Vk.SHARING_MODE_EXCLUSIVE
, $sel:samples:ImageCreateInfo :: SampleCountFlagBits
Vk.samples = SampleCountFlagBits
Vk.SAMPLE_COUNT_1_BIT
}
where
isCube :: Bool
isCube =
Word32
arrayLayers Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
6
usage :: ImageUsageFlags
usage =
ImageUsageFlags
Vk.IMAGE_USAGE_SAMPLED_BIT ImageUsageFlags -> ImageUsageFlags -> ImageUsageFlags
forall a. Bits a => a -> a -> a
.|.
ImageUsageFlags
Vk.IMAGE_USAGE_TRANSFER_DST_BIT
flags :: ImageCreateFlags
flags =
if Bool
isCube then
ImageCreateFlags
Vk.IMAGE_CREATE_CUBE_COMPATIBLE_BIT
else
ImageCreateFlags
forall a. Zero a => a
zero
imageAllocationCI :: VMA.AllocationCreateInfo
imageAllocationCI :: AllocationCreateInfo
imageAllocationCI = AllocationCreateInfo
forall a. Zero a => a
zero
{ $sel:usage:AllocationCreateInfo :: MemoryUsage
VMA.usage = MemoryUsage
VMA.MEMORY_USAGE_GPU_ONLY
, $sel:requiredFlags:AllocationCreateInfo :: MemoryPropertyFlags
VMA.requiredFlags = MemoryPropertyFlags
Vk.MEMORY_PROPERTY_DEVICE_LOCAL_BIT
}
stageBufferCI :: Integral a => a -> Vk.BufferCreateInfo '[]
stageBufferCI :: a -> BufferCreateInfo '[]
stageBufferCI a
pixelBytes = BufferCreateInfo '[]
forall a. Zero a => a
zero
{ $sel:size:BufferCreateInfo :: DeviceSize
Vk.size = a -> DeviceSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
pixelBytes
, $sel:usage:BufferCreateInfo :: BufferUsageFlags
Vk.usage = BufferUsageFlags
Vk.BUFFER_USAGE_TRANSFER_SRC_BIT
, $sel:sharingMode:BufferCreateInfo :: SharingMode
Vk.sharingMode = SharingMode
Vk.SHARING_MODE_EXCLUSIVE
}
stageAllocationCI :: VMA.AllocationCreateInfo
stageAllocationCI :: AllocationCreateInfo
stageAllocationCI = AllocationCreateInfo
forall a. Zero a => a
zero
{ $sel:flags:AllocationCreateInfo :: AllocationCreateFlags
VMA.flags = AllocationCreateFlags
VMA.ALLOCATION_CREATE_MAPPED_BIT
, $sel:usage:AllocationCreateInfo :: MemoryUsage
VMA.usage = MemoryUsage
VMA.MEMORY_USAGE_CPU_TO_GPU
, $sel:requiredFlags:AllocationCreateInfo :: MemoryPropertyFlags
VMA.requiredFlags = MemoryPropertyFlags
Vk.MEMORY_PROPERTY_HOST_VISIBLE_BIT
}