module Resource.Texture.Ktx1
  ( createTexture
  ) where

import RIO

import Codec.Ktx qualified as Ktx1
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Data.Text qualified as Text
import Data.Vector qualified as Vector
import Foreign qualified
import Vulkan.Core10 qualified as Vk
import Vulkan.Utils.FromGL qualified as FromGL
import VulkanMemoryAllocator qualified as VMA

import Engine.Types (StageRIO)
import Engine.Vulkan.Types (HasVulkan(..), Queues)
import Resource.Compressed.Zstd qualified as Zstd
import Resource.Image (AllocatedImage(..))
import Resource.Image qualified as Image
import Resource.Texture (Texture(..), TextureLayers(..))
import Resource.Texture qualified as Texture

createTexture
  :: forall a st . (TextureLayers a)
  => Queues Vk.CommandPool
  -> FilePath
  -> StageRIO st (Texture a)
createTexture :: Queues CommandPool -> FilePath -> StageRIO st (Texture a)
createTexture Queues CommandPool
pool FilePath
path = do
  App GlobalHandles st
context <- RIO (App GlobalHandles st) (App GlobalHandles st)
forall r (m :: * -> *). MonadReader r m => m r
ask
  let vma :: Allocator
vma = App GlobalHandles st -> Allocator
forall a. HasVulkan a => a -> Allocator
getAllocator App GlobalHandles st
context

  Utf8Builder -> RIO (App GlobalHandles st) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO (App GlobalHandles st) ())
-> Utf8Builder -> RIO (App GlobalHandles st) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Loading " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
path
  FilePath
-> RIO (App GlobalHandles st) (Either (ByteOffset, FilePath) Ktx)
loader FilePath
path RIO (App GlobalHandles st) (Either (ByteOffset, FilePath) Ktx)
-> (Either (ByteOffset, FilePath) Ktx -> StageRIO st (Texture a))
-> StageRIO st (Texture a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left (ByteOffset
offset, FilePath
err) -> do
      Utf8Builder -> RIO (App GlobalHandles st) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO (App GlobalHandles st) ())
-> Utf8Builder -> RIO (App GlobalHandles st) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Texture load error: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
err
      TextureError -> StageRIO st (Texture a)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TextureError -> StageRIO st (Texture a))
-> TextureError -> StageRIO st (Texture a)
forall a b. (a -> b) -> a -> b
$ ByteOffset -> Text -> TextureError
Texture.LoadError ByteOffset
offset (FilePath -> Text
Text.pack FilePath
err)
    Right Ktx1.Ktx{Header
$sel:header:Ktx :: Ktx -> Header
header :: Header
header, $sel:images:Ktx :: Ktx -> MipLevels
images=MipLevels
ktxImages} -> do
      let
        skipMips :: Int
skipMips = Int
0 -- DEBUG: Vector.length ktxImages `div` 2
        mipsSkipped :: Int
mipsSkipped = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (MipLevels -> Int
forall a. Vector a -> Int
Vector.length MipLevels
ktxImages Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
skipMips
        images :: MipLevels
images = Int -> MipLevels -> MipLevels
forall a. Int -> Vector a -> Vector a
Vector.drop Int
mipsSkipped MipLevels
ktxImages
        mipLevels :: Word32
mipLevels = Header -> Word32
Ktx1.numberOfMipmapLevels Header
header Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
mipsSkipped

      Bool
-> RIO (App GlobalHandles st) () -> RIO (App GlobalHandles st) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MipLevels -> Bool
forall a. Vector a -> Bool
Vector.null MipLevels
images) (RIO (App GlobalHandles st) () -> RIO (App GlobalHandles st) ())
-> RIO (App GlobalHandles st) () -> RIO (App GlobalHandles st) ()
forall a b. (a -> b) -> a -> b
$
        TextureError -> RIO (App GlobalHandles st) ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TextureError -> RIO (App GlobalHandles st) ())
-> TextureError -> RIO (App GlobalHandles st) ()
forall a b. (a -> b) -> a -> b
$ ByteOffset -> Text -> TextureError
Texture.LoadError ByteOffset
0 Text
"At least one image must be present in KTX"

      Bool
