{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}

{- | Block-by-block extraction of data from a KTX2 file.

* Acquire a "Context". Header data is available without reading the rest of the source.
* Read 'levels' index. An memory allocation information is available.
* Consult 'Codec.Ktx2.Header.supercompressionScheme' and copy level data to decompression staging buffer or GPU memory directly.

Extra information is available when needed:

* Image metadata.
* Data Format Descriptor. Khronos Basic descriptor block is usually present, but a file may contain more.
* Supercompression data shared between all the levels.
-}

module Codec.Ktx2.Read
  ( Context(..)

  , FileContext
  , open
  , close

  , BytesContext
  , bytes

  -- * Reading everything at once
  , fromFile
  , fromBytes

  -- * Reading blocks

  -- ** Image data
  , levels
  , levelToPtr
  , levelData

  -- ** Supplemental information
  , dataFormatDescriptor
  , keyValueData
  , supercompressionGlobalData

  -- * Decoding internals
  , ReadChunk(..)
  , ChunkError(..)
  , decodeAt
  , DecodeError(..)
  , ReadLevel(..)
  ) where

import Control.Exception (Exception, bracket, throwIO)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Binary (Binary(..))
import Data.Binary.Get (Get, ByteOffset, getByteString, runGetOrFail)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import Data.ByteString.Unsafe qualified as BSU
import Data.String (fromString)
import Data.Text (Text)
import Data.Traversable (for)
import Data.Vector (Vector)
import Data.Vector qualified as Vector
import Foreign (Ptr, plusPtr)
import Foreign qualified
import System.IO qualified as IO

import Codec.Ktx.KeyValue (KeyValueData)
import Codec.Ktx.KeyValue qualified as KeyValue
import Codec.Ktx2 (Ktx2)
import Codec.Ktx2 qualified as Ktx2
import Codec.Ktx2.Header (Header(..))
import Codec.Ktx2.Level (Level(..))
import Codec.Ktx2.DFD (DFD(..))
import Data.Typeable (Typeable, Proxy(..), typeRep)

-- * Context

-- | A bundle of source data and header information used by reader functions.
data Context a = Context
  { forall a. Context a -> a
context :: a
  , forall a. Context a -> Header
header :: Header
  }

-- ** Reading from files

-- | Context for reading from a file. The file has to be seekable.
type FileContext = Context IO.Handle

instance ReadChunk IO.Handle where
  readChunkAt :: forall (io :: * -> *).
MonadIO io =>
Handle -> Int -> Int -> io ByteString
readChunkAt Handle
handle Int
offset Int
size = IO ByteString -> io ByteString
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
    Handle -> SeekMode -> Integer -> IO ()
IO.hSeek Handle
handle SeekMode
IO.AbsoluteSeek (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset)
    Handle -> Int -> IO ByteString
BS.hGet Handle
handle Int
size

instance ReadLevel IO.Handle where
  readLevelTo :: forall (io :: * -> *).
MonadIO io =>
Handle -> Level -> Ptr () -> io Bool
readLevelTo Handle
handle Level{Word64
byteOffset :: Word64
byteLength :: Word64
uncompressedByteLength :: Word64
uncompressedByteLength :: Level -> Word64
byteLength :: Level -> Word64
byteOffset :: Level -> Word64
..} Ptr ()
ptr = IO Bool -> io Bool
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
    Handle -> SeekMode -> Integer -> IO ()
IO.hSeek
      Handle
handle
      SeekMode
IO.AbsoluteSeek
      (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
byteOffset)
    Int
got <- Handle -> Ptr () -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
IO.hGetBuf Handle
handle Ptr ()
ptr (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
byteLength)
    pure $ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
got Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
byteLength

instance Show (Context IO.Handle) where
  show :: Context Handle -> String
show (Context Handle
handle Header
header) = [String] -> String
forall a. Monoid a => [a] -> a
mconcat
    [ String
"Context ("
    , Handle -> String
forall a. Show a => a -> String
show Handle
handle
    , String
") "
    , Header -> String
forall a. Show a => a -> String
show Header
header
    ]

open :: MonadIO io => FilePath -> io FileContext
open :: forall (io :: * -> *). MonadIO io => String -> io (Context Handle)
open String
path = do
  Handle
handle <- IO Handle -> io Handle
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> io Handle) -> IO Handle -> io Handle
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> IO Handle
IO.openBinaryFile String
path IOMode
IO.ReadMode
  Header
