#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
#include "MachDeps.h"
#endif
module Data.Binary.Strict.Get (
Get
, runGet
, lookAhead
, lookAheadM
, lookAheadE
, skip
, bytesRead
, remaining
, isEmpty
, getWord8
, getByteString
, getWord16be
, getWord32be
, getWord64be
, getWord16le
, getWord32le
, getWord64le
, getWordhost
, getWord16host
, getWord32host
, getWord64host
) where
import Control.Monad (when)
import Data.Maybe (isNothing)
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as B
import Foreign
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
import GHC.Base
import GHC.Word
#endif
data S = S !B.ByteString
!Int
newtype Get a = Get { unGet :: S -> (Either String a, S) }
instance Functor Get where
fmap f m = Get (\s -> case unGet m s of
(Right a, s') -> (Right $ f a, s')
(Left err, s') -> (Left err, s'))
instance Monad Get where
return a = Get (\s -> (Right a, s))
m >>= k = Get (\s -> case unGet m s of
(Left err, s') -> (Left err, s')
(Right a, s') -> unGet (k a) s')
fail err = Get (\s -> (Left err, s))
get :: Get S
get = Get (\s -> (Right s, s))
put :: S -> Get ()
put s = Get (const (Right (), s))
initState :: B.ByteString -> S
initState input = S input 0
runGet :: Get a -> B.ByteString -> (Either String a, B.ByteString)
runGet m input =
case unGet m (initState input) of
(a, ~(S _ offset)) -> (a, B.drop offset input)
skip :: Int -> Get ()
skip n = readN (fromIntegral n) (const ())
lookAhead :: Get a -> Get a
lookAhead ga = do
s <- get
a <- ga
put s
return a
lookAheadM :: Get (Maybe a) -> Get (Maybe a)
lookAheadM gma = do
s <- get
ma <- gma
when (isNothing ma) $
put s
return ma
lookAheadE :: Get (Either a b) -> Get (Either a b)
lookAheadE gea = do
s <- get
ea <- gea
case ea of
Left _ -> put s
_ -> return ()
return ea
bytesRead :: Get Int
bytesRead = do
S _ b <- get
return b
remaining :: Get Int
remaining = do
S s _ <- get
return (fromIntegral (B.length s))
isEmpty :: Get Bool
isEmpty = do
S s _ <- get
return $ B.null s
getByteString :: Int -> Get B.ByteString
getByteString n = readN n id
getBytes :: Int -> Get B.ByteString
getBytes n = do
S s offset <- get
if n <= B.length s
then do let (consume, rest) = B.splitAt n s
put $! S rest (offset + fromIntegral n)
return $! consume
else fail "too few bytes"
readN :: Int -> (B.ByteString -> a) -> Get a
readN n f = fmap f $ getBytes n
getPtr :: Storable a => Int -> Get a
getPtr n = do
(fp, o, _) <- readN n B.toForeignPtr
return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
getWord8 :: Get Word8
getWord8 = getPtr (sizeOf (undefined :: Word8))
getWord16be :: Get Word16
getWord16be = do
s <- readN 2 id
return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|.
(fromIntegral (s `B.index` 1))
getWord16le :: Get Word16
getWord16le = do
s <- readN 2 id
return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|.
(fromIntegral (s `B.index` 0) )
getWord32be :: Get Word32
getWord32be = do
s <- readN 4 id
return $! (fromIntegral (s `B.index` 0) `shiftl_w32` 24) .|.
(fromIntegral (s `B.index` 1) `shiftl_w32` 16) .|.
(fromIntegral (s `B.index` 2) `shiftl_w32` 8) .|.
(fromIntegral (s `B.index` 3) )
getWord32le :: Get Word32
getWord32le = do
s <- readN 4 id
return $! (fromIntegral (s `B.index` 3) `shiftl_w32` 24) .|.
(fromIntegral (s `B.index` 2) `shiftl_w32` 16) .|.
(fromIntegral (s `B.index` 1) `shiftl_w32` 8) .|.
(fromIntegral (s `B.index` 0) )
getWord64be :: Get Word64
getWord64be = do
s <- readN 8 id
return $! (fromIntegral (s `B.index` 0) `shiftl_w64` 56) .|.
(fromIntegral (s `B.index` 1) `shiftl_w64` 48) .|.
(fromIntegral (s `B.index` 2) `shiftl_w64` 40) .|.
(fromIntegral (s `B.index` 3) `shiftl_w64` 32) .|.
(fromIntegral (s `B.index` 4) `shiftl_w64` 24) .|.
(fromIntegral (s `B.index` 5) `shiftl_w64` 16) .|.
(fromIntegral (s `B.index` 6) `shiftl_w64` 8) .|.
(fromIntegral (s `B.index` 7) )
getWord64le :: Get Word64
getWord64le = do
s <- readN 8 id
return $! (fromIntegral (s `B.index` 7) `shiftl_w64` 56) .|.
(fromIntegral (s `B.index` 6) `shiftl_w64` 48) .|.
(fromIntegral (s `B.index` 5) `shiftl_w64` 40) .|.
(fromIntegral (s `B.index` 4) `shiftl_w64` 32) .|.
(fromIntegral (s `B.index` 3) `shiftl_w64` 24) .|.
(fromIntegral (s `B.index` 2) `shiftl_w64` 16) .|.
(fromIntegral (s `B.index` 1) `shiftl_w64` 8) .|.
(fromIntegral (s `B.index` 0) )
getWordhost :: Get Word
getWordhost = getPtr (sizeOf (undefined :: Word))
getWord16host :: Get Word16
getWord16host = getPtr (sizeOf (undefined :: Word16))
getWord32host :: Get Word32
getWord32host = getPtr (sizeOf (undefined :: Word32))
getWord64host :: Get Word64
getWord64host = getPtr (sizeOf (undefined :: Word64))
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