keid-core 0.1.1.1 → 0.1.2.0

raw patch · 6 files changed

+306/−170 lines, 6 filesdep +file-embedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: file-embed

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−1
• keid-core.cabal +3/−1
• src/Resource/Compressed/Zstd.hs +35/−11
• src/Resource/Source.hs +85/−0
• src/Resource/Texture.hs +5/−5
• src/Resource/Texture/Ktx1.hs +171/−152

@@ -1,11 +1,17 @@ # Changelog for keid-core +## 0.1.2.0++- Added `Resource.Source` type to mix external and embedded byte sources.+- Added `Zstd.Compressed` wrapper and functions to compress/decompress `ByteString`.+- Removed `Ktx1.createTexture`.+  - Added `load`, `loadBytes`, `loadKtx1` instead.+ ## 0.1.1.1  - Added `spawnMergeT` to merge traversable collections. - Added `HasStateRef` to make stage state accessible from `StageFrameRIO`. - Added module labels to pipelines and their layouts.-- Fixed VK_HOST_OUT_OF_MEMORY due to zero cubemap descriptors provided in Basic pipelines.  ## 0.1.1.0 

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           keid-core-version:        0.1.1.1+version:        0.1.2.0 synopsis:       Core parts of Keid engine. category:       Game Engine author:         IC Rainbow@@ -69,6 +69,7 @@       Resource.Mesh.Types       Resource.Mesh.Utils       Resource.Model+      Resource.Source       Resource.Static       Resource.Texture       Resource.Texture.Ktx1@@ -146,6 +147,7 @@     , derive-storable     , derive-storable-plugin     , distributive+    , file-embed     , foldl     , geomancy     , ktx-codec

@@ -2,18 +2,41 @@  import RIO -import RIO.FilePath (takeExtension)+import Data.Typeable (typeOf) import RIO.ByteString qualified as ByteString+import RIO.FilePath (takeExtension)  import Codec.Compression.Zstd qualified as Zstd +-- * Compressed container++newtype Compressed a = Compressed { getCompressed :: a }++compressBytes :: ByteString -> Compressed ByteString+compressBytes = Compressed . Zstd.compress Zstd.maxCLevel++decompressBytes :: Compressed ByteString -> Either CompressedError ByteString+decompressBytes (Compressed bytes) =+  case Zstd.decompress bytes of+    Zstd.Decompress buf ->+      Right buf+    Zstd.Skip ->+      Right mempty+    Zstd.Error str ->+      Left $ ZstdError (fromString str)++instance Typeable a => Show (Compressed a) where+  show (Compressed x) = "Compressed " <> show (typeOf x)+ data CompressedError-  = EmptyFile FilePath-  | ZstdError Text+  = ZstdError Text+  | EmptyFile FilePath   deriving (Eq, Show)  instance Exception CompressedError +-- * Loading files+ fromFileWith :: MonadIO m => (ByteString -> m b) -> (FilePath -> m b) -> FilePath -> m b fromFileWith withBS withFilePath filePath   | elem (takeExtension filePath) compressedExts =@@ -23,14 +46,15 @@  loadCompressed :: MonadIO m => (ByteString -> m b) -> FilePath -> m b loadCompressed withBS filePath = do-  yeet'd <- ByteString.readFile filePath-  case Zstd.decompress yeet'd of-    Zstd.Skip ->-      throwIO $ EmptyFile filePath-    Zstd.Error str ->-      throwIO $ ZstdError (fromString str)-    Zstd.Decompress buf ->-      withBS buf+  bytes <- ByteString.readFile filePath+  case decompressBytes (Compressed bytes) of+    Right buf ->+      if ByteString.null buf then+        throwIO $ EmptyFile filePath+      else+        withBS buf+    Left err ->+      throwIO err  compressedExts :: [FilePath] compressedExts =

