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
  { DFD -> Word32
dfdTotalSize :: Word32
  , DFD -> Vector Block
dfdBlocks :: Vector Block
  }
  deriving (DFD -> DFD -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DFD -> DFD -> Bool
$c/= :: DFD -> DFD -> Bool
== :: DFD -> DFD -> Bool
$c== :: DFD -> DFD -> Bool
Eq, Int -> DFD -> ShowS
[DFD] -> ShowS
DFD -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DFD] -> ShowS
$cshowList :: [DFD] -> ShowS
show :: DFD -> String
$cshow :: DFD -> String
showsPrec :: Int -> DFD -> ShowS
$cshowsPrec :: Int -> DFD -> ShowS
Show, forall x. Rep DFD x -> DFD
forall x. DFD -> Rep DFD x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DFD x -> DFD
$cfrom :: forall x. DFD -> Rep DFD x
Generic)

instance Binary DFD where
  get :: Get DFD
get = do
    Word32
dfdTotalSize <- Get Word32
getWord32le
    Vector Block
dfdBlocks <- forall a. Int -> Get a -> Get a
isolate (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
dfdTotalSize forall a. Num a => a -> a -> a
- Int
4) do
      forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) b a.
Monad m =>
(b -> m (Maybe (a, b))) -> b -> m (Vector a)
Vector.unfoldrM (Word32
dfdTotalSize forall a. Num a => a -> a -> a
- Word32
4) \case
        Word32
0 ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Word32
remaining | Word32
remaining forall a. Ord a => a -> a -> Bool
< Word32
0 ->
          forall a. HasCallStack => String -> a
error String
"reading beyond end of block"
        Word32
remaining -> do
          Block
block <- forall t. Binary t => Get t
get
          pure $ forall a. a -> Maybe a
Just
            ( Block
block
            , Word32
remaining forall a. Num a => a -> a -> a
- Block -> Word32
descriptorBlockSize Block
block
            )
    pure DFD{Word32
Vector Block
dfdBlocks :: Vector Block
dfdTotalSize :: Word32
dfdBlocks :: Vector Block
dfdTotalSize :: Word32
..}

  put :: DFD -> Put
put DFD{Word32
Vector Block
dfdBlocks :: Vector Block
dfdTotalSize :: Word32
dfdBlocks :: DFD -> Vector Block
dfdTotalSize :: DFD -> Word32
..} = do
    Word32 -> Put
putWord32le Word32
dfdTotalSize
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
Vector.mapM_ forall t. Binary t => t -> Put
put Vector Block
dfdBlocks

data Block = Block
  { Block -> Word32
descriptorType :: Word32
  , Block -> Word32
vendorId       :: Word32
  , Block -> Word32
descriptorBlockSize :: Word32
  , Block -> Word32
versionNumber       :: Word32
  , Block -> ByteString
body :: ByteString
  }
  deriving (Block -> Block -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Block -> Block -> Bool
$c/= :: Block -> Block -> Bool
== :: Block -> Block -> Bool
$c== :: Block -> Block -> Bool
Eq, Int -> Block -> ShowS
[Block] -> ShowS
Block -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Block] -> ShowS
$cshowList :: [Block] -> ShowS
show :: Block -> String
$cshow :: Block -> String
showsPrec :: Int -> Block -> ShowS
$cshowsPrec :: Int -> Block -> ShowS
Show, forall x. Rep Block x -> Block
forall x. Block -> Rep Block x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Block x -> Block
$cfrom :: forall x. Block -> Rep Block x
Generic)

instance Binary Block where
  get :: Get Block
get = do
    Word32
a <- Get Word32
getWord32le
    let
      descriptorType :: Word32
descriptorType = forall a. Bits a => a -> Int -> a
shiftR Word32
a Int
17
      vendorId :: Word32
vendorId = Word32
a forall a. Bits a => a -> a -> a
.&. Word32
0x0001FFFF
    Word32
b <- Get Word32
getWord32le
    let
      descriptorBlockSize :: Word32
descriptorBlockSize = forall a. Bits a => a -> Int -> a
shiftR Word32
b Int
16
      versionNumber :: Word32
versionNumber = Word32
b forall a. Bits a => a -> a -> a
.&. Word32
0x00007FFF
    ByteString
body <- Int -> Get ByteString
getByteString forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
descriptorBlockSize forall a. Num a => a -> a -> a
- Int
8
    pure Block{Word32
ByteString
body :: ByteString
versionNumber :: Word32
descriptorBlockSize :: Word32
vendorId :: Word32
descriptorType :: Word32
body :: ByteString
versionNumber :: Word32
vendorId :: Word32
descriptorType :: Word32
descriptorBlockSize :: Word32
..}

  put :: Block -> Put
put Block{Word32
ByteString
body :: ByteString
versionNumber :: Word32
descriptorBlockSize :: Word32
vendorId :: Word32
descriptorType :: Word32
body :: Block -> ByteString
versionNumber :: Block -> Word32
vendorId :: Block -> Word32
descriptorType :: Block -> Word32
descriptorBlockSize :: Block -> Word32
..} = do
    Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ forall a. Bits a => a -> Int -> a
shiftL Word32
descriptorType Int
17 forall a. Bits a => a -> a -> a
.|. Word32
vendorId
    Word32 -> Put
putWord32le forall a b. (a -> b) -> a -> b
$ forall a. Bits a => a -> Int -> a
shiftL Word32
descriptorBlockSize Int
16 forall a. Bits a => a -> a -> a
.|. Word32
versionNumber
    ByteString -> Put
putByteString ByteString
body