-> RIO (App GlobalHandles st) () -> RIO (App GlobalHandles st) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
mipLevels Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== MipLevels -> Int
forall a. Vector a -> Int
Vector.length MipLevels
images) (RIO (App GlobalHandles st) () -> RIO (App GlobalHandles st) ())
-> RIO (App GlobalHandles st) () -> RIO (App GlobalHandles st) ()
forall a b. (a -> b) -> a -> b
$
        TextureError -> RIO (App GlobalHandles st) ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TextureError -> RIO (App GlobalHandles st) ())
-> TextureError -> RIO (App GlobalHandles st) ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Int -> TextureError
Texture.MipLevelsError Word32
mipLevels (MipLevels -> Int
forall a. Vector a -> Int
Vector.length MipLevels
images)

      -- XXX: https://github.com/KhronosGroup/KTX-Software/blob/bf849b7f/lib/vk_format.h#L676
      Format
format <- case Header -> Word32
Ktx1.glInternalFormat Header
header of
        -- XXX: Force all BC7s to SRGB
        Word32
36492 ->
          Format -> RIO (App GlobalHandles st) Format
forall (f :: * -> *) a. Applicative f => a -> f a
pure Format
Vk.FORMAT_BC7_SRGB_BLOCK
        Word32
other ->
          case Word32 -> Maybe Format
forall a. (Eq a, Num a) => a -> Maybe Format
FromGL.internalFormat Word32
other of
            Maybe Format
Nothing ->
              FilePath -> RIO (App GlobalHandles st) Format
forall a. HasCallStack => FilePath -> a
error (FilePath -> RIO (App GlobalHandles st) Format)
-> FilePath -> RIO (App GlobalHandles st) Format
forall a b. (a -> b) -> a -> b
$ FilePath
"Unexpected glInternalFormat: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Word32 -> FilePath
forall a. Show a => a -> FilePath
show Word32
other -- TODO: throwIo
            Just Format
fmt ->
              -- XXX: going in blind
              Format -> RIO (App GlobalHandles st) Format
forall (f :: * -> *) a. Applicative f => a -> f a
pure Format
fmt
      Utf8Builder -> RIO (App GlobalHandles st) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO (App GlobalHandles st) ())
-> Utf8Builder -> RIO (App GlobalHandles st) ()
forall a b. (a -> b) -> a -> b
$ [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
        [ Utf8Builder
"Loading format "
        , Word32 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Word32 -> Utf8Builder) -> Word32 -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Header -> Word32
Ktx1.glInternalFormat Header
header
        , Utf8Builder
" as "
        , Format -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Format
format
        ]

      -- XXX: https://github.com/KhronosGroup/KTX-Software/blob/bf849b7f/lib/vkloader.c#L552
      let
        extent :: Extent3D
extent = Extent3D :: Word32 -> Word32 -> Word32 -> Extent3D
Vk.Extent3D
          { $sel:width:Extent3D :: Word32
Vk.width  = Header -> Word32
Ktx1.pixelWidth Header
header Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`Foreign.shiftR` Int
mipsSkipped
          , $sel:height:Extent3D :: Word32
Vk.height = Header -> Word32
Ktx1.pixelHeight Header
header Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`Foreign.shiftR` Int
mipsSkipped
          , $sel:depth:Extent3D :: Word32
Vk.depth  = Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
1 (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ Header -> Word32
Ktx1.pixelDepth Header
header
          }
        arrayLayers :: Word32
arrayLayers = Word32 -> Word32 -> Word32
forall a. Ord a => a -> a -> a
max Word32
1 (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ Header -> Word32
Ktx1.numberOfArrayElements Header
header

      -- TODO: basisu can encode movies as arrays, this could be handy
      Bool
-> RIO (App GlobalHandles st) () -> RIO (App GlobalHandles st) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
arrayLayers Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
1) do
        Utf8Builder -> RIO (App GlobalHandles st) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"TODO: arrayLayers > 1"
        TextureError -> RIO (App GlobalHandles st) ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TextureError -> RIO (App GlobalHandles st) ())
-> TextureError -> RIO (App GlobalHandles st) ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> TextureError
Texture.ArrayError Word32
1 Word32
arrayLayers

      let
        numLayers :: Word32
