{-# LANGUAGE CPP,MagicHash,ScopedTypeVariables,FlexibleInstances,RankNTypes #-} -- | By Chris Kuklewicz, drawing heavily from binary and binary-strict, -- but all the bugs are my own. -- -- This file is under the usual BSD3 licence, copyright 2008. -- -- This started out as an improvement to -- "Data.Binary.Strict.IncrementalGet" with slightly better internals. -- The simplified 'Get', 'runGet', 'Result' trio with the -- "Data.Binary.Strict.Class.BinaryParser" instance are an _untested_ -- upgrade from IncrementalGet. Especially untested are the -- strictness properties. -- -- 'Get' usefully implements Applicative and Monad, MonadError, -- Alternative and MonadPlus. Unhandled errors are reported along -- with the number of bytes successfully consumed. Effects of -- 'suspend' and 'putAvailable' are visible after -- fail/throwError/mzero. -- -- Each time the parser reaches the end of the input it will return a -- Partial wrapped continuation which requests a (Maybe -- Lazy.ByteString). Passing (Just bs) will append bs to the input so -- far and continue processing. If you pass Nothing to the -- continuation then you are declaring that there will never be more -- input and that the parser should never again return a partial -- contination; it should return failure or finished. -- -- 'suspendUntilComplete' repeatedly uses a partial continuation to -- ask for more input until Nothing is passed and then it proceeds -- with parsing. -- -- The 'getAvailable' command returns the lazy byte string the parser -- has remaining before calling 'suspend'. The 'putAvailable' -- replaces this input and is a bit fancy: it also replaces the input -- at the current offset for all the potential catchError/mplus -- handlers. This change is _not_ reverted by fail/throwError/mzero. -- -- The three 'lookAhead' and 'lookAheadM' and 'lookAheadE' functions are -- very similar to the ones in binary's Data.Binary.Get. -- module Text.ProtocolBuffers.Get (Get,runGet,Result(..) -- main primitives ,ensureBytes,getStorable,getLazyByteString,suspendUntilComplete -- parser state manipulation ,getAvailable,putAvailable -- lookAhead capabilities ,lookAhead,lookAheadM,lookAheadE -- below is for implementation of BinaryParser (for Int64 and Lazy bytestrings) ,skip,bytesRead,isEmpty,isReallyEmpty,remaining,spanOf ,getWord8,getByteString ,getWord16be,getWord32be,getWord64be ,getWord16le,getWord32le,getWord64le ,getWordhost,getWord16host,getWord32host,getWord64host ) where -- The Get monad is an instance of binary-strict's BinaryParser: -- import qualified Data.Binary.Strict.Class as P(BinaryParser(..)) -- The Get monad is an instance of all of these library classes: import Control.Applicative(Applicative(pure,(<*>)),Alternative(empty,(<|>))) import Control.Monad(MonadPlus(mzero,mplus)) import Control.Monad.Error.Class(MonadError(throwError,catchError),Error(strMsg)) -- It can be a MonadCont, but the semantics are too broken without a ton of work. -- implementation imports import Control.Monad(ap) -- instead of Functor.fmap; ap for Applicative --import Control.Monad(replicateM,(>=>)) -- XXX testing import Data.Bits(Bits((.|.))) import qualified Data.ByteString as S(concat,length,null,splitAt) --import qualified Data.ByteString as S(unpack) -- XXX testing import qualified Data.ByteString.Internal as S(ByteString,toForeignPtr,inlinePerformIO) import qualified Data.ByteString.Unsafe as S(unsafeIndex) import qualified Data.ByteString.Lazy as L(take,drop,length,span,toChunks,fromChunks,null) --import qualified Data.ByteString.Lazy as L(pack) -- XXX testing import qualified Data.ByteString.Lazy.Internal as L(ByteString(..),chunk) import qualified Data.Foldable as F(foldr,foldr1) -- used with Seq import Data.Int(Int64) -- index type for L.ByteString import Data.Monoid(Monoid(mempty,mappend)) -- Writer has a Monoid contraint import Data.Sequence(Seq,null,(|>)) -- used for future queue in handler state import Data.Word(Word,Word8,Word16,Word32,Word64) import Foreign.ForeignPtr(withForeignPtr) import Foreign.Ptr(castPtr,plusPtr) import Foreign.Storable(Storable(peek,sizeOf)) #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) import GHC.Base(Int(..),uncheckedShiftL#) import GHC.Word(Word16(..),Word32(..),Word64(..),uncheckedShiftL64#) #endif -- Simple external return type data Result a = Failed {-# UNPACK #-} !Int64 String | Finished {-# UNPACK #-} !L.ByteString {-# UNPACK #-} !Int64 a | Partial (Maybe L.ByteString -> Result a) -- Internal state type, not exposed to the user. data S = S { top :: {-# UNPACK #-} !S.ByteString , current :: {-# UNPACK #-} !L.ByteString , consumed :: {-# UNPACK #-} !Int64 } deriving Show -- Private Internal error handling stack type -- This must NOT be exposed by this module -- -- The ErrorFrame is the top-level error handler setup when execution begins. -- It starts with the Bool set to True: meaning suspend can ask for more input. -- Once suspend get 'Nothing' in reply the Bool is set to False, which means -- that 'suspend' should no longer ask for input -- the input is finished. -- Why store the Bool there? It was handy when I needed to add it. data FrameStack b = ErrorFrame (String -> S -> Result b) -- top level handler Bool -- True at start, False if Nothing passed to suspend continuation | HandlerFrame (Maybe ( S -> FrameStack b -> String -> Result b )) -- encapsulated handler S -- stored state to pass to handler (Seq L.ByteString) -- additional input to hass to handler (FrameStack b) -- earlier/deeper/outer handlers type Success b a = (a -> S -> FrameStack b -> Result b) -- Internal monad type newtype Get a = Get { unGet :: forall b. -- the forall hides the CPS style (and prevents use of MonadCont) Success b a -- main continuation -> S -- parser state -> FrameStack b -- error handler stack -> Result b -- operation } -- These implement the checkponting needed to store and revive the -- state for lookAhead. They are fragile because the setCheckpoint -- must preceed either useCheckpoint or clearCheckpoint but not both. -- The FutureFrame must be the most recent handler, so the commands -- must be in the same scope depth. Because of these constraints, the reader -- value 'r' does not need to be stored and can be taken from the Get -- parameter. -- -- IMPORTANT: Any FutureFrame at the top level(s) is discarded by throwError. setCheckpoint,useCheckpoint,clearCheckpoint :: Get () setCheckpoint = Get $ \ sc s pc -> sc () s (HandlerFrame Nothing s mempty pc) useCheckpoint = Get $ \ sc (S _ _ _) (HandlerFrame Nothing s future pc) -> let (S {top=ss, current=bs, consumed=n}) = collect s future in sc () (S ss bs n) pc clearCheckpoint = Get $ \ sc s (HandlerFrame Nothing _s _future pc) -> sc () s pc -- | 'lookAhead' runs the @todo@ action and then rewinds only the -- BinaryParser state. Any new input from 'suspend' or changes from -- 'putAvailable' are kept. Changes to the user state (MonadState) -- are kept. The MonadWriter output is retained. -- -- If an error is thrown then the entire monad state is reset to last -- catchError as usual. lookAhead :: Get a -> Get a lookAhead todo = do setCheckpoint a <- todo useCheckpoint return a -- | 'lookAheadM' runs the @todo@ action. If the action returns 'Nothing' then the -- BinaryParser state is rewound (as in 'lookAhead'). If the action return 'Just' then -- the BinaryParser is not rewound, and lookAheadM acts as an identity. -- -- If an error is thrown then the entire monad state is reset to last -- catchError as usual. lookAheadM :: Get (Maybe a) -> Get (Maybe a) lookAheadM todo = do setCheckpoint a <- todo maybe useCheckpoint (\_ -> clearCheckpoint) a return a -- | 'lookAheadE' runs the @todo@ action. If the action returns 'Left' then the -- BinaryParser state is rewound (as in 'lookAhead'). If the action return 'Right' then -- the BinaryParser is not rewound, and lookAheadE acts as an identity. -- -- If an error is thrown then the entire monad state is reset to last -- catchError as usual. lookAheadE :: Get (Either a b) -> Get (Either a b) lookAheadE todo = do setCheckpoint a <- todo either (\_ -> useCheckpoint) (\_ -> clearCheckpoint) a return a -- 'collect' is used by 'putCheckpoint' and 'throwError' collect :: S -> Seq L.ByteString -> S collect s@(S ss bs n) future | Data.Sequence.null future = s | otherwise = S ss (mappend bs (F.foldr1 mappend future)) n -- Put the Show instances here instance (Show a) => Show (Result a) where showsPrec _ (Failed n msg) = ("(Failed "++) . shows n . (' ':) . shows msg . (")"++) showsPrec _ (Finished bs n a) = ("(CFinished ("++) . shows bs . (") ("++) . shows n . (") ("++) . shows a . ("))"++) showsPrec _ (Partial {}) = ("(Partial Result a)"++) instance Show (FrameStack b) where showsPrec _ (ErrorFrame _ p) =(++) "(ErrorFrame s->m b> " . shows p . (")"++) showsPrec _ (HandlerFrame _ s future pc) = ("(HandlerFrame <> ("++) . shows s . (") ("++) . shows future . (") ("++) . shows pc . (")"++) -- | 'runGet' is the simple executor runGet :: Get a -> L.ByteString -> Result a runGet (Get f) bsIn = f scIn sIn (ErrorFrame ec True) where scIn a (S ss bs n) _pc = Finished (L.chunk ss bs) n a sIn = case bsIn of L.Empty -> S mempty mempty 0 L.Chunk ss bs -> S ss bs 0 ec msg sOut = Failed (consumed sOut) msg -- | Get the input currently available to the parser. getAvailable :: Get L.ByteString getAvailable = Get $ \ sc s@(S ss bs _) pc -> sc (L.chunk ss bs) s pc -- | 'putAvailable' replaces the bytestream past the current # of read -- bytes. This will also affect pending MonadError handler and -- MonadPlus branches. I think all pending branches have to have -- fewer bytesRead than the current one. If this is wrong then an -- error will be thrown. -- -- WARNING : 'putAvailable' is still untested. putAvailable :: L.ByteString -> Get () putAvailable bsNew = Get $ \ sc (S _ss _bs n) pc -> let s' = case bsNew of L.Empty -> S mempty mempty n L.Chunk ss' bs' -> S ss' bs' n rebuild (HandlerFrame catcher (S ss1 bs1 n1) future pc') = HandlerFrame catcher sNew mempty (rebuild pc') where balance = n - n1 whole | balance < 0 = error "Impossible? Cannot rebuild HandlerFrame in MyGet.putAvailable: balance is negative!" | otherwise = L.take balance $ L.chunk ss1 bs1 `mappend` F.foldr mappend mempty future sNew | balance /= L.length whole = error "Impossible? MyGet.putAvailable.rebuild.sNew HandlerFrame assertion failed." | otherwise = case mappend whole bsNew of L.Empty -> S mempty mempty n1 L.Chunk ss2 bs2 -> S ss2 bs2 n1 rebuild x@(ErrorFrame {}) = x in sc () s' (rebuild pc) -- Internal access to full internal state, as helepr functions getFull :: Get S getFull = Get $ \ sc s pc -> sc s s pc putFull :: S -> Get () putFull s = Get $ \ sc _s pc -> sc () s pc -- | Keep calling 'suspend' until Nothing is passed to the 'Partial' -- continuation. This ensures all the data has been loaded into the -- state of the parser. suspendUntilComplete :: Get () suspendUntilComplete = do continue <- suspend if continue then suspendUntilComplete else return () -- | Call suspend and throw and error with the provided @msg@ if -- Nothing has been passed to the 'Partial' continuation. Otherwise -- return (). suspendMsg :: String -> Get () suspendMsg msg = do continue <- suspend if continue then return () else throwError msg -- | check that there are at least @n@ bytes available in the input. -- This will suspend if there is to little data. ensureBytes :: Int64 -> Get () ensureBytes n = do (S ss bs _read) <- getFull if n < fromIntegral (S.length ss) then return () else do if n == L.length (L.take n (L.chunk ss bs)) then return () else suspendMsg "ensureBytes failed" >> ensureBytes n {-# INLINE ensureBytes #-} -- | Pull @n@ bytes from the unput, as a lazy ByteString. This will -- suspend if there is too little data. getLazyByteString :: Int64 -> Get L.ByteString getLazyByteString n | n<=0 = return mempty | otherwise = do (S ss bs offset) <- getFull case splitAtOrDie n (L.chunk ss bs) of Just (consume,rest) ->do case rest of L.Empty -> putFull (S mempty mempty (offset + n)) L.Chunk ss' bs' -> putFull (S ss' bs' (offset + n)) return consume Nothing -> suspendMsg "getLazyByteString failed" >> getLazyByteString n {-# INLINE getLazyByteString #-} -- important -- | 'suspend' is supposed to allow the execution of the monad to be -- halted, awaiting more input. The computation is supposed to -- continue normally if this returns True, and is supposed to halt -- without calling suspend again if this returns False. All future -- calls to suspend will return False automatically and no nothing -- else. -- -- These semantics are too specialized to let this escape this module. class MonadSuspend m where suspend :: m Bool -- The instance here is fairly specific to the stack manipluation done -- by 'addFuture' to ('S' user) and to the packaging of the resumption -- function in 'IResult'('IPartial'). instance MonadSuspend Get where suspend = Get $ \ sc sIn pcIn -> if checkBool pcIn -- Has Nothing ever been given to a partial continuation? then let f Nothing = let pcOut = rememberFalse pcIn in sc False sIn pcOut f (Just bs') = let sOut = appendBS sIn bs' pcOut = addFuture bs' pcIn in sc True sOut pcOut in Partial f else sc False sIn pcIn -- once Nothing has been given suspend is a no-op where appendBS (S ss bs n) bs' = S ss (mappend bs bs') n -- addFuture puts the new data in 'future' where throwError's collect can find and use it addFuture bs (HandlerFrame catcher s future pc) = HandlerFrame catcher s (future |> bs) (addFuture bs pc) addFuture _bs x@(ErrorFrame {}) = x -- Once suspend is given Nothing, it remembers this and always returns False checkBool (ErrorFrame _ b) = b checkBool (HandlerFrame _ _ _ pc) = checkBool pc rememberFalse (ErrorFrame ec _) = ErrorFrame ec False rememberFalse (HandlerFrame catcher s future pc) = HandlerFrame catcher s future (rememberFalse pc) -- A unique sort of command... -- | 'discardInnerHandler' causes the most recent catchError to be -- discarded, i.e. this reduces the stack of error handlers by removing -- the top one. These are the same handlers which Alternative((<|>)) and -- MonadPlus(mplus) use. This is useful to commit to the current branch and let -- the garbage collector release the suspended handler and its hold on -- the earlier input. discardInnerHandler :: Get () discardInnerHandler = Get $ \ sc s pcIn -> let pcOut = case pcIn of ErrorFrame {} -> pcIn HandlerFrame _ _ _ pc' -> pc' in sc () s pcOut {-# INLINE discardInnerHandler #-} {- Currently unused, commented out to satisfy -Wall -- | 'discardAllHandlers' causes all catchError handler to be -- discarded, i.e. this reduces the stack of error handlers to the top -- level handler. These are the same handlers which Alternative((<|>)) -- and MonadPlus(mplus) use. This is useful to commit to the current -- branch and let the garbage collector release the suspended handlers -- and their hold on the earlier input. discardAllHandlers :: Get () discardAllHandlers = Get $ \ sc s pcIn -> let base pc@(ErrorFrame {}) = pc base (HandlerFrame _ _ _ pc) = base pc in sc () s (base pcIn) {-# INLINE discardAllHandlers #-} -} -- The BinaryParser instance: -- | Discard the next @m@ bytes skip :: Int64 -> Get () skip m | m <=0 = return () | otherwise = do ensureBytes m (S ss bs n) <- getFull case L.drop m (L.chunk ss bs) of L.Empty -> putFull (S mempty mempty (n+m)) L.Chunk ss' bs' -> putFull (S ss' bs' (n+m)) -- | Return the number of 'bytesRead' so far. Initially 0, never negative. bytesRead :: Get Int64 bytesRead = fmap consumed getFull -- | Return the number of bytes 'remaining' before the current input -- runs out and 'suspend' might be called. remaining :: Get Int64 remaining = do (S ss bs _) <- getFull return $ fromIntegral (S.length ss) + (L.length bs) -- | Return True if the number of bytes 'remaining' is 0. Any futher -- attempts to read an empty parser will call 'suspend' which might -- result in more input to consume. -- -- Compare with 'isReallyEmpty' isEmpty :: Get Bool isEmpty = do (S ss bs _n) <- getFull return $ (S.null ss) && (L.null bs) -- | Return True if the input is exhausted and will never be added to. -- Returns False if there is input left to consume. -- -- Compare with 'isEmpty' isReallyEmpty :: Get Bool isReallyEmpty = do b <- isEmpty if not b then return b else loop where loop = do continue <- suspend b <- isEmpty if not b then return b else if continue then loop else return False spanOf :: (Word8 -> Bool) -> Get (L.ByteString) spanOf f = do let loop = do (S ss bs n) <- getFull let (pre,post) = L.span f (L.chunk ss bs) case post of L.Empty -> putFull (S mempty mempty (n + L.length pre)) L.Chunk ss' bs' -> putFull (S ss' bs' (n + L.length pre)) if L.null post then fmap ((L.toChunks pre)++) $ do continue <- suspend if continue then loop else return (L.toChunks pre) else return (L.toChunks pre) fmap L.fromChunks loop {-# INLINE spanOf #-} -- | Pull @n@ bytes from the input, as a strict ByteString. This will -- suspend if there is too little data. If the result spans multiple -- lazy chunks then the result occupies a freshly allocated strict -- bytestring, otherwise it fits in a single chunk and refers to the -- same immutable memory block as the whole chunk. getByteString :: Int -> Get S.ByteString getByteString nIn | nIn <= 0 = return mempty | otherwise = do (S ss bs n) <- getFull if nIn < S.length ss then do let (pre,post) = S.splitAt nIn ss putFull (S post bs (n+fromIntegral nIn)) return pre -- Expect nIn to be less than S.length ss the vast majority of times -- so do not worry about doing anything fancy here. else fmap (S.concat . L.toChunks) (getLazyByteString (fromIntegral nIn)) {-# INLINE getByteString #-} -- important getWordhost :: Get Word getWordhost = getStorable {-# INLINE getWordhost #-} getWord8 :: Get Word8 getWord8 = getPtr 1 {-# INLINE getWord8 #-} getWord16be,getWord16le,getWord16host :: Get Word16 getWord16be = do s <- getByteString 2 return $! (fromIntegral (s `S.unsafeIndex` 0) `shiftl_w16` 8) .|. (fromIntegral (s `S.unsafeIndex` 1)) {-# INLINE getWord16be #-} getWord16le = do s <- getByteString 2 return $! (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w16` 8) .|. (fromIntegral (s `S.unsafeIndex` 0) ) {-# INLINE getWord16le #-} getWord16host = getStorable {-# INLINE getWord16host #-} getWord32be,getWord32le,getWord32host :: Get Word32 getWord32be = do s <- getByteString 4 return $! (fromIntegral (s `S.unsafeIndex` 0) `shiftl_w32` 24) .|. (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w32` 16) .|. (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w32` 8) .|. (fromIntegral (s `S.unsafeIndex` 3) ) {-# INLINE getWord32be #-} getWord32le = do s <- getByteString 4 return $! (fromIntegral (s `S.unsafeIndex` 3) `shiftl_w32` 24) .|. (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w32` 16) .|. (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w32` 8) .|. (fromIntegral (s `S.unsafeIndex` 0) ) {-# INLINE getWord32le #-} getWord32host = getStorable {-# INLINE getWord32host #-} getWord64be,getWord64le,getWord64host :: Get Word64 getWord64be = do s <- getByteString 8 return $! (fromIntegral (s `S.unsafeIndex` 0) `shiftl_w64` 56) .|. (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w64` 48) .|. (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w64` 40) .|. (fromIntegral (s `S.unsafeIndex` 3) `shiftl_w64` 32) .|. (fromIntegral (s `S.unsafeIndex` 4) `shiftl_w64` 24) .|. (fromIntegral (s `S.unsafeIndex` 5) `shiftl_w64` 16) .|. (fromIntegral (s `S.unsafeIndex` 6) `shiftl_w64` 8) .|. (fromIntegral (s `S.unsafeIndex` 7) ) {-# INLINE getWord64be #-} getWord64le = do s <- getByteString 8 return $! (fromIntegral (s `S.unsafeIndex` 7) `shiftl_w64` 56) .|. (fromIntegral (s `S.unsafeIndex` 6) `shiftl_w64` 48) .|. (fromIntegral (s `S.unsafeIndex` 5) `shiftl_w64` 40) .|. (fromIntegral (s `S.unsafeIndex` 4) `shiftl_w64` 32) .|. (fromIntegral (s `S.unsafeIndex` 3) `shiftl_w64` 24) .|. (fromIntegral (s `S.unsafeIndex` 2) `shiftl_w64` 16) .|. (fromIntegral (s `S.unsafeIndex` 1) `shiftl_w64` 8) .|. (fromIntegral (s `S.unsafeIndex` 0) ) {-# INLINE getWord64le #-} getWord64host = getStorable {-# INLINE getWord64host #-} {- -- I no longer include the binary-strict package, but if one wants it -- here is the instance: instance P.BinaryParser Get where skip = skip . fromIntegral bytesRead = fmap fromIntegral bytesRead remaining = fmap fromIntegral remaining isEmpty = isEmpty spanOf = fmap (S.concat . L.toChunks) . spanOf getByteString = getByteString getWordhost = getWordhost getWord8 = getWord8 getWord16be = getWord16be getWord32be = getWord32be getWord64be = getWord64be getWord16le = getWord16le getWord32le = getWord32le getWord64le = getWord64le getWord16host = getWord16host getWord32host = getWord32host getWord64host = getWord64host -} -- Below here are the class instances instance Functor Get where fmap f m = Get (\sc -> unGet m (sc . f)) {-# INLINE fmap #-} instance Monad Get where return a = Get (\sc -> sc a) {-# INLINE return #-} m >>= k = Get (\sc -> unGet m (\a -> unGet (k a) sc)) {-# INLINE (>>=) #-} fail msg = throwError (strMsg msg) instance MonadError String Get where throwError msg = Get $ \_sc s pcIn -> let go (ErrorFrame ec _) = ec msg s go (HandlerFrame (Just catcher) s1 future pc1) = catcher (collect s1 future) pc1 msg go (HandlerFrame Nothing _s1 _future pc1) = go pc1 in go pcIn catchError mayFail handler = Get $ \sc s pc -> let pcWithHandler = let catcher s1 pc1 e1 = unGet (handler e1) sc s1 pc1 in HandlerFrame (Just catcher) s mempty pc actionWithCleanup = mayFail >>= \a -> discardInnerHandler >> return a in unGet actionWithCleanup sc s pcWithHandler instance MonadPlus Get where mzero = throwError (strMsg "[mzero:no message]") mplus m1 m2 = catchError m1 (const m2) instance Applicative Get where pure = return (<*>) = ap instance Alternative Get where empty = mzero (<|>) = mplus -- | I use "splitAt" without tolerating too few bytes, so write a Maybe version. -- This is the only place I invoke L.Chunk as constructor instead of pattern matching. -- I claim that the first argument cannot be empty. splitAtOrDie :: Int64 -> L.ByteString -> Maybe (L.ByteString, L.ByteString) splitAtOrDie i ps | i <= 0 = Just (L.Empty, ps) splitAtOrDie _i L.Empty = Nothing splitAtOrDie i (L.Chunk x xs) | i < len = let (pre,post) = S.splitAt (fromIntegral i) x in Just (L.Chunk pre L.Empty ,L.Chunk post xs) | otherwise = case splitAtOrDie (i-len) xs of Nothing -> Nothing Just (y1,y2) -> Just (L.Chunk x y1,y2) where len = fromIntegral (S.length x) {-# INLINE splitAtOrDie #-} ------------------------------------------------------------------------ -- getPtr copied from binary's Get.hs -- helper, get a raw Ptr onto a strict ByteString copied out of the -- underlying lazy byteString. So many indirections from the raw parser -- state that my head hurts... getPtr :: (Storable a) => Int -> Get a getPtr n = do (fp,o,_) <- fmap S.toForeignPtr (getByteString n) return . S.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o) {-# INLINE getPtr #-} -- I pushed the sizeOf into here (uses ScopedTypeVariables) getStorable :: forall a. (Storable a) => Get a getStorable = do (fp,o,_) <- fmap S.toForeignPtr (getByteString (sizeOf (undefined :: a))) return . S.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o) {-# INLINE getStorable #-} ------------------------------------------------------------------------ ------------------------------------------------------------------------ -- Unchecked shifts copied from binary's Get.hs 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