{-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns #-}
{-# LANGUAGE Trustworthy #-}
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
#include "MachDeps.h"
#endif
module Data.Binary.Get (
Get
, runGet
, runGetOrFail
, ByteOffset
, Decoder(..)
, runGetIncremental
, pushChunk
, pushChunks
, pushEndOfInput
, skip
, isEmpty
, bytesRead
, isolate
, lookAhead
, lookAheadM
, lookAheadE
, label
, getByteString
, getLazyByteString
, getLazyByteStringNul
, getRemainingLazyByteString
, getWord8
, getWord16be
, getWord32be
, getWord64be
, getWord16le
, getWord32le
, getWord64le
, getWordhost
, getWord16host
, getWord32host
, getWord64host
, getInt8
, getInt16be
, getInt32be
, getInt64be
, getInt16le
, getInt32le
, getInt64le
, getInthost
, getInt16host
, getInt32host
, getInt64host
, getFloatbe
, getFloatle
, getFloathost
, getDoublebe
, getDoublele
, getDoublehost
, runGetState
, remaining
, getBytes
) where
#if ! MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Foreign
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Internal as L
import Data.Binary.Get.Internal hiding ( Decoder(..), runGetIncremental )
import qualified Data.Binary.Get.Internal as I
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
import GHC.Base
import GHC.Word
#endif
import Data.Binary.FloatCast (wordToFloat, wordToDouble)
data Decoder a = Fail !B.ByteString {-# UNPACK #-} !ByteOffset String
| Partial (Maybe B.ByteString -> Decoder a)
| Done !B.ByteString {-# UNPACK #-} !ByteOffset a
runGetIncremental :: Get a -> Decoder a
runGetIncremental = calculateOffset . I.runGetIncremental
calculateOffset :: I.Decoder a -> Decoder a
calculateOffset r0 = go r0 0
where
go r !acc = case r of
I.Done inp a -> Done inp (acc - fromIntegral (B.length inp)) a
I.Fail inp s -> Fail inp (acc - fromIntegral (B.length inp)) s
I.Partial k ->
Partial $ \ms ->
case ms of
Nothing -> go (k Nothing) acc
Just i -> go (k ms) (acc + fromIntegral (B.length i))
I.BytesRead unused k ->
go (k $! (acc - unused)) acc
{-# DEPRECATED runGetState "Use runGetIncremental instead. This function will be removed." #-}
runGetState :: Get a -> L.ByteString -> ByteOffset -> (a, L.ByteString, ByteOffset)
runGetState g lbs0 pos' = go (runGetIncremental g) lbs0
where
go (Done s pos a) lbs = (a, L.chunk s lbs, pos+pos')
go (Partial k) lbs = go (k (takeHeadChunk lbs)) (dropHeadChunk lbs)
go (Fail _ pos msg) _ =
error ("Data.Binary.Get.runGetState at position " ++ show pos ++ ": " ++ msg)
takeHeadChunk :: L.ByteString -> Maybe B.ByteString
takeHeadChunk lbs =
case lbs of
(L.Chunk bs _) -> Just bs
_ -> Nothing
dropHeadChunk :: L.ByteString -> L.ByteString
dropHeadChunk lbs =
case lbs of
(L.Chunk _ lbs') -> lbs'
_ -> L.Empty
runGetOrFail :: Get a -> L.ByteString
-> Either (L.ByteString, ByteOffset, String) (L.ByteString, ByteOffset, a)
runGetOrFail g lbs0 = feedAll (runGetIncremental g) lbs0
where
feedAll (Done bs pos x) lbs = Right (L.chunk bs lbs, pos, x)
feedAll (Partial k) lbs = feedAll (k (takeHeadChunk lbs)) (dropHeadChunk lbs)
feedAll (Fail x pos msg) xs = Left (L.chunk x xs, pos, msg)
type ByteOffset = Int64
runGet :: Get a -> L.ByteString -> a
runGet g lbs0 = feedAll (runGetIncremental g) lbs0
where
feedAll (Done _ _ x) _ = x
feedAll (Partial k) lbs = feedAll (k (takeHeadChunk lbs)) (dropHeadChunk lbs)
feedAll (Fail _ pos msg) _ =
error ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg)
pushChunk :: Decoder a -> B.ByteString -> Decoder a
pushChunk r inp =
case r of
Done inp0 p a -> Done (inp0 `B.append` inp) p a
Partial k -> k (Just inp)
Fail inp0 p s -> Fail (inp0 `B.append` inp) p s
pushChunks :: Decoder a -> L.ByteString -> Decoder a
pushChunks r0 = go r0 . L.toChunks
where
go r [] = r
go (Done inp pos a) xs = Done (B.concat (inp:xs)) pos a
go (Fail inp pos s) xs = Fail (B.concat (inp:xs)) pos s
go (Partial k) (x:xs) = go (k (Just x)) xs
pushEndOfInput :: Decoder a -> Decoder a
pushEndOfInput r =
case r of
Done _ _ _ -> r
Partial k -> k Nothing
Fail _ _ _ -> r
skip :: Int -> Get ()
skip n = withInputChunks (fromIntegral n) consumeBytes (const ()) failOnEOF
getLazyByteString :: Int64 -> Get L.ByteString
getLazyByteString n0 = withInputChunks n0 consumeBytes L.fromChunks failOnEOF
consumeBytes :: Consume Int64
consumeBytes n str
| fromIntegral (B.length str) >= n = Right (B.splitAt (fromIntegral n) str)
| otherwise = Left (n - fromIntegral (B.length str))
consumeUntilNul :: Consume ()
consumeUntilNul _ str =
case B.break (==0) str of
(want, rest) | B.null rest -> Left ()
| otherwise -> Right (want, B.drop 1 rest)
consumeAll :: Consume ()
consumeAll _ _ = Left ()
resumeOnEOF :: [B.ByteString] -> Get L.ByteString
resumeOnEOF = return . L.fromChunks
getLazyByteStringNul :: Get L.ByteString
getLazyByteStringNul = withInputChunks () consumeUntilNul L.fromChunks failOnEOF
getRemainingLazyByteString :: Get L.ByteString
getRemainingLazyByteString = withInputChunks () consumeAll L.fromChunks resumeOnEOF
getPtr :: Storable a => Int -> Get a
getPtr n = readNWith n peek
{-# INLINE getPtr #-}
getWord8 :: Get Word8
getWord8 = readN 1 B.unsafeHead
{-# INLINE[2] getWord8 #-}
getInt8 :: Get Int8
getInt8 = fromIntegral <$> getWord8
{-# INLINE getInt8 #-}
{-# RULES
"getWord8/readN" getWord8 = readN 1 B.unsafeHead
"getWord16be/readN" getWord16be = readN 2 word16be
"getWord16le/readN" getWord16le = readN 2 word16le
"getWord32be/readN" getWord32be = readN 4 word32be
"getWord32le/readN" getWord32le = readN 4 word32le
"getWord64be/readN" getWord64be = readN 8 word64be
"getWord64le/readN" getWord64le = readN 8 word64le #-}
getWord16be :: Get Word16
getWord16be = readN 2 word16be
word16be :: B.ByteString -> Word16
word16be = \s ->
(fromIntegral (s `B.unsafeIndex` 0) `shiftl_w16` 8) .|.
(fromIntegral (s `B.unsafeIndex` 1))
{-# INLINE[2] getWord16be #-}
{-# INLINE word16be #-}
getWord16le :: Get Word16
getWord16le = readN 2 word16le
word16le :: B.ByteString -> Word16
word16le = \s ->
(fromIntegral (s `B.unsafeIndex` 1) `shiftl_w16` 8) .|.
(fromIntegral (s `B.unsafeIndex` 0) )
{-# INLINE[2] getWord16le #-}
{-# INLINE word16le #-}
getWord32be :: Get Word32
getWord32be = readN 4 word32be
word32be :: B.ByteString -> Word32
word32be = \s ->
(fromIntegral (s `B.unsafeIndex` 0) `shiftl_w32` 24) .|.
(fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 16) .|.
(fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 8) .|.
(fromIntegral (s `B.unsafeIndex` 3) )
{-# INLINE[2] getWord32be #-}
{-# INLINE word32be #-}
getWord32le :: Get Word32
getWord32le = readN 4 word32le
word32le :: B.ByteString -> Word32
word32le = \s ->
(fromIntegral (s `B.unsafeIndex` 3) `shiftl_w32` 24) .|.
(fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 16) .|.
(fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 8) .|.
(fromIntegral (s `B.unsafeIndex` 0) )
{-# INLINE[2] getWord32le #-}
{-# INLINE word32le #-}
getWord64be :: Get Word64
getWord64be = readN 8 word64be
word64be :: B.ByteString -> Word64
word64be = \s ->
(fromIntegral (s `B.unsafeIndex` 0) `shiftl_w64` 56) .|.
(fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 48) .|.
(fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 40) .|.
(fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 32) .|.
(fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 24) .|.
(fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 16) .|.
(fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 8) .|.
(fromIntegral (s `B.unsafeIndex` 7) )
{-# INLINE[2] getWord64be #-}
{-# INLINE word64be #-}
getWord64le :: Get Word64
getWord64le = readN 8 word64le
word64le :: B.ByteString -> Word64
word64le = \s ->
(fromIntegral (s `B.unsafeIndex` 7) `shiftl_w64` 56) .|.
(fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 48) .|.
(fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 40) .|.
(fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 32) .|.
(fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 24) .|.
(fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 16) .|.
(fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 8) .|.
(fromIntegral (s `B.unsafeIndex` 0) )
{-# INLINE[2] getWord64le #-}
{-# INLINE word64le #-}
getInt16be :: Get Int16
getInt16be = fromIntegral <$> getWord16be
{-# INLINE getInt16be #-}
getInt32be :: Get Int32
getInt32be = fromIntegral <$> getWord32be
{-# INLINE getInt32be #-}
getInt64be :: Get Int64
getInt64be = fromIntegral <$> getWord64be
{-# INLINE getInt64be #-}
getInt16le :: Get Int16
getInt16le = fromIntegral <$> getWord16le
{-# INLINE getInt16le #-}
getInt32le :: Get Int32
getInt32le = fromIntegral <$> getWord32le
{-# INLINE getInt32le #-}
getInt64le :: Get Int64
getInt64le = fromIntegral <$> getWord64le
{-# INLINE getInt64le #-}
getWordhost :: Get Word
getWordhost = getPtr (sizeOf (undefined :: Word))
{-# INLINE getWordhost #-}
getWord16host :: Get Word16
getWord16host = getPtr (sizeOf (undefined :: Word16))
{-# INLINE getWord16host #-}
getWord32host :: Get Word32
getWord32host = getPtr (sizeOf (undefined :: Word32))
{-# INLINE getWord32host #-}
getWord64host :: Get Word64
getWord64host = getPtr (sizeOf (undefined :: Word64))
{-# INLINE getWord64host #-}
getInthost :: Get Int
getInthost = getPtr (sizeOf (undefined :: Int))
{-# INLINE getInthost #-}
getInt16host :: Get Int16
getInt16host = getPtr (sizeOf (undefined :: Int16))
{-# INLINE getInt16host #-}
getInt32host :: Get Int32
getInt32host = getPtr (sizeOf (undefined :: Int32))
{-# INLINE getInt32host #-}
getInt64host :: Get Int64
getInt64host = getPtr (sizeOf (undefined :: Int64))
{-# INLINE getInt64host #-}
getFloatbe :: Get Float
getFloatbe = wordToFloat <$> getWord32be
{-# INLINE getFloatbe #-}
getFloatle :: Get Float
getFloatle = wordToFloat <$> getWord32le
{-# INLINE getFloatle #-}
getFloathost :: Get Float
getFloathost = wordToFloat <$> getWord32host
{-# INLINE getFloathost #-}
getDoublebe :: Get Double
getDoublebe = wordToDouble <$> getWord64be
{-# INLINE getDoublebe #-}
getDoublele :: Get Double
getDoublele = wordToDouble <$> getWord64le
{-# INLINE getDoublele #-}
getDoublehost :: Get Double
getDoublehost = wordToDouble <$> getWord64host
{-# INLINE getDoublehost #-}
shiftl_w16 :: Word16 -> Int -> Word16
shiftl_w32 :: Word32 -> Int -> Word32
shiftl_w64 :: Word64 -> Int -> Word64
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)
shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)
#if WORD_SIZE_IN_BITS < 64
shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
#else
shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
#endif
#else
shiftl_w16 = shiftL
shiftl_w32 = shiftL
shiftl_w64 = shiftL
#endif