flatbuffers-0.3.0.0: src/FlatBuffers/Internal/Read.hs
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE InstanceSigs #-}
{-# OPTIONS_HADDOCK not-home #-}
{- HLINT ignore readTableFieldOpt "Avoid lambda" -}
-- Using `replicateM` here causes a performance regression.
{- HLINT ignore inlineVectorToList "Use replicateM" -}
module FlatBuffers.Internal.Read where
import Control.Monad ( (>=>), join )
import Data.Binary.Get ( Get )
import qualified Data.Binary.Get as G
import qualified Data.ByteString as BS
import Data.ByteString.Lazy ( ByteString )
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Internal as BSL
import qualified Data.ByteString.Unsafe as BSU
import Data.Coerce ( coerce )
import Data.Functor ( (<&>) )
import Data.Int
import qualified Data.List as L
import Data.Text ( Text )
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import Data.Word
import FlatBuffers.Internal.Constants
import FlatBuffers.Internal.FileIdentifier ( FileIdentifier(..), HasFileIdentifier(..) )
import FlatBuffers.Internal.Types
import Prelude hiding ( drop, length, take )
type ReadError = String
newtype TableIndex = TableIndex { unTableIndex :: Word16 }
deriving newtype (Show, Num)
newtype VOffset = VOffset { unVOffset :: Word16 }
deriving newtype (Show, Num, Real, Ord, Enum, Integral, Eq)
-- NOTE: this is an Int32 because a buffer is assumed to respect the size limit of 2^31 - 1.
newtype OffsetFromRoot = OffsetFromRoot Int32
deriving newtype (Show, Num, Real, Ord, Enum, Integral, Eq)
-- | A table that is being read from a flatbuffer.
data Table a = Table
{ vtable :: !Position
, tablePos :: !PositionInfo
}
-- | A struct that is being read from a flatbuffer.
newtype Struct a = Struct
{ structPos :: Position
}
-- | A union that is being read from a flatbuffer.
data Union a
= Union !a
| UnionNone
| UnionUnknown !Word8
type Position = ByteString
-- | Current position in the buffer
data PositionInfo = PositionInfo
{ posRoot :: !Position -- ^ Pointer to the buffer root
, posCurrent :: !Position -- ^ Pointer to current position
, posOffsetFromRoot :: !OffsetFromRoot -- ^ Number of bytes between current position and root
}
class HasPosition a where
getPosition :: a -> Position
move :: Integral i => a -> i -> a
instance HasPosition ByteString where
getPosition = id
move bs offset = BSL.drop (fromIntegral @_ @Int64 offset) bs
instance HasPosition PositionInfo where
getPosition = posCurrent
move PositionInfo{..} offset =
PositionInfo
{ posRoot = posRoot
, posCurrent = move posCurrent offset
, posOffsetFromRoot = posOffsetFromRoot + OffsetFromRoot (fromIntegral @_ @Int32 offset)
}
-- | Deserializes a flatbuffer from a lazy `ByteString`.
decode :: ByteString -> Either ReadError (Table a)
decode root = readTable initialPos
where
initialPos = PositionInfo root root 0
-- | Checks if a buffer contains the file identifier for a root table @a@, to see if it's
-- safe to decode it to a `Table`.
-- It should be used in conjunction with @-XTypeApplications@.
--
-- > {-# LANGUAGE TypeApplications #-}
-- >
-- > if checkFileIdentifier @Monster bs
-- > then decode @Monster bs
-- > else return someMonster
checkFileIdentifier :: forall a. HasFileIdentifier a => ByteString -> Bool
checkFileIdentifier = checkFileIdentifier' (getFileIdentifier @a)
checkFileIdentifier' :: FileIdentifier -> ByteString -> Bool
checkFileIdentifier' (unFileIdentifier -> fileIdent) bs =
actualFileIdent == BSL.fromStrict fileIdent
where
actualFileIdent =
BSL.take fileIdentifierSize .
BSL.drop uoffsetSize $
bs
-- | Proof that a number is strictly positive.
newtype Positive a = Positive { getPositive :: a }
deriving newtype (Eq, Show)
{-# INLINE positive #-}
positive :: (Num a, Ord a) => a -> Maybe (Positive a)
positive n = if n > 0 then Just (Positive n) else Nothing
----------------------------------
------------ Vectors -------------
----------------------------------
{-# INLINE moveToElem #-}
moveToElem :: HasPosition pos => pos -> Int32 -> Int32 -> pos
moveToElem pos elemSize ix =
move pos (ix * elemSize)
{-# INLINE checkIndexBounds #-}
checkIndexBounds :: Int32 -> Int32 -> Int32
checkIndexBounds ix length
| ix < 0 = error ("FlatBuffers.Internal.Read.index: negative index: " <> show ix)
| ix >= length = error ("FlatBuffers.Internal.Read.index: index too large: " <> show ix)
| otherwise = ix
{-# INLINE inlineVectorToList #-}
inlineVectorToList :: Get a -> Int32 -> Position -> Either ReadError [a]
inlineVectorToList get len pos =
runGet pos $
sequence $ L.replicate (fromIntegral @Int32 @Int len) get
-- | @clamp n upperBound@ truncates a value to stay between @0@ and @upperBound@.
clamp :: Int32 -> Int32 -> Int32
clamp n upperBound = n `min` upperBound `max` 0
class VectorElement a where
-- | A vector that is being read from a flatbuffer.
data Vector a
-- | Returns the size of the vector.
--
-- /O(1)/.
length :: Vector a -> Int32
-- | Returns the item at the given index without performing the bounds check.
--
-- Given an invalid index, @unsafeIndex@ will likely read garbage data or return a `ReadError`.
-- In the case of @Vector Word8@, using a negative index carries the same risks as `BSU.unsafeIndex`
-- (i.e. reading from outside the buffer's boundaries).
--
-- /O(c)/, where /c/ is the number of chunks in the underlying `ByteString`.
unsafeIndex :: Vector a -> Int32 -> Either ReadError a
-- | Converts the vector to a list.
--
-- /O(n)/.
toList :: Vector a -> Either ReadError [a]
-- | @take n xs@ returns the prefix of @xs@ of length @n@, or @xs@ itself if @n > length xs@.
--
-- /O(1)/.
--
-- @since 0.2.0.0
take :: Int32 -> Vector a -> Vector a
-- | @drop n xs@ returns the suffix of @xs@ after the first @n@ elements, or @[]@ if @n > length xs@.
--
-- /O(c)/, where /c/ is the number of chunks in the underlying `ByteString`.
--
-- @since 0.2.0.0
drop :: Int32 -> Vector a -> Vector a
-- | Returns the item at the given index.
-- If the given index is negative or too large, an `error` is thrown.
--
-- /O(c)/, where /c/ is the number of chunks in the underlying `ByteString`.
index :: VectorElement a => Vector a -> Int32 -> Either ReadError a
index vec ix = unsafeIndex vec . checkIndexBounds ix $ length vec
-- | Convert the vector to a lazy `ByteString`.
--
-- /O(c)/, where /c/ is the number of chunks in the underlying `ByteString`.
--
-- @since 0.2.0.0
toLazyByteString :: Vector Word8 -> ByteString
toLazyByteString (VectorWord8 len pos) =
BSL.take (fromIntegral @Int32 @Int64 len) pos
instance VectorElement Word8 where
data Vector Word8 = VectorWord8 !Int32 !Position
length (VectorWord8 len _) = len
unsafeIndex (VectorWord8 _ pos) = byteStringSafeIndex pos
take n (VectorWord8 len pos) = VectorWord8 (clamp n len) pos
drop n (VectorWord8 len pos) = VectorWord8 (clamp (len - n) len) (BSL.drop (fromIntegral @Int32 @Int64 n) pos)
toList = Right . BSL.unpack . toLazyByteString
instance VectorElement Word16 where
data Vector Word16 = VectorWord16 !Int32 !Position
length (VectorWord16 len _) = len
unsafeIndex (VectorWord16 _ pos) = readWord16 . moveToElem pos word16Size
take n (VectorWord16 len pos) = VectorWord16 (clamp n len) pos
drop n (VectorWord16 len pos) = VectorWord16 (len - n') (moveToElem pos word16Size n')
where n' = clamp n len
toList (VectorWord16 len pos) = inlineVectorToList G.getWord16le len pos
instance VectorElement Word32 where
data Vector Word32 = VectorWord32 !Int32 !Position
length (VectorWord32 len _) = len
unsafeIndex (VectorWord32 _ pos) = readWord32 . moveToElem pos word32Size
take n (VectorWord32 len pos) = VectorWord32 (clamp n len) pos
drop n (VectorWord32 len pos) = VectorWord32 (len - n') (moveToElem pos word32Size n')
where n' = clamp n len
toList (VectorWord32 len pos) = inlineVectorToList G.getWord32le len pos
instance VectorElement Word64 where
data Vector Word64 = VectorWord64 !Int32 !Position
length (VectorWord64 len _) = len
unsafeIndex (VectorWord64 _ pos) = readWord64 . moveToElem pos word64Size
take n (VectorWord64 len pos) = VectorWord64 (clamp n len) pos
drop n (VectorWord64 len pos) = VectorWord64 (len - n') (moveToElem pos word64Size n')
where n' = clamp n len
toList (VectorWord64 len pos) = inlineVectorToList G.getWord64le len pos
instance VectorElement Int8 where
data Vector Int8 = VectorInt8 !Int32 !Position
length (VectorInt8 len _) = len
unsafeIndex (VectorInt8 _ pos) = readInt8 . moveToElem pos int8Size
take n (VectorInt8 len pos) = VectorInt8 (clamp n len) pos
drop n (VectorInt8 len pos) = VectorInt8 (len - n') (moveToElem pos int8Size n')
where n' = clamp n len
toList (VectorInt8 len pos) = inlineVectorToList G.getInt8 len pos
instance VectorElement Int16 where
data Vector Int16 = VectorInt16 !Int32 !Position
length (VectorInt16 len _) = len
unsafeIndex (VectorInt16 _ pos) = readInt16 . moveToElem pos int16Size
take n (VectorInt16 len pos) = VectorInt16 (clamp n len) pos
drop n (VectorInt16 len pos) = VectorInt16 (len - n') (moveToElem pos int16Size n')
where n' = clamp n len
toList (VectorInt16 len pos) = inlineVectorToList G.getInt16le len pos
instance VectorElement Int32 where
data Vector Int32 = VectorInt32 !Int32 !Position
length (VectorInt32 len _) = len
unsafeIndex (VectorInt32 _ pos) = readInt32 . moveToElem pos int32Size
take n (VectorInt32 len pos) = VectorInt32 (clamp n len) pos
drop n (VectorInt32 len pos) = VectorInt32 (len - n') (moveToElem pos int32Size n')
where n' = clamp n len
toList (VectorInt32 len pos) = inlineVectorToList G.getInt32le len pos
instance VectorElement Int64 where
data Vector Int64 = VectorInt64 !Int32 !Position
length (VectorInt64 len _) = len
unsafeIndex (VectorInt64 _ pos) = readInt64 . moveToElem pos int64Size
take n (VectorInt64 len pos) = VectorInt64 (clamp n len) pos
drop n (VectorInt64 len pos) = VectorInt64 (len - n') (moveToElem pos int64Size n')
where n' = clamp n len
toList (VectorInt64 len pos) = inlineVectorToList G.getInt64le len pos
instance VectorElement Float where
data Vector Float = VectorFloat !Int32 !Position
length (VectorFloat len _) = len
unsafeIndex (VectorFloat _ pos) = readFloat . moveToElem pos floatSize
take n (VectorFloat len pos) = VectorFloat (clamp n len) pos
drop n (VectorFloat len pos) = VectorFloat (len - n') (moveToElem pos floatSize n')
where n' = clamp n len
toList (VectorFloat len pos) = inlineVectorToList G.getFloatle len pos
instance VectorElement Double where
data Vector Double = VectorDouble !Int32 !Position
length (VectorDouble len _) = len
unsafeIndex (VectorDouble _ pos) = readDouble . moveToElem pos doubleSize
take n (VectorDouble len pos) = VectorDouble (clamp n len) pos
drop n (VectorDouble len pos) = VectorDouble (len - n') (moveToElem pos doubleSize n')
where n' = clamp n len
toList (VectorDouble len pos) = inlineVectorToList G.getDoublele len pos
instance VectorElement Bool where
data Vector Bool = VectorBool !Int32 !Position
length (VectorBool len _) = len
unsafeIndex (VectorBool _ pos) = readBool . moveToElem pos boolSize
take n (VectorBool len pos) = VectorBool (clamp n len) pos
drop n (VectorBool len pos) = VectorBool (len - n') (moveToElem pos boolSize n')
where n' = clamp n len
toList (VectorBool len pos) = fmap word8ToBool <$> toList (VectorWord8 len pos)
instance VectorElement Text where
data Vector Text = VectorText !Int32 !Position
length (VectorText len _) = len
unsafeIndex (VectorText _ pos) = readText . moveToElem pos textRefSize
take n (VectorText len pos) = VectorText (clamp n len) pos
drop n (VectorText len pos) = VectorText (len - n') (moveToElem pos textRefSize n')
where n' = clamp n len
toList :: Vector Text -> Either ReadError [Text]
toList (VectorText len pos) = do
offsets <- inlineVectorToList G.getInt32le len pos
L.reverse <$> go offsets 0 []
where
go :: [Int32] -> Int32 -> [Text] -> Either ReadError [Text]
go [] _ acc = Right acc
go (offset : xs) ix acc = do
let textPos = move pos (offset + (ix * 4))
text <- join $ runGet textPos readText'
go xs (ix + 1) (text : acc)
instance IsStruct a => VectorElement (Struct a) where
data Vector (Struct a) = VectorStruct !Int32 !Position
length (VectorStruct len _) = len
unsafeIndex (VectorStruct _ pos) = Right . readStruct . moveToElem pos (fromIntegral (structSizeOf @a))
take n (VectorStruct len pos) = VectorStruct (clamp n len) pos
drop n (VectorStruct len pos) = VectorStruct (len - n') (moveToElem pos (fromIntegral (structSizeOf @a)) n')
where n' = clamp n len
toList (VectorStruct len pos) =
Right (go len pos)
where
go :: Int32 -> Position -> [Struct a]
go 0 _ = []
go !len pos =
let head = readStruct pos
tail = go (len - 1) (move pos (structSizeOf @a))
in head : tail
instance VectorElement (Table a) where
data Vector (Table a) = VectorTable !Int32 !PositionInfo
length (VectorTable len _) = len
unsafeIndex (VectorTable _ pos) = readTable . moveToElem pos tableRefSize
take n (VectorTable len pos) = VectorTable (clamp n len) pos
drop n (VectorTable len pos) = VectorTable (len - n') (moveToElem pos tableRefSize n')
where n' = clamp n len
toList (VectorTable len vectorPos) = do
offsets <- inlineVectorToList G.getInt32le len (getPosition vectorPos)
go offsets 0
where
go :: [Int32] -> Int32 -> Either ReadError [Table a]
go [] _ = Right []
go (offset : offsets) !ix = do
let tablePos = move vectorPos (offset + (ix * 4))
table <- readTable' tablePos
tables <- go offsets (ix + 1)
pure (table : tables)
instance VectorElement (Union a) where
data Vector (Union a) = VectorUnion
{ vectorUnionTypesPos :: !(Vector Word8)
-- ^ A byte-vector, where each byte represents the type of each "union value" in the vector
, vectorUnionValuesPos :: !PositionInfo
-- ^ A table vector, with the actual union values
, vectorUnionReadElem :: !(Positive Word8 -> PositionInfo -> Either ReadError (Union a))
-- ^ A function to read a union value from this vector
}
-- NOTE: we assume the two vectors have the same length
length = length . vectorUnionTypesPos
unsafeIndex (VectorUnion typesPos valuesPos readElem) ix = do
unionType <- unsafeIndex typesPos ix
case positive unionType of
Nothing -> Right UnionNone
Just unionType' -> do
tablePos <- readUOffsetAndSkip $ moveToElem valuesPos tableRefSize ix
readElem unionType' tablePos
take n (VectorUnion typesPos valuesPos readElem) = VectorUnion (take n typesPos) valuesPos readElem
drop n vec@(VectorUnion typesPos valuesPos readElem) = VectorUnion (drop n typesPos) (moveToElem valuesPos tableRefSize n') readElem
where n' = clamp n (length vec)
toList vec@(VectorUnion typesPos valuesPos readElem) = do
unionTypes <- toList typesPos
offsets <- inlineVectorToList G.getInt32le (length vec) (getPosition valuesPos)
go unionTypes offsets 0
where
go :: [Word8] -> [Int32] -> Int32 -> Either ReadError [Union a]
go [] [] _ = Right []
go (unionType : unionTypes) (offset : offsets) !ix = do
union <-
case positive unionType of
Nothing -> Right UnionNone
Just unionType' ->
let tablePos = move valuesPos (offset + (ix * 4))
in readElem unionType' tablePos
unions <- go unionTypes offsets (ix + 1)
pure (union : unions)
go _ _ _ = Left "Union vector: 'type vector' and 'value vector' do not have the same length."
----------------------------------
----- Read from Struct/Table -----
----------------------------------
{-# INLINE readStructField #-}
readStructField :: (Position -> a) -> VOffset -> Struct s -> a
readStructField read voffset (Struct bs) =
read (move bs voffset)
{-# INLINE readTableFieldOpt #-}
readTableFieldOpt :: (PositionInfo -> Either ReadError a) -> TableIndex -> Table t -> Either ReadError (Maybe a)
readTableFieldOpt read ix t = do
mbOffset <- tableIndexToVOffset t ix
traverse (\offset -> read (move (tablePos t) offset)) mbOffset
{-# INLINE readTableFieldReq #-}
readTableFieldReq :: (PositionInfo -> Either ReadError a) -> TableIndex -> String -> Table t -> Either ReadError a
readTableFieldReq read ix name t = do
mbOffset <- tableIndexToVOffset t ix
case mbOffset of
Nothing -> missingField name
Just offset -> read (move (tablePos t) offset)
{-# INLINE readTableFieldWithDef #-}
readTableFieldWithDef :: (PositionInfo -> Either ReadError a) -> TableIndex -> a -> Table t -> Either ReadError a
readTableFieldWithDef read ix dflt t =
tableIndexToVOffset t ix >>= \case
Nothing -> Right dflt
Just offset -> read (move (tablePos t) offset)
{-# INLINE readTableFieldUnion #-}
readTableFieldUnion :: (Positive Word8 -> PositionInfo -> Either ReadError (Union a)) -> TableIndex -> Table t -> Either ReadError (Union a)
readTableFieldUnion read ix t =
readTableFieldWithDef readWord8 (ix - 1) 0 t >>= \unionType ->
case positive unionType of
Nothing -> Right UnionNone
Just unionType' ->
tableIndexToVOffset t ix >>= \case
Nothing -> Left "Union: 'union type' found but 'union value' is missing."
Just offset -> readUOffsetAndSkip (move (tablePos t) offset) >>= read unionType'
readTableFieldUnionVectorOpt ::
(Positive Word8 -> PositionInfo -> Either ReadError (Union a))
-> TableIndex
-> Table t
-> Either ReadError (Maybe (Vector (Union a)))
readTableFieldUnionVectorOpt read ix t =
tableIndexToVOffset t (ix - 1) >>= \case
Nothing -> Right Nothing
Just typesOffset ->
tableIndexToVOffset t ix >>= \case
Nothing -> Left "Union vector: 'type vector' found but 'value vector' is missing."
Just valuesOffset ->
Just <$> readUnionVector read (move (tablePos t) typesOffset) (move (tablePos t) valuesOffset)
readTableFieldUnionVectorReq ::
(Positive Word8 -> PositionInfo -> Either ReadError (Union a))
-> TableIndex
-> String
-> Table t
-> Either ReadError (Vector (Union a))
readTableFieldUnionVectorReq read ix name t =
tableIndexToVOffset t (ix - 1) >>= \case
Nothing -> missingField name
Just typesOffset ->
tableIndexToVOffset t ix >>= \case
Nothing -> Left "Union vector: 'type vector' found but 'value vector' is missing."
Just valuesOffset ->
readUnionVector read (move (tablePos t) typesOffset) (move (tablePos t) valuesOffset)
----------------------------------
------ Read from `Position` ------
----------------------------------
{-# INLINE readInt8 #-}
readInt8 :: HasPosition a => a -> Either ReadError Int8
readInt8 (getPosition -> pos) = runGet pos G.getInt8
{-# INLINE readInt16 #-}
readInt16 :: HasPosition a => a -> Either ReadError Int16
readInt16 (getPosition -> pos) = runGet pos G.getInt16le
{-# INLINE readInt32 #-}
readInt32 :: HasPosition a => a -> Either ReadError Int32
readInt32 (getPosition -> pos) = runGet pos G.getInt32le
{-# INLINE readInt64 #-}
readInt64 :: HasPosition a => a -> Either ReadError Int64
readInt64 (getPosition -> pos) = runGet pos G.getInt64le
{-# INLINE readWord8 #-}
readWord8 :: HasPosition a => a -> Either ReadError Word8
readWord8 (getPosition -> pos) = runGet pos G.getWord8
{-# INLINE readWord16 #-}
readWord16 :: HasPosition a => a -> Either ReadError Word16
readWord16 (getPosition -> pos) = runGet pos G.getWord16le
{-# INLINE readWord32 #-}
readWord32 :: HasPosition a => a -> Either ReadError Word32
readWord32 (getPosition -> pos) = runGet pos G.getWord32le
{-# INLINE readWord64 #-}
readWord64 :: HasPosition a => a -> Either ReadError Word64
readWord64 (getPosition -> pos) = runGet pos G.getWord64le
{-# INLINE readFloat #-}
readFloat :: HasPosition a => a -> Either ReadError Float
readFloat (getPosition -> pos) = runGet pos G.getFloatle
{-# INLINE readDouble #-}
readDouble :: HasPosition a => a -> Either ReadError Double
readDouble (getPosition -> pos) = runGet pos G.getDoublele
{-# INLINE readBool #-}
readBool :: HasPosition a => a -> Either ReadError Bool
readBool p = word8ToBool <$> readWord8 p
{-# INLINE word8ToBool #-}
word8ToBool :: Word8 -> Bool
word8ToBool 0 = False
word8ToBool _ = True
readPrimVector ::
(Int32 -> Position -> Vector a)
-> PositionInfo
-> Either ReadError (Vector a)
readPrimVector vecConstructor (posCurrent -> pos) = do
vecPos <- readUOffsetAndSkip pos
vecLength <- readInt32 vecPos
Right $! vecConstructor vecLength (move vecPos (int32Size :: Int64))
readTableVector :: PositionInfo -> Either ReadError (Vector (Table a))
readTableVector pos = do
vecPos <- readUOffsetAndSkip pos
vecLength <- readInt32 vecPos
Right $! VectorTable vecLength (move vecPos (int32Size :: Int64))
readUnionVector ::
(Positive Word8 -> PositionInfo -> Either ReadError (Union a))
-> PositionInfo
-> PositionInfo
-> Either ReadError (Vector (Union a))
readUnionVector readUnion typesPos valuesPos =
do
typesVec <- readPrimVector VectorWord8 typesPos
valuesVec <- readUOffsetAndSkip valuesPos
Right $! VectorUnion
typesVec
(move valuesVec (int32Size :: Int64))
readUnion
-- | Follow a pointer to the position of a string and read it.
{-# INLINE readText #-}
readText :: HasPosition a => a -> Either ReadError Text
readText (getPosition -> pos) =
join $ runGet pos $ do
uoffset <- G.getInt32le
-- NOTE: this might overflow in systems where Int has less than 32 bits
G.skip (fromIntegral @Int32 @Int (uoffset - uoffsetSize))
readText'
-- | Read a string from the current buffer position.
{-# INLINE readText' #-}
readText' :: Get (Either ReadError Text)
readText' = do
strLength <- G.getInt32le
-- NOTE: this might overflow in systems where Int has less than 32 bits
bs <- G.getByteString $ fromIntegral @Int32 @Int strLength
pure $! case T.decodeUtf8' bs of
Right t -> Right t
Left (T.DecodeError msg byteMaybe) ->
case byteMaybe of
Just byte -> Left $ "UTF8 decoding error (byte " <> show byte <> "): " <> msg
Nothing -> Left $ "UTF8 decoding error: " <> msg
-- The `EncodeError` constructor is deprecated and not used
-- https://hackage.haskell.org/package/text-1.2.3.1/docs/Data-Text-Encoding-Error.html#t:UnicodeException
Left _ -> error "the impossible happened"
-- | Follow a pointer to the position of a table and read it.
{-# INLINE readTable #-}
readTable :: PositionInfo -> Either ReadError (Table t)
readTable = readUOffsetAndSkip >=> readTable'
-- | Read a table from the current buffer position.
{-# INLINE readTable' #-}
readTable' :: PositionInfo -> Either ReadError (Table t)
readTable' tablePos =
readInt32 tablePos <&> \soffset ->
let vtableOffsetFromRoot = coerce (posOffsetFromRoot tablePos) - soffset
vtable = move (posRoot tablePos) vtableOffsetFromRoot
in Table vtable tablePos
{-# INLINE readStruct #-}
readStruct :: HasPosition a => a -> Struct s
readStruct = Struct . getPosition
----------------------------------
---------- Primitives ------------
----------------------------------
{-# INLINE tableIndexToVOffset #-}
tableIndexToVOffset :: Table t -> TableIndex -> Either ReadError (Maybe VOffset)
tableIndexToVOffset Table{..} ix =
runGet vtable $ do
vtableSize <- G.getWord16le
let vtableIndex = 4 + (unTableIndex ix * 2)
if vtableIndex >= vtableSize
then pure Nothing
else do
G.skip (fromIntegral @Word16 @Int vtableIndex - 2)
G.getWord16le <&> \case
0 -> Nothing
word16 -> Just (VOffset word16)
{-# INLINE readUOffsetAndSkip #-}
readUOffsetAndSkip :: HasPosition pos => pos -> Either ReadError pos
readUOffsetAndSkip pos =
move pos <$> readInt32 pos
{-# INLINE runGet #-}
runGet :: ByteString -> Get a -> Either ReadError a
runGet bs get =
case G.runGetOrFail get bs of
Right (_, _, a) -> Right a
Left (_, _, msg) -> Left msg
{-# NOINLINE missingField #-}
missingField :: String -> Either ReadError a
missingField fieldName =
Left $ "Missing required table field: " <> fieldName
-- | Safer version of `Data.ByteString.Lazy.index` that doesn't throw when index is too large.
-- Assumes @i > 0@.
-- Adapted from `Data.ByteString.Lazy.index`: https://hackage.haskell.org/package/bytestring-0.10.8.2/docs/src/Data.ByteString.Lazy.html#index
{-# INLINE byteStringSafeIndex #-}
byteStringSafeIndex :: ByteString -> Int32 -> Either ReadError Word8
byteStringSafeIndex !cs0 !i =
index' cs0 i
where index' BSL.Empty _ = Left "not enough bytes"
index' (BSL.Chunk c cs) n
-- NOTE: this might overflow in systems where Int has less than 32 bits
| fromIntegral @Int32 @Int n >= BS.length c =
-- Note: it's safe to narrow `BS.length` to an int32 here, the line above proves it.
index' cs (n - fromIntegral @Int @Int32 (BS.length c))
| otherwise = Right $! BSU.unsafeIndex c (fromIntegral @Int32 @Int n)