numLayers = Header -> Word32
Ktx1.numberOfFaces Header
header
        mipSizes :: Vector Word32
mipSizes = (MipLevel -> Word32) -> MipLevels -> Vector Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
(*) Word32
numLayers (Word32 -> Word32) -> (MipLevel -> Word32) -> MipLevel -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MipLevel -> Word32
Ktx1.imageSize) MipLevels
images

        offsets' :: Vector Word32
offsets' = (Word32 -> Word32 -> Word32)
-> Word32 -> Vector Word32 -> Vector Word32
forall a b. (a -> b -> a) -> a -> Vector b -> Vector a
Vector.scanl' Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
(+) Word32
0 Vector Word32
mipSizes
        totalSize :: Word32
totalSize = Vector Word32 -> Word32
forall a. Vector a -> a
Vector.last Vector Word32
offsets'
        offsets :: Vector Word32
offsets = Vector Word32 -> Vector Word32
forall a. Vector a -> Vector a
Vector.init Vector Word32
offsets'

      Utf8Builder -> RIO (App GlobalHandles st) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO (App GlobalHandles st) ())
-> Utf8Builder -> RIO (App GlobalHandles st) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"mipSizes: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Vector Word32 -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Vector Word32
mipSizes
      Utf8Builder -> RIO (App GlobalHandles st) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO (App GlobalHandles st) ())
-> Utf8Builder -> RIO (App GlobalHandles st) ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"offsets: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Vector Word32 -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Vector Word32
offsets

      {- XXX:
        Image created before staging buffer due to `Image.copyBufferToImage`
        issued inside `VMA.withBuffer` bracket.
      -}
      (Image
image, Allocation
allocation, AllocationInfo
_info) <- Allocator
-> ImageCreateInfo '[]
-> AllocationCreateInfo
-> RIO (App GlobalHandles st) (Image, Allocation, AllocationInfo)
forall (a :: [*]) (io :: * -> *).
(Extendss ImageCreateInfo a, PokeChain a, MonadIO io) =>
Allocator
-> ImageCreateInfo a
-> AllocationCreateInfo
-> io (Image, Allocation, AllocationInfo)
VMA.createImage
        Allocator
vma
        (Format -> Extent3D -> Word32 -> Word32 -> ImageCreateInfo '[]
Texture.imageCI Format
format Extent3D
extent Word32
mipLevels Word32
numLayers)
        AllocationCreateInfo
Texture.imageAllocationCI

      App GlobalHandles st
-> Queues CommandPool
-> Image
-> Word32
-> Word32
-> Format
-> ("old" ::: ImageLayout)
-> ("old" ::: ImageLayout)
-> RIO (App GlobalHandles st) ()
forall context env.
HasVulkan context =>
context
-> Queues CommandPool
-> Image
-> Word32
-> Word32
-> Format
-> ("old" ::: ImageLayout)
-> ("old" ::: ImageLayout)
-> RIO env ()
Image.transitionImageLayout
        App GlobalHandles st
context
        Queues CommandPool
pool
        Image
image
        Word32
mipLevels
        Word32
numLayers -- XXX: arrayLayers is always 0 for now
        Format
format
        "old" ::: ImageLayout
Vk.IMAGE_LAYOUT_UNDEFINED
        "old" ::: ImageLayout
Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL

      Bool
-> RIO (App GlobalHandles st) () -> RIO (App GlobalHandles st) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
numLayers Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== TextureLayers a => Word32
forall a. TextureLayers a => Word32
textureLayers @a) (RIO (App GlobalHandles st) () -> RIO (App GlobalHandles st) ())
-> RIO (App GlobalHandles st) () -> RIO (App GlobalHandles st) ()
forall a b. (a -> b) -> a -> b
$
        TextureError -> RIO (App GlobalHandles st) ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (TextureError -> RIO (App GlobalHandles st) ())
-> TextureError -> RIO (App GlobalHandles st) ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> TextureError
Texture.ArrayError (TextureLayers a => Word32
forall a. TextureLayers a => Word32
textureLayers @a) Word32
numLayers

      Allocator
