DFD.hs

module Codec.Ktx2.DFD where

import Data.Binary (Binary(..))
import Data.Binary.Get (getWord32le, getByteString, isolate)
import Data.Binary.Put (putByteString, putWord32le)
import Data.Bits (shiftR, Bits ((.&.), shiftL, (.|.)))
import Data.ByteString (ByteString)
import Data.Vector (Vector)
import Data.Vector qualified as Vector
import Data.Word (Word32)
import GHC.Generics (Generic)

data DFD = DFD
  { dfdTotalSize :: Word32
  , dfdBlocks :: Vector Block
  }
  deriving (Eq, Show, Generic)

instance Binary DFD where
  get = do
    dfdTotalSize <- getWord32le
    dfdBlocks <- isolate (fromIntegral dfdTotalSize - 4) do
      flip Vector.unfoldrM (dfdTotalSize - 4) \case
        0 ->
          pure Nothing
        remaining | remaining < 0 ->
          error "reading beyond end of block"
        remaining -> do
          block <- get
          pure $ Just
            ( block
            , remaining - descriptorBlockSize block
            )
    pure DFD{..}

  put DFD{..} = do
    putWord32le dfdTotalSize
    Vector.mapM_ put dfdBlocks

data Block = Block
  { descriptorType :: Word32
  , vendorId       :: Word32
  , descriptorBlockSize :: Word32
  , versionNumber       :: Word32
  , body :: ByteString
  }
  deriving (Eq, Show, Generic)

instance Binary Block where
  get = do
    a <- getWord32le
    let
      descriptorType = shiftR a 17
      vendorId = a .&. 0x0001FFFF
    b <- getWord32le
    let
      descriptorBlockSize = shiftR b 16
      versionNumber = b .&. 0x00007FFF
    body <- getByteString $ fromIntegral descriptorBlockSize - 8
    pure Block{..}

  put Block{..} = do
    putWord32le $ shiftL descriptorType 17 .|. vendorId
    putWord32le $ shiftL descriptorBlockSize 16 .|. versionNumber
    putByteString body