header <- Handle -> Int -> Int -> Get Header -> io Header
forall a src (io :: * -> *).
(ReadChunk src, Show a, Typeable a, MonadIO io) =>
src -> Int -> Int -> Get a -> io a
decodeAt Handle
handle Int
0 Int
80 Get Header
forall t. Binary t => Get t
get
  pure $ Handle -> Header -> Context Handle
forall a. a -> Header -> Context a
Context Handle
handle Header
header

close :: MonadIO io => FileContext -> io ()
close :: forall (io :: * -> *). MonadIO io => Context Handle -> io ()
close (Context Handle
handle Header
_header) = IO () -> io ()
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> io ()) -> IO () -> io ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
IO.hClose Handle
handle

-- ** Reading from memory

-- | Context for reading from memory. Useful when the data is embedded in a module or otherwise already available in full.
type BytesContext = Context ByteString

instance ReadChunk ByteString where
  readChunkAt :: forall (io :: * -> *).
MonadIO io =>
ByteString -> Int -> Int -> io ByteString
readChunkAt ByteString
bs Int
offset Int
size =
    if Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ByteString -> Int
BS.length ByteString
bs then
      IO ByteString -> io ByteString
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> io ByteString)
-> (Text -> IO ByteString) -> Text -> io ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChunkError -> IO ByteString
forall e a. Exception e => e -> IO a
throwIO (ChunkError -> IO ByteString)
-> (Text -> ChunkError) -> Text -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ChunkError
ChunkError (Text -> io ByteString) -> Text -> io ByteString
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"Offset " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show Int
offset)
        , Text
" and size " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show Int
size)
        , Text
" is beyond the size of the buffer: "
        , String -> Text
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bs)
        ]
    else
      ByteString -> io ByteString
forall a. a -> io a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> io ByteString) -> ByteString -> io ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
size (Int -> ByteString -> ByteString
BS.drop Int
offset ByteString
bs)

instance ReadLevel ByteString where
  readLevelTo :: forall (io :: * -> *).
MonadIO io =>
ByteString -> Level -> Ptr () -> io Bool
readLevelTo ByteString
buf Level{Word64
uncompressedByteLength :: Level -> Word64
byteLength :: Level -> Word64
byteOffset :: Level -> Word64
byteOffset :: Word64
byteLength :: Word64
uncompressedByteLength :: Word64
..} Ptr ()
dst =
    IO Bool -> io Bool
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> io Bool) -> IO Bool -> io Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> (CStringLen -> IO Bool) -> IO Bool
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BSU.unsafeUseAsCStringLen ByteString
buf \(Ptr CChar
src, Int
size) ->
      if Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
byteOffset Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
byteLength) then
        Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      else do
        Ptr () -> Ptr () -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
Foreign.copyBytes
          Ptr ()
dst
          (Ptr CChar -> Int -> Ptr ()
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr CChar
src (Int -> Ptr ()) -> Int -> Ptr ()
forall a b. (a -> b) -> a -> b
$ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
byteOffset)
          (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
byteLength)
        pure Bool
True

instance Show (Context ByteString) where
  show :: Context ByteString -> String
show (Context ByteString
buf Header
header) = [String] -> String
forall a. Monoid a => [a] -> a
mconcat
    [ String
"Context ["
    , Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
buf
    , String
"] "
    , Header -> String
forall a. Show a => a -> String
show Header
header
    ]

bytes :: MonadIO io => ByteString -> io BytesContext
bytes :: forall (io :: * -> *).
MonadIO io =>
ByteString -> io (Context ByteString)
bytes ByteString
src = do
  Header
header <- ByteString -> Int -> Int -> Get Header -> io Header
forall a src (io :: * -> *).
(ReadChunk src, Show a, Typeable a, MonadIO io) =>
src -> Int -> Int -> Get a -> io a
decodeAt ByteString
src Int
0 Int
80 Get Header
forall t. Binary t => Get t
get
  pure $ ByteString -> Header -> Context ByteString
forall a. a -> Header -> Context a
Context ByteString
src Header
header

-- * File contents

fromFile :: MonadIO io => FilePath -> io Ktx2
fromFile :: forall (io :: * -> *). MonadIO io => String -> io Ktx2
fromFile String
source = IO Ktx2 -> io Ktx2
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Ktx2 -> io Ktx2) -> IO Ktx2 -> io Ktx2
forall a b. (a -> b) -> a -> b
$ IO (Context Handle)
-> (Context Handle -> IO ())
-> (Context Handle -> IO Ktx2)
-> IO Ktx2
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO (Context Handle)
forall (io :: * -> *). MonadIO io => String -> io (Context Handle)
open String
source) Context Handle -> IO ()
forall (io :: * -> *). MonadIO io => Context Handle -> io ()
close Context Handle -> IO Ktx2
forall (io :: * -> *) a.
(MonadIO io, ReadChunk a) =>
Context a -> io Ktx2
fromContext