-> BufferCreateInfo '[]
-> AllocationCreateInfo
-> (RIO (App GlobalHandles st) (Buffer, Allocation, AllocationInfo)
    -> ((Buffer, Allocation, AllocationInfo)
        -> RIO (App GlobalHandles st) ())
    -> ((Buffer, Allocation, AllocationInfo)
        -> RIO (App GlobalHandles st) ())
    -> RIO (App GlobalHandles st) ())
-> ((Buffer, Allocation, AllocationInfo)
    -> RIO (App GlobalHandles st) ())
-> RIO (App GlobalHandles st) ()
forall (a :: [*]) (io :: * -> *) r.
(Extendss BufferCreateInfo a, PokeChain a, MonadIO io) =>
Allocator
-> BufferCreateInfo a
-> AllocationCreateInfo
-> (io (Buffer, Allocation, AllocationInfo)
    -> ((Buffer, Allocation, AllocationInfo) -> io ()) -> r)
-> r
VMA.withBuffer Allocator
vma (Word32 -> BufferCreateInfo '[]
forall a. Integral a => a -> BufferCreateInfo '[]
Texture.stageBufferCI Word32
totalSize) AllocationCreateInfo
Texture.stageAllocationCI RIO (App GlobalHandles st) (Buffer, Allocation, AllocationInfo)
-> ((Buffer, Allocation, AllocationInfo)
    -> RIO (App GlobalHandles st) ())
-> ((Buffer, Allocation, AllocationInfo)
    -> RIO (App GlobalHandles st) ())
-> RIO (App GlobalHandles st) ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket \(Buffer
staging, Allocation
stage, AllocationInfo
stageInfo) -> do
        let ixMipImages :: Vector (Word32, Word32, MipLevel)
ixMipImages = Vector Word32
-> Vector Word32 -> MipLevels -> Vector (Word32, Word32, MipLevel)
forall a b c. Vector a -> Vector b -> Vector c -> Vector (a, b, c)
Vector.zip3 ([Word32] -> Vector Word32
forall a. [a] -> Vector a
Vector.fromList [Word32
0..]) Vector Word32
offsets MipLevels
images
        Vector (Word32, Word32, MipLevel)
-> ((Word32, Word32, MipLevel) -> RIO (App GlobalHandles st) ())
-> RIO (App GlobalHandles st) ()
forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
Vector.forM_ Vector (Word32, Word32, MipLevel)
ixMipImages \(Word32
mipIx, Word32
offset, Ktx1.MipLevel{Word32
imageSize :: Word32
$sel:imageSize:MipLevel :: MipLevel -> Word32
imageSize, Vector ArrayElement
$sel:arrayElements:MipLevel :: MipLevel -> Vector ArrayElement
arrayElements :: Vector ArrayElement
arrayElements}) -> do
          let ixArrayElements :: Vector (Word32, ArrayElement)
ixArrayElements = Vector Word32
-> Vector ArrayElement -> Vector (Word32, ArrayElement)
forall a b. Vector a -> Vector b -> Vector (a, b)
Vector.zip ([Word32] -> Vector Word32
forall a. [a] -> Vector a
Vector.fromList [Word32
0..]) Vector ArrayElement
arrayElements
          Vector (Word32, ArrayElement)
-> ((Word32, ArrayElement) -> RIO (App GlobalHandles st) ())
-> RIO (App GlobalHandles st) ()
forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
Vector.forM_ Vector (Word32, ArrayElement)
ixArrayElements \(Word32
arrayIx, Ktx1.ArrayElement{Vector Face
$sel:faces:ArrayElement :: ArrayElement -> Vector Face
faces :: Vector Face
faces}) -> do
            let ixFaces :: Vector (Word32, Face)
ixFaces = Vector Word32 -> Vector Face -> Vector (Word32, Face)
forall a b. Vector a -> Vector b -> Vector (a, b)
Vector.zip ([Word32] -> Vector Word32
forall a. [a] -> Vector a
Vector.fromList [Word32
0..]) Vector Face
faces
            Vector (Word32, Face)
-> ((Word32, Face) -> RIO (App GlobalHandles st) ())
-> RIO (App GlobalHandles st) ()
forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
Vector.forM_ Vector (Word32, Face)
ixFaces \(Word32
faceIx, Ktx1.Face{Vector ZSlice
$sel:zSlices:Face :: Face -> Vector ZSlice
zSlices :: Vector ZSlice
zSlices}) -> do
              let ixSlices :: Vector (Word32, ZSlice)