@@ -0,0 +1,85 @@++module Resource.Source+  ( Source(..)+  , load+  , embedFile+  ) where++import RIO++import Data.FileEmbed qualified+import Data.Typeable+import GHC.Stack (withFrozenCallStack)+import Language.Haskell.TH.Syntax qualified as TH+import Resource.Compressed.Zstd qualified as Zstd+import RIO.ByteString qualified as ByteString+import RIO.FilePath (takeFileName, takeExtension)+import RIO.Text qualified as Text++data Source+  = Bytes     (Maybe Text) ByteString+  | BytesZstd (Maybe Text) (Zstd.Compressed ByteString)+  | File      (Maybe Text) FilePath++instance Show Source where+  show = \case+    Bytes mlabel _bs ->+      maybe "<buffer>" Text.unpack mlabel+    BytesZstd mlabel _zbs ->+      maybe "<zstd buffer>" Text.unpack mlabel+    File mlabel filePath ->+      maybe filePath Text.unpack mlabel++load+  :: forall a m env+  .  ( MonadIO m+     , MonadReader env m+     , HasLogFunc env+     , Typeable a+     , HasCallStack+     )+  => (ByteString -> m a)+  -> Source+  -> m a+load action = \case+  Bytes label !bytes -> do+    withFrozenCallStack . logDebug $+      case label of+        Nothing ->+          "Loading " <> displayShow (typeRep $ Proxy @a)+        Just someText ->+          "Loading " <> displayShow (typeRep $ Proxy @a) <> " from " <> display someText+    action bytes++  BytesZstd label !bytesZstd ->+    case Zstd.decompressBytes bytesZstd of+      Left zstdError ->+        throwIO zstdError+      Right !bytes ->+        load action $+          Bytes label bytes++  File label filePath -> do+    !bytes <- Zstd.fromFileWith pure (liftIO . ByteString.readFile) filePath+    load action $+      Bytes+        (label <|> Just (fromString filePath))+        bytes++embedFile :: FilePath -> TH.Q TH.Exp+embedFile filePath =+  case takeExtension filePath of+    ".zst" -> do+      bytesZstd <- Data.FileEmbed.embedFile filePath+      compressed <- [| Zstd.Compressed |]+      let bytesZstdExpr = compressed `TH.AppE` bytesZstd++      constr <- [| BytesZstd label |]+      pure $ constr `TH.AppE` bytesZstdExpr++    _ -> do+      bytes <- Data.FileEmbed.embedFile filePath+      constr <- [| Bytes label |]+      pure $ constr `TH.AppE` bytes+  where+    label = Just . mappend "embedded|" $ takeFileName filePath

@@ -79,14 +79,14 @@  type TextureLoader m layers = Vk.Format -> Queues Vk.CommandPool -> FilePath -> m (Texture layers) -type TextureLoaderAction m layers = FilePath -> m (Texture layers)+type TextureLoaderAction src m layers = src -> m (Texture layers)  -- * Allocation wrappers  allocateCollectionWith   :: (Resource.MonadResource m, MonadVulkan env m, Traversable t)-  => TextureLoaderAction m layers-  -> t FilePath+  => TextureLoaderAction src m layers+  -> t src   -> m (Resource.ReleaseKey, t (Texture layers)) allocateCollectionWith action collection = do   res <- traverse (allocateTextureWith action) collection@@ -96,8 +96,8 @@  allocateTextureWith   :: (Resource.MonadResource m, MonadVulkan env m)-  => TextureLoaderAction m layers-  -> FilePath+  => TextureLoaderAction src m layers+  -> src   -> m (Resource.ReleaseKey, Texture layers) allocateTextureWith action path = do   context <- ask