fromBytes :: MonadIO io => ByteString -> io Ktx2
fromBytes :: forall (io :: * -> *). MonadIO io => ByteString -> io Ktx2
fromBytes ByteString
source = ByteString -> io (Context ByteString)
forall (io :: * -> *).
MonadIO io =>
ByteString -> io (Context ByteString)
bytes ByteString
source io (Context ByteString)
-> (Context ByteString -> io Ktx2) -> io Ktx2
forall a b. io a -> (a -> io b) -> io b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context ByteString -> io Ktx2
forall (io :: * -> *) a.
(MonadIO io, ReadChunk a) =>
Context a -> io Ktx2
fromContext

fromContext :: (MonadIO io, ReadChunk a) => Context a -> io Ktx2
fromContext :: forall (io :: * -> *) a.
(MonadIO io, ReadChunk a) =>
Context a -> io Ktx2
fromContext ktx :: Context a
ktx@Context{Header
header :: forall a. Context a -> Header
header :: Header
header} = do
  DFD{Vector Block
dfdBlocks :: Vector Block
dfdBlocks :: DFD -> Vector Block
dfdBlocks} <- Context a -> io DFD
forall src (io :: * -> *).
(ReadChunk src, MonadIO io) =>
Context src -> io DFD
dataFormatDescriptor Context a
ktx
  KeyValueData
kvd <- Context a -> io KeyValueData
forall src (io :: * -> *).
(ReadChunk src, MonadIO io) =>
Context src -> io KeyValueData
keyValueData Context a
ktx
  ByteString
sgd <- Context a -> io ByteString
forall src (io :: * -> *).
(ReadChunk src, MonadIO io) =>
Context src -> io ByteString
supercompressionGlobalData Context a
ktx
  Vector Level
levels' <- Context a -> io (Vector Level)
forall src (io :: * -> *).
(ReadChunk src, MonadIO io) =>
Context src -> io (Vector Level)
levels Context a
ktx
  [(Maybe Word64, ByteString)]
annLevels <-
    [Level]