ixSlices = Vector Word32 -> Vector ZSlice -> Vector (Word32, ZSlice)
forall a b. Vector a -> Vector b -> Vector (a, b)
Vector.zip ([Word32] -> Vector Word32
forall a. [a] -> Vector a
Vector.fromList [Word32
0..]) Vector ZSlice
zSlices
              Vector (Word32, ZSlice)
-> ((Word32, ZSlice) -> RIO (App GlobalHandles st) ())
-> RIO (App GlobalHandles st) ()
forall (m :: * -> *) a b. Monad m => Vector a -> (a -> m b) -> m ()
Vector.forM_ Vector (Word32, ZSlice)
ixSlices \(Word32
sliceIx, Ktx1.ZSlice{ByteString
$sel:block:ZSlice :: ZSlice -> ByteString
block :: ByteString
block}) -> do
                let
                  indices :: Utf8Builder
indices = [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
                    [ Utf8Builder
"["
                    , Utf8Builder
" mip:" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display @Word32 Word32
mipIx
                    , Utf8Builder
" arr:" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display @Word32 Word32
arrayIx
                    , Utf8Builder
" fac:" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display @Word32 Word32
faceIx
                    , Utf8Builder
" slc:" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display @Word32 Word32
sliceIx
                    , Utf8Builder
" ]"
                    ]
                let blockOffset :: Word32
blockOffset = Word32
offset Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
faceIx Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
imageSize
                let sectionPtr :: Ptr Any
sectionPtr = Ptr () -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
Foreign.plusPtr (AllocationInfo -> Ptr ()
VMA.mappedData AllocationInfo
stageInfo) (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
blockOffset)
                Utf8Builder -> RIO (App GlobalHandles st) ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO (App GlobalHandles st) ())
-> Utf8Builder -> RIO (App GlobalHandles st) ()
forall a b. (a -> b) -> a -> b
$ [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
                  [ Utf8Builder
indices
                  , Utf8Builder
" base offset = "
                  , Word32 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Word32
offset
                  , Utf8Builder
" image offset = "
                  , Word32 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Word32 -> Utf8Builder) -> Word32 -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Word32
faceIx Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
imageSize
                  , Utf8Builder
" image size = "
                  , Word32 -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Word32
imageSize
                  ]
                IO () -> RIO (App GlobalHandles st) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO (App GlobalHandles st) ())
-> IO () -> RIO (App GlobalHandles st) ()
forall a b. (a -> b) -> a -> b
$ ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
block \(Ptr CChar
pixelsPtr, Int
pixelBytes) -> do
                  if Int
pixelBytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
imageSize then
                    FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
"assert: MipLevel.imageSize matches block.pixelBytes"
                  else
                    -- traceShowM (sectionPtr, pixelBytes)
                    Ptr Any -> Ptr Any -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
Foreign.copyBytes Ptr Any
sectionPtr (Ptr CChar -> Ptr Any
forall a b. Ptr a -> Ptr b
Foreign.castPtr Ptr CChar
pixelsPtr) Int
pixelBytes

        Allocator
-> Allocation
-> ("offset" ::: DeviceSize)
-> ("offset" ::: DeviceSize)
-> RIO (App GlobalHandles st) ()
forall (io :: * -> *).
MonadIO io =>
Allocator
-> Allocation
-> ("offset" ::: DeviceSize)
-> ("offset" ::: DeviceSize)
-> io ()
VMA.flushAllocation Allocator
vma Allocation
stage "offset" ::: DeviceSize
0 "offset" ::: DeviceSize
Vk.WHOLE_SIZE

        -- XXX: copying to image while the staging buffer is still alive
        App GlobalHandles st
-> Queues CommandPool
-> Buffer
-> Image
-> Extent3D
-> Vector Word32
-> Word32
-> RIO (App GlobalHandles st) ()
forall context (t :: * -> *) deviceSize env.
(HasVulkan context, Foldable t, Integral deviceSize) =>
context
-> Queues CommandPool
-> Buffer
-> Image
-> Extent3D
-> ("mip offsets" ::: t deviceSize)
-> Word32
-> RIO env ()
Image.copyBufferToImage
          App GlobalHandles st
