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
(DFD -> DFD -> Bool) -> (DFD -> DFD -> Bool) -> Eq DFD
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DFD -> DFD -> Bool
== :: DFD -> DFD -> Bool
$c/= :: DFD -> DFD -> Bool
/= :: DFD -> DFD -> Bool
Eq, Int -> DFD -> ShowS
[DFD] -> ShowS
DFD -> String
(Int -> DFD -> ShowS)
-> (DFD -> String) -> ([DFD] -> ShowS) -> Show DFD
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DFD -> ShowS
showsPrec :: Int -> DFD -> ShowS
$cshow :: DFD -> String
show :: DFD -> String
$cshowList :: [DFD] -> ShowS
showList :: [DFD] -> ShowS
Show, (forall x. DFD -> Rep DFD x)
-> (forall x. Rep DFD x -> DFD) -> Generic DFD
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
$cfrom :: forall x. DFD -> Rep DFD x
from :: forall x. DFD -> Rep DFD x
$cto :: forall x. Rep DFD x -> DFD
to :: forall x. Rep DFD x -> DFD
Generic)

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

  put :: DFD -> Put
put DFD{Word32
Vector Block
dfdTotalSize :: DFD -> Word32
dfdBlocks :: DFD -> Vector Block
dfdTotalSize :: Word32
dfdBlocks :: Vector Block
..} = do
    Word32 -> Put
putWord32le Word32
dfdTotalSize
    (Block -> Put) -> Vector Block -> Put
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
Vector.mapM_ Block -> Put
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
(Block -> Block -> Bool) -> (Block -> Block -> Bool) -> Eq Block
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Block -> Block -> Bool
== :: Block -> Block -> Bool
$c/= :: Block -> Block -> Bool
/= :: Block -> Block -> Bool
Eq, Int -> Block -> ShowS
[Block] -> ShowS
Block -> String
(Int -> Block -> ShowS)
-> (Block -> String) -> ([Block] -> ShowS) -> Show Block
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Block -> ShowS
showsPrec :: Int -> Block -> ShowS
$cshow :: Block -> String
show :: Block -> String
$cshowList :: [Block] -> ShowS
showList :: [Block] -> ShowS
Show, (forall x. Block -> Rep Block x)
-> (forall x. Rep Block x -> Block) -> Generic Block
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
$cfrom :: forall x. Block -> Rep Block x
from :: forall x. Block -> Rep Block x
$cto :: forall x. Rep Block x -> Block
to :: forall x. Rep Block x -> Block
Generic)

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

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