@@ -1,5 +1,7 @@ module Resource.Texture.Ktx1-  ( createTexture+  ( load+  , loadBytes+  , loadKtx1   ) where  import RIO@@ -9,189 +11,206 @@ import Data.Text qualified as Text import Data.Vector qualified as Vector import Foreign qualified+import GHC.Stack (withFrozenCallStack) 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.Source (Source(..))+import Resource.Source qualified as Source import Resource.Texture (Texture(..), TextureLayers(..)) import Resource.Texture qualified as Texture -createTexture-  :: forall a st . (TextureLayers a)+load+  :: (TextureLayers a, Typeable a, HasCallStack)   => Queues Vk.CommandPool-  -> FilePath+  -> Source   -> StageRIO st (Texture a)-createTexture pool path = do-  context <- ask-  let vma = getAllocator context+load pool source =+  withFrozenCallStack $+    Source.load (loadBytes pool) source -  logInfo $ "Loading " <> fromString path-  loader path >>= \case+loadBytes+  :: TextureLayers a+  => Queues Vk.CommandPool+  -> ByteString+  -> StageRIO st (Texture a)+loadBytes pool bytes = do+  case Ktx1.fromByteString bytes of     Left (offset, err) -> do       logError $ "Texture load error: " <> fromString err       throwM $ Texture.LoadError offset (Text.pack err)-    Right Ktx1.Ktx{header, images=ktxImages} -> do-      let-        skipMips = 0 -- DEBUG: Vector.length ktxImages `div` 2-        mipsSkipped = min (Vector.length ktxImages - 1) skipMips-        images = Vector.drop mipsSkipped ktxImages-        mipLevels = Ktx1.numberOfMipmapLevels header - fromIntegral mipsSkipped+    Right ktx1 ->+      loadKtx1 pool ktx1 -      when (Vector.null images) $-        throwM $ Texture.LoadError 0 "At least one image must be present in KTX"+loadKtx1+  :: forall a st+  .  (TextureLayers a)+  => Queues Vk.CommandPool+  -> Ktx1.Ktx+  -> StageRIO st (Texture a)+loadKtx1 pool Ktx1.Ktx{header, images=ktxImages} = do+  context <- ask+  let vma = getAllocator context -      unless (fromIntegral mipLevels == Vector.length images) $-        throwM $ Texture.MipLevelsError mipLevels (Vector.length images)+  let+    skipMips = 0 -- DEBUG: Vector.length ktxImages `div` 2+    mipsSkipped = min (Vector.length ktxImages - 1) skipMips+    images = Vector.drop mipsSkipped ktxImages+    mipLevels = Ktx1.numberOfMipmapLevels header - fromIntegral mipsSkipped -      -- XXX: https://github.com/KhronosGroup/KTX-Software/blob/bf849b7f/lib/vk_format.h#L676-      format <- case Ktx1.glInternalFormat header of-        -- XXX: Force all BC7s to SRGB-        36492 ->-          pure Vk.FORMAT_BC7_SRGB_BLOCK-        other ->-          case FromGL.internalFormat other of-            Nothing ->-              error $ "Unexpected glInternalFormat: " <> show other -- TODO: throwIo-            Just fmt ->-              -- XXX: going in blind-              pure fmt-      logDebug $ mconcat-        [ "Loading format "-        , display $ Ktx1.glInternalFormat header-        , " as "-        , displayShow format-        ]+  when (Vector.null images) $+    throwM $ Texture.LoadError 0 "At least one image must be present in KTX" -      -- XXX: https://github.com/KhronosGroup/KTX-Software/blob/bf849b7f/lib/vkloader.c#L552-      let-        extent = Vk.Extent3D-          { Vk.width  = Ktx1.pixelWidth header `Foreign.shiftR` mipsSkipped-          , Vk.height = Ktx1.pixelHeight header `Foreign.shiftR` mipsSkipped-          , Vk.depth  = max 1 $ Ktx1.pixelDepth header-          }-        arrayLayers = max 1 $ Ktx1.numberOfArrayElements header+  unless (fromIntegral mipLevels == Vector.length images) $+    throwM $ Texture.MipLevelsError mipLevels (Vector.length images) -      -- TODO: basisu can encode movies as arrays, this could be handy-      unless (arrayLayers == 1) do-        logError "TODO: arrayLayers > 1"-        throwM $ Texture.ArrayError 1 arrayLayers+  -- XXX: https://github.com/KhronosGroup/KTX-Software/blob/bf849b7f/lib/vk_format.h#L676+  format <- case Ktx1.glInternalFormat header of+    -- XXX: Force all BC7s to SRGB+    36492 ->+      pure Vk.FORMAT_BC7_SRGB_BLOCK+    other ->+      case FromGL.internalFormat other of+        Nothing ->+          error $ "Unexpected glInternalFormat: " <> show other -- TODO: throwIo+        Just fmt ->+          -- XXX: going in blind+          pure fmt+  logDebug $ mconcat+    [ "Loading format "+    , display $ Ktx1.glInternalFormat header+    , " as "+    , displayShow format+    ] -      let-        numLayers = Ktx1.numberOfFaces header-        mipSizes = fmap ((*) numLayers . Ktx1.imageSize) images+  -- XXX: https://github.com/KhronosGroup/KTX-Software/blob/bf849b7f/lib/vkloader.c#L552+  let+    extent = Vk.Extent3D+      { Vk.width  = Ktx1.pixelWidth header `Foreign.shiftR` mipsSkipped+      , Vk.height = Ktx1.pixelHeight header `Foreign.shiftR` mipsSkipped+      , Vk.depth  = max 1 $ Ktx1.pixelDepth header+      }+    arrayLayers = max 1 $ Ktx1.numberOfArrayElements header -        offsets' = Vector.scanl' (+) 0 mipSizes-        totalSize = Vector.last offsets'-        offsets = Vector.init offsets'+  -- TODO: basisu can encode movies as arrays, this could be handy+  unless (arrayLayers == 1) do+    logError "TODO: arrayLayers > 1"+    throwM $ Texture.ArrayError 1 arrayLayers -      logDebug $ "mipSizes: " <> displayShow mipSizes-      logDebug $ "offsets: " <> displayShow offsets+  let+    numLayers = Ktx1.numberOfFaces header+    mipSizes = fmap ((*) numLayers . Ktx1.imageSize) images -      {- XXX:-        Image created before staging buffer due to `Image.copyBufferToImage`-        issued inside `VMA.withBuffer` bracket.-      -}-      (image, allocation, _info) <- VMA.createImage-        vma-        (Texture.imageCI format extent mipLevels numLayers)-        Texture.imageAllocationCI+    offsets' = Vector.scanl' (+) 0 mipSizes+    totalSize = Vector.last offsets'+    offsets = Vector.init offsets' -      Image.transitionImageLayout-        context-        pool-        image-        mipLevels-        numLayers -- XXX: arrayLayers is always 0 for now-        format-        Vk.IMAGE_LAYOUT_UNDEFINED-        Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL+  logDebug $ "mipSizes: " <> displayShow mipSizes+  logDebug $ "offsets: " <> displayShow offsets -      unless (numLayers == textureLayers @a) $-        throwM $ Texture.ArrayError (textureLayers @a) numLayers+  {- XXX:+    Image created before staging buffer due to `Image.copyBufferToImage`+    issued inside `VMA.withBuffer` bracket.+  -}+  (image, allocation, _info) <- VMA.createImage+    vma+    (Texture.imageCI format extent mipLevels numLayers)+    Texture.imageAllocationCI -      VMA.withBuffer vma (Texture.stageBufferCI totalSize) Texture.stageAllocationCI bracket \(staging, stage, stageInfo) -> do-        let ixMipImages = Vector.zip3 (Vector.fromList [0..]) offsets images-        Vector.forM_ ixMipImages \(mipIx, offset, Ktx1.MipLevel{imageSize, arrayElements}) -> do-          let ixArrayElements = Vector.zip (Vector.fromList [0..]) arrayElements-          Vector.forM_ ixArrayElements \(arrayIx, Ktx1.ArrayElement{faces}) -> do-            let ixFaces = Vector.zip (Vector.fromList [0..]) faces-            Vector.forM_ ixFaces \(faceIx, Ktx1.Face{zSlices}) -> do-              let ixSlices = Vector.zip (Vector.fromList [0..]) zSlices-              Vector.forM_ ixSlices \(sliceIx, Ktx1.ZSlice{block}) -> do-                let-                  indices = mconcat-                    [ "["-                    , " mip:" <> display @Word32 mipIx-                    , " arr:" <> display @Word32 arrayIx-                    , " fac:" <> display @Word32 faceIx-                    , " slc:" <> display @Word32 sliceIx-                    , " ]"-                    ]-                let blockOffset = offset + faceIx * imageSize-                let sectionPtr = Foreign.plusPtr (VMA.mappedData stageInfo) (fromIntegral blockOffset)-                logDebug $ mconcat-                  [ indices-                  , " base offset = "-                  , display offset-                  , " image offset = "-                  , display $ faceIx * imageSize-                  , " image size = "-                  , display imageSize-                  ]-                liftIO $ unsafeUseAsCStringLen block \(pixelsPtr, pixelBytes) -> do-                  if pixelBytes /= fromIntegral imageSize then-                    error "assert: MipLevel.imageSize matches block.pixelBytes"-                  else-                    -- traceShowM (sectionPtr, pixelBytes)-                    Foreign.copyBytes sectionPtr (Foreign.castPtr pixelsPtr) pixelBytes+  Image.transitionImageLayout+    context+    pool+    image+    mipLevels+    numLayers -- XXX: arrayLayers is always 0 for now+    format+    Vk.IMAGE_LAYOUT_UNDEFINED+    Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL -        VMA.flushAllocation vma stage 0 Vk.WHOLE_SIZE+  unless (numLayers == textureLayers @a) $+    throwM $ Texture.ArrayError (textureLayers @a) numLayers -        -- XXX: copying to image while the staging buffer is still alive-        Image.copyBufferToImage-          context-          pool-          staging-          image-          extent-          offsets-          numLayers+  VMA.withBuffer vma (Texture.stageBufferCI totalSize) Texture.stageAllocationCI bracket \(staging, stage, stageInfo) -> do+    let ixMipImages = Vector.zip3 (Vector.fromList [0..]) offsets images+    Vector.forM_ ixMipImages \(mipIx, offset, Ktx1.MipLevel{imageSize, arrayElements}) -> do+      let ixArrayElements = Vector.zip (Vector.fromList [0..]) arrayElements+      Vector.forM_ ixArrayElements \(arrayIx, Ktx1.ArrayElement{faces}) -> do+        let ixFaces = Vector.zip (Vector.fromList [0..]) faces+        Vector.forM_ ixFaces \(faceIx, Ktx1.Face{zSlices}) -> do+          let ixSlices = Vector.zip (Vector.fromList [0..]) zSlices+          Vector.forM_ ixSlices \(sliceIx, Ktx1.ZSlice{block}) -> do+            let+              indices = mconcat+                [ "["+                , " mip:" <> display @Word32 mipIx+                , " arr:" <> display @Word32 arrayIx+                , " fac:" <> display @Word32 faceIx+                , " slc:" <> display @Word32 sliceIx+                , " ]"+                ]+            let blockOffset = offset + faceIx * imageSize+            let sectionPtr = Foreign.plusPtr (VMA.mappedData stageInfo) (fromIntegral blockOffset)+            logDebug $ mconcat+              [ indices+              , " base offset = "+              , display offset+              , " image offset = "+              , display $ faceIx * imageSize+              , " image size = "+              , display imageSize+              ]+            liftIO $ unsafeUseAsCStringLen block \(pixelsPtr, pixelBytes) -> do+              if pixelBytes /= fromIntegral imageSize then+                error "assert: MipLevel.imageSize matches block.pixelBytes"+              else+                -- traceShowM (sectionPtr, pixelBytes)+                Foreign.copyBytes sectionPtr (Foreign.castPtr pixelsPtr) pixelBytes -      -- XXX: staging buffer is gone+    VMA.flushAllocation vma stage 0 Vk.WHOLE_SIZE -      Image.transitionImageLayout-        context-        pool-        image-        mipLevels-        numLayers -- XXX: arrayLayers is always 0 for now-        format-        Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL-        Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL+    -- XXX: copying to image while the staging buffer is still alive+    Image.copyBufferToImage+      context+      pool+      staging+      image+      extent+      offsets+      numLayers -      imageView <- Texture.createImageView-        context-        image-        format-        mipLevels-        numLayers+  -- XXX: staging buffer is gone -      let-        allocatedImage = AllocatedImage-          { aiAllocation = allocation-          , aiImage      = image-          , aiImageView  = imageView-          }-      pure Texture-        { tFormat         = format-        , tMipLevels      = mipLevels-        , tLayers         = numLayers-        , tAllocatedImage = allocatedImage-        }-  where-    loader = liftIO . Zstd.fromFileWith (pure . Ktx1.fromByteString) Ktx1.fromFile+  Image.transitionImageLayout+    context+    pool+    image+    mipLevels+    numLayers -- XXX: arrayLayers is always 0 for now+    format+    Vk.IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL+    Vk.IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL++  imageView <- Texture.createImageView+    context+    image+    format+    mipLevels+    numLayers++  let+    allocatedImage = AllocatedImage+      { aiAllocation = allocation+      , aiImage      = image+      , aiImageView  = imageView+      }+  pure Texture+    { tFormat         = format+    , tMipLevels      = mipLevels+    , tLayers         = numLayers+    , tAllocatedImage = allocatedImage+    }