Data/Serialize/Get.hs

{-# 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. Additional to the result of get it returns the number of
-- consumed bytes and 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. Additional to the result of get it returns the number of
-- consumed bytes and 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__)
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)

#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
shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
#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)