-> (Level -> io (Maybe Word64, ByteString))
-> io [(Maybe Word64, ByteString)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Vector Level -> [Level]
forall a. Vector a -> [a]
Vector.toList Vector Level
levels') \l :: Level
l@Level{Word64
uncompressedByteLength :: Level -> Word64
uncompressedByteLength :: Word64
uncompressedByteLength} -> do
      ByteString
bs <- Context a -> Level -> io ByteString
forall src (io :: * -> *).
(ReadChunk src, MonadIO io) =>
Context src -> Level -> io ByteString
levelData Context a
ktx Level
l
      pure (Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
uncompressedByteLength, ByteString
bs)
  pure Ktx2.Ktx2{levels :: [(Maybe Word64, ByteString)]
levels=[(Maybe Word64, ByteString)]
annLevels, ByteString
KeyValueData
Vector Block
Header
header :: Header
dfdBlocks :: Vector Block
kvd :: KeyValueData
sgd :: ByteString
sgd :: ByteString
kvd :: KeyValueData
dfdBlocks :: Vector Block
header :: Header
..}

-- | Read the level index.
levels
  :: ( ReadChunk src
     , MonadIO io
     )
  => Context src
  -> io (Vector Level)
levels :: forall src (io :: * -> *).
(ReadChunk src, MonadIO io) =>
Context src -> io (Vector Level)
levels (Context src
handle Header{Word32
levelCount :: Word32
levelCount :: Header -> Word32
levelCount}) =
  src -> Int -> Int -> Get (Vector Level) -> io (Vector Level)
forall a src (io :: * -> *).
(ReadChunk src, Show a, Typeable a, MonadIO io) =>
src -> Int -> Int -> Get a -> io a
decodeAt src
handle Int
80 (Int
numLevels Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3) (Get (Vector Level) -> io (Vector Level))
-> Get (Vector Level) -> io (Vector Level)
forall a b. (a -> b) -> a -> b
$
    Int -> Get Level -> Get (Vector Level)
forall (m :: * -> *) a. Monad m => Int -> m a -> m (Vector a)
Vector.replicateM Int
numLevels Get Level
forall t. Binary t => Get t
get
  where
    numLevels :: Int
numLevels = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
levelCount

{- | Copy level data into a provided pointer.

The buffer must be large enough for the 'byteLength' of the "Level" being accessed.
-}
{-# INLINE levelToPtr #-}
levelToPtr
  :: ( ReadLevel src
     , MonadIO io
     )
  => Context src
  -> Level
  -> Ptr ()
  -> io Bool
levelToPtr :: forall src (io :: * -> *).
(ReadLevel src, MonadIO io) =>
Context src -> Level -> Ptr () -> io Bool
levelToPtr (Context src
handle Header
_header) = src -> Level -> Ptr () -> io Bool
forall a (io :: * -> *).
(ReadLevel a, MonadIO io) =>
a -> Level -> Ptr () -> io Bool
forall (io :: * -> *).
MonadIO io =>
src -> Level -> Ptr () -> io Bool
readLevelTo src
handle

-- | Copy level data into a managed buffer.
levelData
  :: ( ReadChunk src
     , MonadIO io
     )
  => Context src
  -> Level
  -> io ByteString
levelData :: forall src (io :: * -> *).
(ReadChunk src, MonadIO io) =>
Context src -> Level -> io ByteString
levelData (Context src
handle Header
_header) Level{Word64
uncompressedByteLength :: Level -> Word64
byteLength :: Level -> Word64
byteOffset :: Level -> Word64
byteOffset :: Word64
byteLength :: Word64
uncompressedByteLength :: Word64
..} = do
  src -> Int -> Int -> io ByteString
forall a (io :: * -> *).
(ReadChunk a, MonadIO io) =>
a -> Int -> Int -> io ByteString
forall (io :: * -> *).
MonadIO io =>
src -> Int -> Int -> io ByteString
readChunkAt
    src
handle
    (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
byteOffset)
    (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
byteLength)

{- | Read DFD block data.

Further processing is performed according to descriptor vendor/type/version.
E.g. "Codec.Ktx2.DFD.Khronos.BasicV2".
-}
dataFormatDescriptor
  :: ( ReadChunk src
     , MonadIO io
     )
  => Context src
  -> io DFD
dataFormatDescriptor :: forall src (io :: * -> *).
(ReadChunk src, MonadIO io) =>
Context src -> io DFD
dataFormatDescriptor (Context src
handle Header{Word32
Word64
supercompressionScheme :: Header -> Word32
levelCount :: Header -> Word32
vkFormat :: Word32
typeSize :: Word32
pixelWidth :: Word32
pixelHeight :: Word32
pixelDepth :: Word32
layerCount :: Word32
faceCount :: Word32
levelCount :: Word32
supercompressionScheme :: Word32
dfdByteOffset :: Word32
dfdByteLength :: Word32
kvdByteOffset :: Word32
kvdByteLength :: Word32
sgdByteOffset :: Word64
sgdByteLength :: Word64
sgdByteLength :: Header -> Word64
sgdByteOffset :: Header -> Word64
kvdByteLength :: Header -> Word32
kvdByteOffset :: Header -> Word32
dfdByteLength :: Header -> Word32
dfdByteOffset :: Header -> Word32
faceCount :: Header -> Word32
layerCount :: Header -> Word32
pixelDepth :: Header -> Word32
pixelHeight :: Header -> Word32
pixelWidth :: Header -> Word32
typeSize :: Header -> Word32
vkFormat :: Header -> Word32
..}) =
  if Word32
dfdByteLength Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 then
    DFD -> io DFD
forall a. a -> io a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DFD
      { dfdTotalSize :: Word32
dfdTotalSize = Word32
0
      , dfdBlocks :: Vector Block
dfdBlocks = Vector Block
forall a. Monoid a => a
mempty
      }
  else
    src -> Int -> Int -> Get DFD -> io DFD
forall a src (io :: * -> *).
(ReadChunk src, Show a, Typeable a, MonadIO io) =>
src -> Int -> Int -> Get a -> io a
decodeAt
      src
handle
      (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
dfdByteOffset)
      (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
dfdByteLength)
      Get DFD
forall t. Binary t => Get t
get

{- | Read and parse Key-Value Data block.
-}
keyValueData
  :: ( ReadChunk src
     , MonadIO io
     )
  => Context src
  -> io KeyValueData
keyValueData :: forall src (io :: * -> *).
(ReadChunk src, MonadIO io) =>
Context src -> io KeyValueData
keyValueData (Context src
handle Header{Word32
Word64
supercompressionScheme :: Header -> Word32
levelCount :: Header -> Word32
sgdByteLength :: Header -> Word64
sgdByteOffset :: Header -> Word64
kvdByteLength :: Header -> Word32
kvdByteOffset :: Header -> Word32
dfdByteLength :: Header -> Word32
dfdByteOffset :: Header -> Word32
faceCount :: Header -> Word32
layerCount :: Header -> Word32
pixelDepth :: Header -> Word32
pixelHeight :: Header -> Word32
pixelWidth :: Header -> Word32
typeSize :: Header -> Word32
vkFormat :: Header -> Word32
vkFormat :: Word32
typeSize :: Word32
pixelWidth :: Word32
pixelHeight :: Word32
pixelDepth :: Word32
layerCount :: Word32
faceCount :: Word32
levelCount :: Word32
supercompressionScheme :: Word32
dfdByteOffset :: Word32
dfdByteLength :: Word32
kvdByteOffset :: Word32
kvdByteLength :: Word32
sgdByteOffset :: Word64
sgdByteLength :: Word64
..}) =
  if Word32
kvdByteLength Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 then
    KeyValueData -> io KeyValueData
forall a. a -> io a
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyValueData
forall a. Monoid a => a
mempty
  else
    src -> Int -> Int -> Get KeyValueData -> io KeyValueData
forall a src (io :: * -> *).
(ReadChunk src, Show a, Typeable a, MonadIO io) =>
src -> Int -> Int -> Get a -> io a
decodeAt
      src
handle
      (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
kvdByteOffset)
      (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
kvdByteLength)
      (Int -> Get KeyValueData
KeyValue.getDataLe (Int -> Get KeyValueData) -> Int -> Get KeyValueData
forall a b. (a -> b) -> a -> b
$ Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
kvdByteLength)

-- | Get a copy of global supercompression data.
supercompressionGlobalData
  :: ( ReadChunk src
     , MonadIO io
     )
  => Context src
  -> io ByteString
supercompressionGlobalData :: forall src (io :: * -> *).
(ReadChunk src, MonadIO io) =>
Context src -> io ByteString
supercompressionGlobalData (Context src
handle Header{Word32
Word64
supercompressionScheme :: Header -> Word32
levelCount :: Header -> Word32
sgdByteLength :: Header -> Word64
sgdByteOffset :: Header -> Word64
kvdByteLength :: Header -> Word32
kvdByteOffset :: Header -> Word32
dfdByteLength :: Header -> Word32
dfdByteOffset :: Header -> Word32
faceCount :: Header -> Word32
layerCount :: Header -> Word32
pixelDepth :: Header -> Word32
pixelHeight :: Header -> Word32
pixelWidth :: Header -> Word32
typeSize :: Header -> Word32
vkFormat :: Header -> Word32
vkFormat :: Word32
typeSize :: Word32
pixelWidth :: Word32
pixelHeight :: Word32
pixelDepth :: Word32
layerCount :: Word32
faceCount :: Word32
levelCount :: Word32
supercompressionScheme :: Word32
dfdByteOffset :: Word32
dfdByteLength :: Word32
kvdByteOffset :: Word32
kvdByteLength :: Word32
sgdByteOffset :: Word64
sgdByteLength :: Word64
..}) =
  src -> Int -> Int -> Get ByteString -> io ByteString
forall a src (io :: * -> *).
(ReadChunk src, Show a, Typeable a, MonadIO io) =>
src -> Int -> Int -> Get a -> io a
decodeAt
    src
handle
    (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sgdByteOffset)
    (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sgdByteLength)
    (Int -> Get ByteString
getByteString (Int -> Get ByteString) -> Int -> Get ByteString
forall a b. (a -> b) -> a -> b
$ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sgdByteLength)

-- * IO helpers

class ReadChunk a where
  {- | Get a chunk of data.

  The context handle must have enough information to check whether requested region is safe to access.
  Throw "ChunkError" when it isn't possible to fullfill the request.
  -}
  readChunkAt :: MonadIO io => a -> Int -> Int -> io ByteString

newtype ChunkError = ChunkError Text
  deriving (ChunkError -> ChunkError -> Bool
(ChunkError -> ChunkError -> Bool)
-> (ChunkError -> ChunkError -> Bool) -> Eq ChunkError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChunkError -> ChunkError -> Bool
== :: ChunkError -> ChunkError -> Bool
$c/= :: ChunkError -> ChunkError -> Bool
/= :: ChunkError -> ChunkError -> Bool
Eq, Int -> ChunkError -> ShowS
[ChunkError] -> ShowS
ChunkError -> String
(Int -> ChunkError -> ShowS)
-> (ChunkError -> String)
-> ([ChunkError] -> ShowS)
-> Show ChunkError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChunkError -> ShowS
showsPrec :: Int -> ChunkError -> ShowS
$cshow :: ChunkError -> String
show :: ChunkError -> String
$cshowList :: [ChunkError] -> ShowS
showList :: [ChunkError] -> ShowS
Show)

instance Exception ChunkError

-- | Get a chunk of data and run a decoder on it.
decodeAt
  :: forall a src io
  .  ( ReadChunk src
     , Show a
     , Typeable a
     , MonadIO io
     )
  => src
  -> Int
  -> Int
  -> Get a
  -> io a
decodeAt :: forall a src (io :: * -> *).
(ReadChunk src, Show a, Typeable a, MonadIO io) =>
src -> Int -> Int -> Get a -> io a
decodeAt src
src Int
offset Int
size Get a
action = do
  ByteString
chunk <- src -> Int -> Int -> io ByteString
forall a (io :: * -> *).
(ReadChunk a, MonadIO io) =>
a -> Int -> Int -> io ByteString
forall (io :: * -> *).
MonadIO io =>
src -> Int -> Int -> io ByteString
readChunkAt src
src Int
offset Int
size
  case Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
forall a.
Get a
-> ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
runGetOrFail Get a
action ([ByteString] -> ByteString
BSL.fromChunks [ByteString
chunk]) of
    Right (ByteString
"", ByteOffset
used, a
ok) | ByteOffset -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ByteOffset
used Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
size ->
      a -> io a
forall a. a -> io a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
ok
    Right (ByteString
remains, ByteOffset
finalOffset, a
_okBut) ->
      IO a -> io a
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> io a) -> (DecodeError -> IO a) -> DecodeError -> io a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeError -> IO a
forall e a. Exception e => e -> IO a
throwIO (DecodeError -> io a) -> DecodeError -> io a
forall a b. (a -> b) -> a -> b
$ ByteOffset -> Text -> DecodeError
DecodeError
        (Int -> ByteOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset ByteOffset -> ByteOffset -> ByteOffset
forall a. Num a => a -> a -> a
+ ByteOffset
finalOffset)
        ( Text
"BUG: unused data " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
          String -> Text
forall a. IsString a => String -> a
fromString (ByteString -> String
forall a. Show a => a -> String
show ByteString
remains)
        )
    Left (ByteString
_remains, ByteOffset
errorOffset, String
message) ->
      IO a -> io a
forall a. IO a -> io a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> io a) -> (DecodeError -> IO a) -> DecodeError -> io a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeError -> IO a
forall e a. Exception e => e -> IO a
throwIO (DecodeError -> io a) -> DecodeError -> io a
forall a b. (a -> b) -> a -> b
$ ByteOffset -> Text -> DecodeError
DecodeError
        (Int -> ByteOffset
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset ByteOffset -> ByteOffset -> ByteOffset
forall a. Num a => a -> a -> a
+ ByteOffset
errorOffset)
        ( String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
            [ String
typeName
            , String
"-"
            , String
message
            ]
        )
  where
    typeName :: String
typeName = TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

data DecodeError = DecodeError ByteOffset Text
  deriving (DecodeError -> DecodeError -> Bool
(DecodeError -> DecodeError -> Bool)
-> (DecodeError -> DecodeError -> Bool) -> Eq DecodeError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecodeError -> DecodeError -> Bool
== :: DecodeError -> DecodeError -> Bool
$c/= :: DecodeError -> DecodeError -> Bool
/= :: DecodeError -> DecodeError -> Bool
Eq, Int -> DecodeError -> ShowS
[DecodeError] -> ShowS
DecodeError -> String
(Int -> DecodeError -> ShowS)
-> (DecodeError -> String)
-> ([DecodeError] -> ShowS)
-> Show DecodeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecodeError -> ShowS
showsPrec :: Int -> DecodeError -> ShowS
$cshow :: DecodeError -> String
show :: DecodeError -> String
$cshowList :: [DecodeError] -> ShowS
showList :: [DecodeError] -> ShowS
Show)

instance Exception DecodeError

class ReadLevel a where
  readLevelTo :: MonadIO io => a -> Level -> Ptr () -> io Bool