context
          Queues CommandPool
pool
          Buffer
staging
          Image
image
          Extent3D
extent
          Vector Word32
offsets
          Word32
numLayers

      -- XXX: staging buffer is gone

      App GlobalHandles st
-> Queues CommandPool
-> Image
-> Word32
-> Word32
-> Format
-> ("old" ::: ImageLayout)
-> ("old" ::: ImageLayout)
-> RIO (App GlobalHandles st) ()
forall context env.
HasVulkan context =>
context
-> Queues CommandPool
-> Image
-> Word32
-> Word32
-> Format
-> ("old" ::: ImageLayout)
-> ("old" ::: ImageLayout)
-> RIO env ()
Image.transitionImageLayout
        App GlobalHandles st
context
        Queues CommandPool
pool
        Image
image
        Word32
mipLevels
        Word32
numLayers -- XXX: arrayLayers is always 0 for now
        Format
format
        "old" ::: ImageLayout
Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL
        "old" ::: ImageLayout
Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL

      ImageView
imageView <- App GlobalHandles st
-> Image
-> Format
-> Word32
-> Word32
-> RIO (App GlobalHandles st) ImageView
forall (io :: * -> *) context.
(MonadIO io, HasVulkan context) =>
context -> Image -> Format -> Word32 -> Word32 -> io ImageView
Texture.createImageView
        App GlobalHandles st
context
        Image
image
        Format
format
        Word32
mipLevels
        Word32
numLayers

      let
        allocatedImage :: AllocatedImage
allocatedImage = AllocatedImage :: Allocation -> Image -> ImageView -> AllocatedImage
AllocatedImage
          { $sel:aiAllocation:AllocatedImage :: Allocation
aiAllocation = Allocation
allocation
          , $sel:aiImage:AllocatedImage :: Image
aiImage      = Image
image
          , $sel:aiImageView:AllocatedImage :: ImageView
aiImageView  = ImageView
imageView
          }
      pure Texture :: forall a. Format -> Word32 -> Word32 -> AllocatedImage -> Texture a
Texture
        { $sel:tFormat:Texture :: Format
tFormat         = Format
format
        , $sel:tMipLevels:Texture :: Word32
tMipLevels      = Word32
mipLevels
        , $sel:tLayers:Texture :: Word32
tLayers         = Word32
numLayers
        , $sel:tAllocatedImage:Texture :: AllocatedImage
tAllocatedImage = AllocatedImage
allocatedImage
        }
  where
    loader :: FilePath
-> RIO (App GlobalHandles st) (Either (ByteOffset, FilePath) Ktx)
loader = IO (Either (ByteOffset, FilePath) Ktx)
-> RIO (App GlobalHandles st) (Either (ByteOffset, FilePath) Ktx)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (ByteOffset, FilePath) Ktx)
 -> RIO (App GlobalHandles st) (Either (ByteOffset, FilePath) Ktx))
-> (FilePath -> IO (Either (ByteOffset, FilePath) Ktx))
-> FilePath
-> RIO (App GlobalHandles st) (Either (ByteOffset, FilePath) Ktx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> IO (Either (ByteOffset, FilePath) Ktx))
-> (FilePath -> IO (Either (ByteOffset, FilePath) Ktx))
-> FilePath
-> IO (Either (ByteOffset, FilePath) Ktx)
forall (m :: * -> *) b.
MonadIO m =>
(ByteString -> m b) -> (FilePath -> m b) -> FilePath -> m b
Zstd.fromFileWith (Either (ByteOffset, FilePath) Ktx
-> IO (Either (ByteOffset, FilePath) Ktx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ByteOffset, FilePath) Ktx
 -> IO (Either (ByteOffset, FilePath) Ktx))
-> (ByteString -> Either (ByteOffset, FilePath) Ktx)
-> ByteString
-> IO (Either (ByteOffset, FilePath) Ktx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either (ByteOffset, FilePath) Ktx
Ktx1.fromByteString) FilePath -> IO (Either (ByteOffset, FilePath) Ktx)
Ktx1.fromFile