847 lines
27 KiB
Haskell
847 lines
27 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE MagicHash #-}
|
|
{-# LANGUAGE Rank2Types #-}
|
|
{-# LANGUAGE BangPatterns #-}
|
|
|
|
-----------------------------------------------------------------------------
|
|
-- |
|
|
-- Module : Data.Serialize.Get
|
|
-- Copyright : Lennart Kolmodin, Galois Inc. 2009
|
|
-- License : BSD3-style (see LICENSE)
|
|
--
|
|
-- Maintainer : Trevor Elliott <trevor@galois.com>
|
|
-- Stability :
|
|
-- Portability :
|
|
--
|
|
-- The Get monad. A monad for efficiently building structures from
|
|
-- strict ByteStrings
|
|
--
|
|
-----------------------------------------------------------------------------
|
|
|
|
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
|
|
#include "MachDeps.h"
|
|
#endif
|
|
|
|
module Data.Serialize.Get (
|
|
|
|
-- * The Get type
|
|
Get
|
|
, runGet
|
|
, runGetLazy
|
|
, runGetState
|
|
, runGetLazyState
|
|
|
|
-- ** Incremental interface
|
|
, Result(..)
|
|
, runGetPartial
|
|
, runGetChunk
|
|
|
|
-- * Parsing
|
|
, ensure
|
|
, isolate
|
|
, label
|
|
, skip
|
|
, uncheckedSkip
|
|
, lookAhead
|
|
, lookAheadM
|
|
, lookAheadE
|
|
, uncheckedLookAhead
|
|
, bytesRead
|
|
|
|
-- * Utility
|
|
, getBytes
|
|
, remaining
|
|
, isEmpty
|
|
|
|
-- * Parsing particular types
|
|
, getWord8
|
|
, getInt8
|
|
|
|
-- ** ByteStrings
|
|
, getByteString
|
|
, getLazyByteString
|
|
, getShortByteString
|
|
|
|
-- ** Big-endian reads
|
|
, getWord16be
|
|
, getWord32be
|
|
, getWord64be
|
|
, getInt16be
|
|
, getInt32be
|
|
, getInt64be
|
|
|
|
-- ** Little-endian reads
|
|
, getWord16le
|
|
, getWord32le
|
|
, getWord64le
|
|
, getInt16le
|
|
, getInt32le
|
|
, getInt64le
|
|
|
|
-- ** Host-endian, unaligned reads
|
|
, getWordhost
|
|
, getWord16host
|
|
, getWord32host
|
|
, getWord64host
|
|
|
|
-- ** Containers
|
|
, getTwoOf
|
|
, getListOf
|
|
, getIArrayOf
|
|
, getTreeOf
|
|
, getSeqOf
|
|
, getMapOf
|
|
, getIntMapOf
|
|
, getSetOf
|
|
, getIntSetOf
|
|
, getMaybeOf
|
|
, getEitherOf
|
|
, getNested
|
|
) where
|
|
|
|
import qualified Control.Applicative as A
|
|
import qualified Control.Monad as M
|
|
import Control.Monad (unless)
|
|
import qualified Control.Monad.Fail as Fail
|
|
import Data.Array.IArray (IArray,listArray)
|
|
import Data.Ix (Ix)
|
|
import Data.List (intercalate)
|
|
import Data.Maybe (isNothing,fromMaybe)
|
|
import Foreign
|
|
import System.IO.Unsafe (unsafeDupablePerformIO)
|
|
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.ByteString.Internal as B
|
|
import qualified Data.ByteString.Unsafe as B
|
|
import qualified Data.ByteString.Lazy as L
|
|
import qualified Data.ByteString.Short as BS
|
|
import qualified Data.IntMap as IntMap
|
|
import qualified Data.IntSet as IntSet
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Sequence as Seq
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Tree as T
|
|
|
|
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
|
|
import GHC.Base
|
|
import GHC.Word
|
|
#endif
|
|
|
|
-- | The result of a parse.
|
|
data Result r = Fail String B.ByteString
|
|
-- ^ The parse failed. The 'String' is the
|
|
-- message describing the error, if any.
|
|
| Partial (B.ByteString -> Result r)
|
|
-- ^ Supply this continuation with more input so that
|
|
-- the parser can resume. To indicate that no more
|
|
-- input is available, use an 'B.empty' string.
|
|
| Done r B.ByteString
|
|
-- ^ The parse succeeded. The 'B.ByteString' is the
|
|
-- input that had not yet been consumed (if any) when
|
|
-- the parse succeeded.
|
|
|
|
instance Show r => Show (Result r) where
|
|
show (Fail msg _) = "Fail " ++ show msg
|
|
show (Partial _) = "Partial _"
|
|
show (Done r bs) = "Done " ++ show r ++ " " ++ show bs
|
|
|
|
instance Functor Result where
|
|
fmap _ (Fail msg rest) = Fail msg rest
|
|
fmap f (Partial k) = Partial (fmap f . k)
|
|
fmap f (Done r bs) = Done (f r) bs
|
|
|
|
-- | The Get monad is an Exception and State monad.
|
|
newtype Get a = Get
|
|
{ unGet :: forall r. Input -> Buffer -> More
|
|
-> Int -> Failure r
|
|
-> Success a r -> Result r }
|
|
|
|
type Input = B.ByteString
|
|
type Buffer = Maybe B.ByteString
|
|
|
|
emptyBuffer :: Buffer
|
|
emptyBuffer = Just B.empty
|
|
|
|
extendBuffer :: Buffer -> B.ByteString -> Buffer
|
|
extendBuffer buf chunk =
|
|
do bs <- buf
|
|
return $! bs `B.append` chunk
|
|
{-# INLINE extendBuffer #-}
|
|
|
|
append :: Buffer -> Buffer -> Buffer
|
|
append l r = B.append `fmap` l A.<*> r
|
|
{-# INLINE append #-}
|
|
|
|
bufferBytes :: Buffer -> B.ByteString
|
|
bufferBytes = fromMaybe B.empty
|
|
{-# INLINE bufferBytes #-}
|
|
|
|
type Failure r = Input -> Buffer -> More -> [String] -> String -> Result r
|
|
type Success a r = Input -> Buffer -> More -> Int -> a -> Result r
|
|
|
|
-- | Have we read all available input?
|
|
data More
|
|
= Complete
|
|
| Incomplete (Maybe Int)
|
|
deriving (Eq)
|
|
|
|
moreLength :: More -> Int
|
|
moreLength m = case m of
|
|
Complete -> 0
|
|
Incomplete mb -> fromMaybe 0 mb
|
|
|
|
instance Functor Get where
|
|
fmap p m = Get $ \ s0 b0 m0 w0 kf ks ->
|
|
unGet m s0 b0 m0 w0 kf $ \ s1 b1 m1 w1 a -> ks s1 b1 m1 w1 (p a)
|
|
|
|
instance A.Applicative Get where
|
|
pure a = Get $ \ s0 b0 m0 w _ ks -> ks s0 b0 m0 w a
|
|
{-# INLINE pure #-}
|
|
|
|
f <*> x = Get $ \ s0 b0 m0 w0 kf ks ->
|
|
unGet f s0 b0 m0 w0 kf $ \ s1 b1 m1 w1 g ->
|
|
unGet x s1 b1 m1 w1 kf $ \ s2 b2 m2 w2 y -> ks s2 b2 m2 w2 (g y)
|
|
{-# INLINE (<*>) #-}
|
|
|
|
m *> k = Get $ \ s0 b0 m0 w0 kf ks ->
|
|
unGet m s0 b0 m0 w0 kf $ \ s1 b1 m1 w1 _ -> unGet k s1 b1 m1 w1 kf ks
|
|
{-# INLINE (*>) #-}
|
|
|
|
instance A.Alternative Get where
|
|
empty = failDesc "empty"
|
|
{-# INLINE empty #-}
|
|
|
|
(<|>) = M.mplus
|
|
{-# INLINE (<|>) #-}
|
|
|
|
-- Definition directly from Control.Monad.State.Strict
|
|
instance Monad Get where
|
|
return = A.pure
|
|
{-# INLINE return #-}
|
|
|
|
m >>= g = Get $ \ s0 b0 m0 w0 kf ks ->
|
|
unGet m s0 b0 m0 w0 kf $ \ s1 b1 m1 w1 a -> unGet (g a) s1 b1 m1 w1 kf ks
|
|
{-# INLINE (>>=) #-}
|
|
|
|
(>>) = (A.*>)
|
|
{-# INLINE (>>) #-}
|
|
|
|
#if !(MIN_VERSION_base(4,13,0))
|
|
fail = Fail.fail
|
|
{-# INLINE fail #-}
|
|
#endif
|
|
|
|
instance Fail.MonadFail Get where
|
|
fail = failDesc
|
|
{-# INLINE fail #-}
|
|
|
|
instance M.MonadPlus Get where
|
|
mzero = failDesc "mzero"
|
|
{-# INLINE mzero #-}
|
|
-- TODO: Test this!
|
|
mplus a b =
|
|
Get $ \s0 b0 m0 w0 kf ks ->
|
|
let ks' s1 b1 = ks s1 (b0 `append` b1)
|
|
kf' _ b1 m1 = kf (s0 `B.append` bufferBytes b1)
|
|
(b0 `append` b1) m1
|
|
try _ b1 m1 _ _ = unGet b (s0 `B.append` bufferBytes b1)
|
|
b1 m1 w0 kf' ks'
|
|
in unGet a s0 emptyBuffer m0 w0 try ks'
|
|
{-# INLINE mplus #-}
|
|
|
|
|
|
------------------------------------------------------------------------
|
|
|
|
formatTrace :: [String] -> String
|
|
formatTrace [] = "Empty call stack"
|
|
formatTrace ls = "From:\t" ++ intercalate "\n\t" ls ++ "\n"
|
|
|
|
get :: Get B.ByteString
|
|
get = Get (\s0 b0 m0 w _ k -> k s0 b0 m0 w s0)
|
|
{-# INLINE get #-}
|
|
|
|
put :: B.ByteString -> Int -> Get ()
|
|
put s !w = Get (\_ b0 m _ _ k -> k s b0 m w ())
|
|
{-# INLINE put #-}
|
|
|
|
label :: String -> Get a -> Get a
|
|
label l m =
|
|
Get $ \ s0 b0 m0 w0 kf ks ->
|
|
let kf' s1 b1 m1 ls = kf s1 b1 m1 (l:ls)
|
|
in unGet m s0 b0 m0 w0 kf' ks
|
|
|
|
finalK :: Success a a
|
|
finalK s _ _ _ a = Done a s
|
|
|
|
failK :: Failure a
|
|
failK s b _ ls msg =
|
|
Fail (unlines [msg, formatTrace ls]) (s `B.append` bufferBytes b)
|
|
|
|
-- | Run the Get monad applies a 'get'-based parser on the input ByteString
|
|
runGet :: Get a -> B.ByteString -> Either String a
|
|
runGet m str =
|
|
case unGet m str Nothing Complete 0 failK finalK of
|
|
Fail i _ -> Left i
|
|
Done a _ -> Right a
|
|
Partial{} -> Left "Failed reading: Internal error: unexpected Partial."
|
|
{-# INLINE runGet #-}
|
|
|
|
-- | Run the get monad on a single chunk, providing an optional length for the
|
|
-- remaining, unseen input, with Nothing indicating that it's not clear how much
|
|
-- input is left. For example, with a lazy ByteString, the optional length
|
|
-- represents the sum of the lengths of all remaining chunks.
|
|
runGetChunk :: Get a -> Maybe Int -> B.ByteString -> Result a
|
|
runGetChunk m mbLen str = unGet m str Nothing (Incomplete mbLen) 0 failK finalK
|
|
{-# INLINE runGetChunk #-}
|
|
|
|
-- | Run the Get monad applies a 'get'-based parser on the input ByteString
|
|
runGetPartial :: Get a -> B.ByteString -> Result a
|
|
runGetPartial m = runGetChunk m Nothing
|
|
{-# INLINE runGetPartial #-}
|
|
|
|
-- | Run the Get monad applies a 'get'-based parser on the input
|
|
-- ByteString, starting at the specified offset. In addition to the result of get
|
|
-- it returns the rest of the input.
|
|
runGetState :: Get a -> B.ByteString -> Int
|
|
-> Either String (a, B.ByteString)
|
|
runGetState m str off = case runGetState' m str off of
|
|
(Right a,bs) -> Right (a,bs)
|
|
(Left i,_) -> Left i
|
|
{-# INLINE runGetState #-}
|
|
|
|
-- | Run the Get monad applies a 'get'-based parser on the input
|
|
-- ByteString, starting at the specified offset. In addition to the result of get
|
|
-- it returns the rest of the input, even in the event of a failure.
|
|
runGetState' :: Get a -> B.ByteString -> Int
|
|
-> (Either String a, B.ByteString)
|
|
runGetState' m str off =
|
|
case unGet m (B.drop off str) Nothing Complete 0 failK finalK of
|
|
Fail i bs -> (Left i,bs)
|
|
Done a bs -> (Right a, bs)
|
|
Partial{} -> (Left "Failed reading: Internal error: unexpected Partial.",B.empty)
|
|
{-# INLINE runGetState' #-}
|
|
|
|
|
|
|
|
-- Lazy Get --------------------------------------------------------------------
|
|
|
|
runGetLazy' :: Get a -> L.ByteString -> (Either String a,L.ByteString)
|
|
runGetLazy' m lstr =
|
|
case L.toChunks lstr of
|
|
[c] -> wrapStrict (runGetState' m c 0)
|
|
[] -> wrapStrict (runGetState' m B.empty 0)
|
|
c:cs -> loop (runGetChunk m (Just (len - B.length c)) c) cs
|
|
where
|
|
len = fromIntegral (L.length lstr)
|
|
|
|
wrapStrict (e,s) = (e,L.fromChunks [s])
|
|
|
|
loop result chunks = case result of
|
|
|
|
Fail str rest -> (Left str, L.fromChunks (rest : chunks))
|
|
Partial k -> case chunks of
|
|
c:cs -> loop (k c) cs
|
|
[] -> loop (k B.empty) []
|
|
|
|
Done r rest -> (Right r, L.fromChunks (rest : chunks))
|
|
{-# INLINE runGetLazy' #-}
|
|
|
|
-- | Run the Get monad over a Lazy ByteString. Note that this will not run the
|
|
-- Get parser lazily, but will operate on lazy ByteStrings.
|
|
runGetLazy :: Get a -> L.ByteString -> Either String a
|
|
runGetLazy m lstr = fst (runGetLazy' m lstr)
|
|
{-# INLINE runGetLazy #-}
|
|
|
|
-- | Run the Get monad over a Lazy ByteString. Note that this does not run the
|
|
-- Get parser lazily, but will operate on lazy ByteStrings.
|
|
runGetLazyState :: Get a -> L.ByteString -> Either String (a,L.ByteString)
|
|
runGetLazyState m lstr = case runGetLazy' m lstr of
|
|
(Right a,rest) -> Right (a,rest)
|
|
(Left err,_) -> Left err
|
|
{-# INLINE runGetLazyState #-}
|
|
|
|
------------------------------------------------------------------------
|
|
|
|
-- | If at least @n@ bytes of input are available, return the current
|
|
-- input, otherwise fail.
|
|
{-# INLINE ensure #-}
|
|
ensure :: Int -> Get B.ByteString
|
|
ensure n0 = n0 `seq` Get $ \ s0 b0 m0 w0 kf ks -> let
|
|
n' = n0 - B.length s0
|
|
in if n' <= 0
|
|
then ks s0 b0 m0 w0 s0
|
|
else getMore n' s0 [] b0 m0 w0 kf ks
|
|
where
|
|
-- The "accumulate and concat" pattern here is important not to incur
|
|
-- in quadratic behavior, see <https://github.com/GaloisInc/cereal/issues/48>
|
|
|
|
finalInput s0 ss = B.concat (reverse (s0 : ss))
|
|
finalBuffer b0 s0 ss = extendBuffer b0 (B.concat (reverse (init (s0 : ss))))
|
|
getMore !n s0 ss b0 m0 w0 kf ks = let
|
|
tooFewBytes = let
|
|
!s = finalInput s0 ss
|
|
!b = finalBuffer b0 s0 ss
|
|
in kf s b m0 ["demandInput"] "too few bytes"
|
|
in case m0 of
|
|
Complete -> tooFewBytes
|
|
Incomplete mb -> Partial $ \s ->
|
|
if B.null s
|
|
then tooFewBytes
|
|
else let
|
|
!mb' = case mb of
|
|
Just l -> Just $! l - B.length s
|
|
Nothing -> Nothing
|
|
in checkIfEnough n s (s0 : ss) b0 (Incomplete mb') w0 kf ks
|
|
|
|
checkIfEnough !n s0 ss b0 m0 w0 kf ks = let
|
|
n' = n - B.length s0
|
|
in if n' <= 0
|
|
then let
|
|
!s = finalInput s0 ss
|
|
!b = finalBuffer b0 s0 ss
|
|
in ks s b m0 w0 s
|
|
else getMore n' s0 ss b0 m0 w0 kf ks
|
|
|
|
-- | Isolate an action to operating within a fixed block of bytes. The action
|
|
-- is required to consume all the bytes that it is isolated to.
|
|
isolate :: Int -> Get a -> Get a
|
|
isolate n m = do
|
|
M.when (n < 0) (fail "Attempted to isolate a negative number of bytes")
|
|
s <- ensure n
|
|
let (s',rest) = B.splitAt n s
|
|
cur <- bytesRead
|
|
put s' cur
|
|
a <- m
|
|
used <- get
|
|
unless (B.null used) (fail "not all bytes parsed in isolate")
|
|
put rest (cur + n)
|
|
return a
|
|
|
|
failDesc :: String -> Get a
|
|
failDesc err = do
|
|
let msg = "Failed reading: " ++ err
|
|
Get (\s0 b0 m0 _ kf _ -> kf s0 b0 m0 [] msg)
|
|
|
|
-- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available.
|
|
skip :: Int -> Get ()
|
|
skip n = do
|
|
s <- ensure n
|
|
cur <- bytesRead
|
|
put (B.drop n s) (cur + n)
|
|
|
|
-- | Skip ahead up to @n@ bytes in the current chunk. No error if there aren't
|
|
-- enough bytes, or if less than @n@ bytes are skipped.
|
|
uncheckedSkip :: Int -> Get ()
|
|
uncheckedSkip n = do
|
|
s <- get
|
|
cur <- bytesRead
|
|
put (B.drop n s) (cur + n)
|
|
|
|
-- | Run @ga@, but return without consuming its input.
|
|
-- Fails if @ga@ fails.
|
|
lookAhead :: Get a -> Get a
|
|
lookAhead ga = Get $ \ s0 b0 m0 w0 kf ks ->
|
|
-- the new continuation extends the old input with the new buffered bytes, and
|
|
-- appends the new buffer to the old one, if there was one.
|
|
let ks' _ b1 = ks (s0 `B.append` bufferBytes b1) (b0 `append` b1)
|
|
kf' _ b1 = kf s0 (b0 `append` b1)
|
|
in unGet ga s0 emptyBuffer m0 w0 kf' ks'
|
|
|
|
-- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'.
|
|
-- Fails if @gma@ fails.
|
|
lookAheadM :: Get (Maybe a) -> Get (Maybe a)
|
|
lookAheadM gma = do
|
|
s <- get
|
|
pre <- bytesRead
|
|
ma <- gma
|
|
M.when (isNothing ma) (put s pre)
|
|
return ma
|
|
|
|
-- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'.
|
|
-- Fails if @gea@ fails.
|
|
lookAheadE :: Get (Either a b) -> Get (Either a b)
|
|
lookAheadE gea = do
|
|
s <- get
|
|
pre <- bytesRead
|
|
ea <- gea
|
|
case ea of
|
|
Left _ -> put s pre
|
|
_ -> return ()
|
|
return ea
|
|
|
|
-- | Get the next up to @n@ bytes as a ByteString until end of this chunk,
|
|
-- without consuming them.
|
|
uncheckedLookAhead :: Int -> Get B.ByteString
|
|
uncheckedLookAhead n = do
|
|
s <- get
|
|
return (B.take n s)
|
|
|
|
------------------------------------------------------------------------
|
|
-- Utility
|
|
|
|
-- | Get the number of remaining unparsed bytes. Useful for checking whether
|
|
-- all input has been consumed.
|
|
--
|
|
-- WARNING: when run with @runGetPartial@, remaining will only return the number
|
|
-- of bytes that are remaining in the current input.
|
|
remaining :: Get Int
|
|
remaining = Get (\ s0 b0 m0 w0 _ ks -> ks s0 b0 m0 w0 (B.length s0 + moreLength m0))
|
|
|
|
-- | Test whether all input has been consumed.
|
|
--
|
|
-- WARNING: when run with @runGetPartial@, isEmpty will only tell you if you're
|
|
-- at the end of the current chunk.
|
|
isEmpty :: Get Bool
|
|
isEmpty = Get (\ s0 b0 m0 w0 _ ks -> ks s0 b0 m0 w0 (B.null s0 && moreLength m0 == 0))
|
|
|
|
------------------------------------------------------------------------
|
|
-- Utility with ByteStrings
|
|
|
|
-- | An efficient 'get' method for strict ByteStrings. Fails if fewer
|
|
-- than @n@ bytes are left in the input. This function creates a fresh
|
|
-- copy of the underlying bytes.
|
|
getByteString :: Int -> Get B.ByteString
|
|
getByteString n = do
|
|
bs <- getBytes n
|
|
return $! B.copy bs
|
|
|
|
getLazyByteString :: Int64 -> Get L.ByteString
|
|
getLazyByteString n = f `fmap` getByteString (fromIntegral n)
|
|
where f bs = L.fromChunks [bs]
|
|
|
|
getShortByteString :: Int -> Get BS.ShortByteString
|
|
getShortByteString n = do
|
|
bs <- getBytes n
|
|
return $! BS.toShort bs
|
|
|
|
|
|
------------------------------------------------------------------------
|
|
-- Helpers
|
|
|
|
-- | Pull @n@ bytes from the input, as a strict ByteString.
|
|
getBytes :: Int -> Get B.ByteString
|
|
getBytes n | n < 0 = fail "getBytes: negative length requested"
|
|
getBytes n = do
|
|
s <- ensure n
|
|
let consume = B.unsafeTake n s
|
|
rest = B.unsafeDrop n s
|
|
-- (consume,rest) = B.splitAt n s
|
|
cur <- bytesRead
|
|
put rest (cur + n)
|
|
return consume
|
|
{-# INLINE getBytes #-}
|
|
|
|
|
|
|
|
------------------------------------------------------------------------
|
|
-- Primtives
|
|
|
|
-- helper, get a raw Ptr onto a strict ByteString copied out of the
|
|
-- underlying strict byteString.
|
|
|
|
getPtr :: Storable a => Int -> Get a
|
|
getPtr n = do
|
|
(fp,o,_) <- B.toForeignPtr `fmap` getBytes n
|
|
let k p = peek (castPtr (p `plusPtr` o))
|
|
return (unsafeDupablePerformIO (withForeignPtr fp k))
|
|
{-# INLINE getPtr #-}
|
|
|
|
-----------------------------------------------------------------------
|
|
|
|
-- | Read a Int8 from the monad state
|
|
getInt8 :: Get Int8
|
|
getInt8 = do
|
|
s <- getBytes 1
|
|
return $! fromIntegral (B.unsafeHead s)
|
|
|
|
-- | Read a Int16 in big endian format
|
|
getInt16be :: Get Int16
|
|
getInt16be = do
|
|
s <- getBytes 2
|
|
return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftL` 8) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 1) )
|
|
|
|
-- | Read a Int16 in little endian format
|
|
getInt16le :: Get Int16
|
|
getInt16le = do
|
|
s <- getBytes 2
|
|
return $! (fromIntegral (s `B.unsafeIndex` 1) `shiftL` 8) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 0) )
|
|
|
|
-- | Read a Int32 in big endian format
|
|
getInt32be :: Get Int32
|
|
getInt32be = do
|
|
s <- getBytes 4
|
|
return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftL` 24) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 1) `shiftL` 16) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 2) `shiftL` 8) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 3) )
|
|
|
|
-- | Read a Int32 in little endian format
|
|
getInt32le :: Get Int32
|
|
getInt32le = do
|
|
s <- getBytes 4
|
|
return $! (fromIntegral (s `B.unsafeIndex` 3) `shiftL` 24) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 2) `shiftL` 16) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 1) `shiftL` 8) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 0) )
|
|
|
|
-- | Read a Int64 in big endian format
|
|
getInt64be :: Get Int64
|
|
getInt64be = do
|
|
s <- getBytes 8
|
|
return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftL` 56) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 1) `shiftL` 48) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 2) `shiftL` 40) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 3) `shiftL` 32) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 4) `shiftL` 24) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 5) `shiftL` 16) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 6) `shiftL` 8) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 7) )
|
|
|
|
-- | Read a Int64 in little endian format
|
|
getInt64le :: Get Int64
|
|
getInt64le = do
|
|
s <- getBytes 8
|
|
return $! (fromIntegral (s `B.unsafeIndex` 7) `shiftL` 56) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 6) `shiftL` 48) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 5) `shiftL` 40) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 4) `shiftL` 32) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 3) `shiftL` 24) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 2) `shiftL` 16) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 1) `shiftL` 8) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 0) )
|
|
|
|
{-# INLINE getInt8 #-}
|
|
{-# INLINE getInt16be #-}
|
|
{-# INLINE getInt16le #-}
|
|
{-# INLINE getInt32be #-}
|
|
{-# INLINE getInt32le #-}
|
|
{-# INLINE getInt64be #-}
|
|
{-# INLINE getInt64le #-}
|
|
|
|
------------------------------------------------------------------------
|
|
|
|
-- | Read a Word8 from the monad state
|
|
getWord8 :: Get Word8
|
|
getWord8 = do
|
|
s <- getBytes 1
|
|
return (B.unsafeHead s)
|
|
|
|
-- | Read a Word16 in big endian format
|
|
getWord16be :: Get Word16
|
|
getWord16be = do
|
|
s <- getBytes 2
|
|
return $! (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w16` 8) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 1))
|
|
|
|
-- | Read a Word16 in little endian format
|
|
getWord16le :: Get Word16
|
|
getWord16le = do
|
|
s <- getBytes 2
|
|
return $! (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w16` 8) .|.
|
|
(fromIntegral (s `B.unsafeIndex` 0) )
|
|
|
|
-- | Read a Word32 in big endian format
|
|
getWord32be :: Get Word32
|
|
getWord32be = do
|
|
s <- getBytes 4
|
|
return $! (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) )
|
|
|
|
-- | Read a Word32 in little endian format
|
|
getWord32le :: Get Word32
|
|
getWord32le = do
|
|
s <- getBytes 4
|
|
return $! (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) )
|
|
|
|
-- | Read a Word64 in big endian format
|
|
getWord64be :: Get Word64
|
|
getWord64be = do
|
|
s <- getBytes 8
|
|
return $! (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) )
|
|
|
|
-- | Read a Word64 in little endian format
|
|
getWord64le :: Get Word64
|
|
getWord64le = do
|
|
s <- getBytes 8
|
|
return $! (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 getWord8 #-}
|
|
{-# INLINE getWord16be #-}
|
|
{-# INLINE getWord16le #-}
|
|
{-# INLINE getWord32be #-}
|
|
{-# INLINE getWord32le #-}
|
|
{-# INLINE getWord64be #-}
|
|
{-# INLINE getWord64le #-}
|
|
|
|
------------------------------------------------------------------------
|
|
-- Host-endian reads
|
|
|
|
-- | /O(1)./ Read a single native machine word. The word is read in
|
|
-- host order, host endian form, for the machine you're on. On a 64 bit
|
|
-- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes.
|
|
getWordhost :: Get Word
|
|
getWordhost = getPtr (sizeOf (undefined :: Word))
|
|
|
|
-- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness.
|
|
getWord16host :: Get Word16
|
|
getWord16host = getPtr (sizeOf (undefined :: Word16))
|
|
|
|
-- | /O(1)./ Read a Word32 in native host order and host endianness.
|
|
getWord32host :: Get Word32
|
|
getWord32host = getPtr (sizeOf (undefined :: Word32))
|
|
|
|
-- | /O(1)./ Read a Word64 in native host order and host endianness.
|
|
getWord64host :: Get Word64
|
|
getWord64host = getPtr (sizeOf (undefined :: Word64))
|
|
|
|
------------------------------------------------------------------------
|
|
-- Unchecked shifts
|
|
|
|
shiftl_w16 :: Word16 -> Int -> Word16
|
|
shiftl_w32 :: Word32 -> Int -> Word32
|
|
shiftl_w64 :: Word64 -> Int -> Word64
|
|
|
|
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
|
|
#if MIN_VERSION_base(4,16,0)
|
|
shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftLWord16#` i)
|
|
shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftLWord32#` i)
|
|
#else
|
|
shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)
|
|
shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)
|
|
#endif
|
|
|
|
#if WORD_SIZE_IN_BITS < 64
|
|
shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
|
|
|
|
#if __GLASGOW_HASKELL__ <= 606
|
|
-- Exported by GHC.Word in GHC 6.8 and higher
|
|
foreign import ccall unsafe "stg_uncheckedShiftL64"
|
|
uncheckedShiftL64# :: Word64# -> Int# -> Word64#
|
|
#endif
|
|
|
|
#else
|
|
#if MIN_VERSION_base(4,17,0)
|
|
shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
|
|
#else
|
|
shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
|
|
#endif
|
|
#endif
|
|
|
|
#else
|
|
shiftl_w16 = shiftL
|
|
shiftl_w32 = shiftL
|
|
shiftl_w64 = shiftL
|
|
#endif
|
|
|
|
|
|
-- Containers ------------------------------------------------------------------
|
|
|
|
getTwoOf :: Get a -> Get b -> Get (a,b)
|
|
getTwoOf ma mb = M.liftM2 (,) ma mb
|
|
|
|
-- | Get a list in the following format:
|
|
-- Word64 (big endian format)
|
|
-- element 1
|
|
-- ...
|
|
-- element n
|
|
getListOf :: Get a -> Get [a]
|
|
getListOf m = go [] =<< getWord64be
|
|
where
|
|
go as 0 = return $! reverse as
|
|
go as i = do x <- m
|
|
x `seq` go (x:as) (i - 1)
|
|
|
|
-- | Get an IArray in the following format:
|
|
-- index (lower bound)
|
|
-- index (upper bound)
|
|
-- Word64 (big endian format)
|
|
-- element 1
|
|
-- ...
|
|
-- element n
|
|
getIArrayOf :: (Ix i, IArray a e) => Get i -> Get e -> Get (a i e)
|
|
getIArrayOf ix e = M.liftM2 listArray (getTwoOf ix ix) (getListOf e)
|
|
|
|
-- | Get a sequence in the following format:
|
|
-- Word64 (big endian format)
|
|
-- element 1
|
|
-- ...
|
|
-- element n
|
|
getSeqOf :: Get a -> Get (Seq.Seq a)
|
|
getSeqOf m = go Seq.empty =<< getWord64be
|
|
where
|
|
go xs 0 = return $! xs
|
|
go xs n = xs `seq` n `seq` do
|
|
x <- m
|
|
go (xs Seq.|> x) (n - 1)
|
|
|
|
-- | Read as a list of lists.
|
|
getTreeOf :: Get a -> Get (T.Tree a)
|
|
getTreeOf m = M.liftM2 T.Node m (getListOf (getTreeOf m))
|
|
|
|
-- | Read as a list of pairs of key and element.
|
|
getMapOf :: Ord k => Get k -> Get a -> Get (Map.Map k a)
|
|
getMapOf k m = Map.fromList `fmap` getListOf (getTwoOf k m)
|
|
|
|
-- | Read as a list of pairs of int and element.
|
|
getIntMapOf :: Get Int -> Get a -> Get (IntMap.IntMap a)
|
|
getIntMapOf i m = IntMap.fromList `fmap` getListOf (getTwoOf i m)
|
|
|
|
-- | Read as a list of elements.
|
|
getSetOf :: Ord a => Get a -> Get (Set.Set a)
|
|
getSetOf m = Set.fromList `fmap` getListOf m
|
|
|
|
-- | Read as a list of ints.
|
|
getIntSetOf :: Get Int -> Get IntSet.IntSet
|
|
getIntSetOf m = IntSet.fromList `fmap` getListOf m
|
|
|
|
-- | Read in a Maybe in the following format:
|
|
-- Word8 (0 for Nothing, anything else for Just)
|
|
-- element (when Just)
|
|
getMaybeOf :: Get a -> Get (Maybe a)
|
|
getMaybeOf m = do
|
|
tag <- getWord8
|
|
case tag of
|
|
0 -> return Nothing
|
|
_ -> Just `fmap` m
|
|
|
|
-- | Read an Either, in the following format:
|
|
-- Word8 (0 for Left, anything else for Right)
|
|
-- element a when 0, element b otherwise
|
|
getEitherOf :: Get a -> Get b -> Get (Either a b)
|
|
getEitherOf ma mb = do
|
|
tag <- getWord8
|
|
case tag of
|
|
0 -> Left `fmap` ma
|
|
_ -> Right `fmap` mb
|
|
|
|
-- | Read in a length and then read a nested structure
|
|
-- of that length.
|
|
getNested :: Get Int -> Get a -> Get a
|
|
getNested getLen getVal = do
|
|
n <- getLen
|
|
isolate n getVal
|
|
|
|
-- | Get the number of bytes read up to this point
|
|
bytesRead :: Get Int
|
|
bytesRead = Get (\i b m w _ k -> k i b m w w)
|