{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE Trustworthy #-} #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) #include "MachDeps.h" #endif module Data.Tickle.Get( -- * Get data type Get -- ** Primitive parsers , getLazyByteString , getLazyByteStringNul , getRemainingLazyByteString , getPtr , getWord8 , getWord16be , getWord16le , getWord32be , getWord32le , getWord64be , getWord64le , getWordhost , getWord16host , getWord32host , getWord64host , failGet , constant , bytesRead , demandInput , skip , isNotEmpty , isEmpty , getByteString , modify , readN , ensureN -- ** Higher-level combinators , runAndKeepTrack , pushBack , pushFront , xrunGetIncremental , noMeansNo , prompt , isolate , lookAhead , lookAheadM , lookAheadE , readNWith , calculateOffset , pushChunk , pushChunks , pushEndOfInput -- ** Error label , (!+) , addLabel , (!-) , setLabel , (!!-) , modifyLabel -- * Decoder , Decoder , decoder , _Fail , _Partial , _Done -- ** Run Get parser , runGet , runGetIncremental -- * XDecoder data type , XDecoder -- ** Reduction , xdecoder -- ** Prisms , _XFail , _XPartial , _XDone , _XBytesRead -- * CompletedXDecoder data type , CompletedXDecoder -- ** Reduction , completedXDecoder -- ** Prism , _CompletedFail , _CompletedDone -- ** Isomorphism , completedIso -- ** Lens , completedByteString , completedValue -- ** Prism , uncomplete -- ** Traversal , uncompletedByteString , uncompletedValue ) where import Control.Applicative(Applicative((<*>), pure), (<$>)) import Control.Category(Category((.), id)) import Control.Lens.Iso(iso) import Control.Lens.Lens(lens) import Control.Lens.Prism(prism') import Control.Lens.Review((#)) import Control.Lens.Type(Iso, Prism', Lens', Traversal') import Control.Monad(Monad((>>=), (>>), return), ap) import Data.Bifoldable(Bifoldable(bifoldMap)) import Data.Bifunctor(Bifunctor(bimap)) import Data.Bitraversable(Bitraversable(bitraverse)) import Data.Bits((.|.)) import Data.Bool(Bool(False, True), (&&), not) import qualified Data.ByteString as B(ByteString, concat, append, length, splitAt, empty, null, break, drop) import qualified Data.ByteString.Internal as BI import qualified Data.ByteString.Lazy as L(ByteString, toChunks, fromChunks) import qualified Data.ByteString.Lazy.Internal as LI(ByteString(Chunk, Empty)) import qualified Data.ByteString.Unsafe as BU(unsafeDrop, unsafeTake, unsafeHead, unsafeIndex, unsafeUseAsCString) import Data.Either(Either(Left, Right), either) import Data.Eq(Eq((==))) import Data.Foldable(Foldable(foldMap)) import Data.Function(const) import Data.Functor(Functor(fmap)) import Data.Functor.Apply(Apply((<.>))) import Data.Functor.Alt(Alt(())) import qualified Data.Functor.Alt as Al(Alt(some, many)) import Data.Functor.Bind(Bind((>>-))) import Data.Int(Int, Int64) import Data.List(reverse) import Data.Maybe(Maybe(Nothing, Just), maybe, isJust) import Data.Monoid(Monoid(mempty)) import Data.Ord(Ord((>), (>=), (<), (>=))) import Data.Semigroup(Semigroup((<>))) import Data.Tickle.IsolateError(IsolateError, _NegativeSize, _IsolateXFail, _UnexpectedConsumed) import Data.Tickle.RunGetResult(RunGetResult, _RunGet, _RunGetFail) import Data.Traversable(Traversable(traverse)) import Data.Tuple(uncurry) import Foreign(Ptr, castPtr, Storable(peek), sizeOf) #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) import GHC.Word(Word, Word8, Word16(W16#), Word32(W32#), Word64(W64#)) import GHC.Base(uncheckedShiftL#, Int(I#)) #endif import Prelude(Num((-), (+)), ($!), Show, fromIntegral, undefined) import System.IO(IO) -- $setup -- >>> import Control.Lens.Fold((^?)) -- >>> import Control.Lens.Prism(_Right, _Left) -- >>> import qualified Data.ByteString.Lazy.Char8 as BLC(pack) -- >>> import qualified Data.ByteString.Char8 as BC(ByteString, pack) -- >>> import Data.String(String) -- >>> import Data.List((++)) -- >>> import Data.Maybe(fromMaybe, isNothing) -- >>> import Data.Validation(_Success, _Failure) -- >>> import Prelude(Num((*)), subtract, even, mod) newtype Get e a = Get (forall r. B.ByteString -> (B.ByteString -> a -> XDecoder e r) -> XDecoder e r) bimapG :: (e -> f) -> (a -> b) -> Get e a -> Get f b bimapG f g (Get z) = Get (\b q -> let r = z b XDone go (XDone i a) = q i (g a) go (XPartial k) = XPartial (go . k) go (XFail i s) = XFail i (f s) go (XBytesRead u k) = XBytesRead u (go . k) in go r) {-# INLINE bimapG #-} -- | Map on the error and result of a @Get@ decoder. -- -- >>> runGet (bimap (const True) (\x -> x + x) getWord8) (BLC.pack "") -- RunGetFail 0 True -- -- >>> runGet (bimap (const True) (\x -> x + x) getWord8) (BLC.pack "abc") -- RunGet 194 instance Bifunctor Get where bimap = bimapG fmapG :: (a -> b) -> Get e a -> Get e b fmapG = bimapG id {-# INLINE fmapG #-} -- | Map on the result of a @Get@ decoder. -- -- >>> runGet (fmap (\x -> x + x) getWord8) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet (fmap (\x -> x + x) getWord8) (BLC.pack "abc") -- RunGet 194 instance Functor (Get e) where fmap = fmapG -- | Apply a function on the @Get@ decoder result. -- -- >>> runGet (fmap (+) getWord8 <.> getWord8) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet (fmap (+) getWord8 <.> getWord8) (BLC.pack "a") -- RunGetFail 1 () -- -- >>> runGet (fmap (+) getWord8 <.> getWord8) (BLC.pack "ab") -- RunGet 195 -- -- >>> runGet (fmap (+) getWord8 <.> getWord8) (BLC.pack "abc") -- RunGet 195 instance Apply (Get e) where (<.>) = ap apG :: Get e (a -> b) -> Get e a -> Get e b apG d e = do b <- d a <- e return (b a) {-# INLINE [0] apG #-} -- | Apply a function on the @Get@ decoder result. -- -- >>> runGet (fmap (+) getWord8 <*> getWord8) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet (fmap (+) getWord8 <*> getWord8) (BLC.pack "a") -- RunGetFail 1 () -- -- >>> runGet (fmap (+) getWord8 <*> getWord8) (BLC.pack "ab") -- RunGet 195 -- -- >>> runGet (fmap (+) getWord8 <*> getWord8) (BLC.pack "abc") -- RunGet 195 -- -- >>> runGet (pure 7 :: Get () Int) (BLC.pack "abc") -- RunGet 7 -- -- prop> runGet (pure x :: Get () Int) (BLC.pack "abc") == _RunGet # x instance Applicative (Get e) where pure = return {-# INLINE pure #-} (<*>) = apG {-# INLINE (<*>) #-} -- | Sequence an action through the @Get@ decoder. -- -- >>> runGet (getWord8 >>- \c1 -> fmap (\c2 -> c1 + c2) getWord8) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet (getWord8 >>- \c1 -> fmap (\c2 -> c1 + c2) getWord8) (BLC.pack "a") -- RunGetFail 1 () -- -- >>> runGet (getWord8 >>- \c1 -> fmap (\c2 -> c1 + c2) getWord8) (BLC.pack "ab") -- RunGet 195 -- -- >>> runGet (getWord8 >>- \c1 -> fmap (\c2 -> c1 + c2) getWord8) (BLC.pack "abc") -- RunGet 195 instance Bind (Get e) where (>>-) = (>>=) returnG :: a -> Get e a returnG a = Get (\b q -> q b a) {-# INLINE [0] returnG #-} bindG :: Get e a -> (a -> Get e b) -> Get e b Get k `bindG` f = Get (\b q -> k b (\c a -> let Get l = f a in l c q)) {-# INLINE bindG #-} -- | Sequence an action through the @Get@ decoder. -- -- >>> runGet (return 7 :: Get () Int) (BLC.pack "abc") -- RunGet 7 -- -- prop> runGet (return x :: Get () Int) (BLC.pack "abc") == _RunGet # x -- -- >>> runGet (getWord8 >>= \c1 -> getWord8 >>= \c2 -> return (c1 + c2)) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet (getWord8 >>= \c1 -> getWord8 >>= \c2 -> return (c1 + c2)) (BLC.pack "a") -- RunGetFail 1 () -- -- >>> runGet (getWord8 >>= \c1 -> getWord8 >>= \c2 -> return (c1 + c2)) (BLC.pack "ab") -- RunGet 195 -- -- >>> runGet (getWord8 >>= \c1 -> getWord8 >>= \c2 -> return (c1 + c2)) (BLC.pack "abc") -- RunGet 195 instance Monad (Get e) where return = returnG (>>=) = bindG -- | Pick between two @Get@ decoders, finding the first to not fail. -- -- >>> runGet ((+1) <$> getWord8 subtract 1 <$> getWord8) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet ((+1) <$> getWord8 subtract 1 <$> getWord8) (BLC.pack "abc") -- RunGet 98 -- -- >>> runGet (getWord8 failGet ()) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet (getWord8 failGet ()) (BLC.pack "abc") -- RunGet 97 -- -- >>> runGet (Al.some getWord8) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet (Al.some getWord8) (BLC.pack "a") -- RunGet [97] -- -- >>> runGet (Al.some getWord8) (BLC.pack "abc") -- RunGet [97,98,99] -- -- >>> runGet (Al.many getWord8) (BLC.pack "") -- RunGet [] -- -- >>> runGet (Al.many getWord8) (BLC.pack "a") -- RunGet [97] -- -- >>> runGet (Al.many getWord8) (BLC.pack "abc") -- RunGet [97,98,99] instance Alt (Get e) where f g = do (d, bs) <- runAndKeepTrack f case d of CompletedDone b a -> Get (\_ q -> q b a) CompletedFail _ _ -> pushBack bs >> g some p = (:) <$> p <*> Al.many p many p = (p >>= \x -> fmap (x:) (Al.many p)) pure [] -- | Pick between two @Get@ decoders, finding the first to not fail. -- -- >>> runGet (((+1) <$> getWord8) <> (subtract 1 <$> getWord8)) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet (((+1) <$> getWord8) <> (subtract 1 <$> getWord8)) (BLC.pack "abc") -- RunGet 98 -- -- >>> runGet (getWord8 <> failGet ()) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet (getWord8 <> failGet ()) (BLC.pack "abc") -- RunGet 97 instance Semigroup (Get e a) where (<>) = () -- | A @Get@ decoder that always fails with the given value. -- -- prop> runGet (failGet x :: Get Int ()) (BLC.pack s) == _RunGetFail # (0, x) -- -- >>> runGet (failGet "abc" :: Get String ()) (BLC.pack "def") -- RunGetFail 0 "abc" failGet :: e -> Get e a failGet e = Get (\i _ -> XFail i e) constant :: (forall r. XDecoder e r) -> Get e a constant d = Get (\_ _ -> d) -- | Run a @Get@ decoder, but keep a track of the input that ran it to completion. -- -- >>> runGet (runAndKeepTrack getWord8 :: Get () (CompletedXDecoder () Word8, [BC.ByteString])) (BLC.pack "") -- RunGet (CompletedFail "" (),[]) -- -- >>> runGet (runAndKeepTrack getWord8 :: Get () (CompletedXDecoder () Word8, [BC.ByteString])) (BLC.pack "abc") -- RunGet (CompletedDone "bc" 97,["abc"]) runAndKeepTrack :: Get e a -> Get x (CompletedXDecoder e a, [B.ByteString]) runAndKeepTrack (Get k) = Get (\b q -> let go !acc w = case w of XDone c a -> q b (CompletedDone c a, reverse acc) XPartial l -> XPartial (\c -> go (maybe acc (:acc) c) (l c)) XFail c e -> q b (CompletedFail c e, reverse acc) XBytesRead i l -> XBytesRead i (go acc . l) in go [] (k b XDone)) {-# INLINE runAndKeepTrack #-} -- | -- -- >>> runGet (pushBack [] :: Get () ()) (BLC.pack "") -- RunGet () -- -- >>> runGet (pushBack [] :: Get () ()) (BLC.pack "abc") -- RunGet () -- -- >>> runGet (pushBack [BC.pack "def"] :: Get () ()) (BLC.pack "") -- RunGet () -- -- >>> runGet (pushBack [BC.pack "def"] :: Get () ()) (BLC.pack "abc") -- RunGet () pushBack :: [B.ByteString] -> Get e () pushBack z = let y [] = id y _ = B.concat . (:z) in Get (\b q -> q (y z b) ()) {-# INLINE pushBack #-} -- | -- -- >>> runGet (pushFront (BC.pack "def") :: Get () ()) (BLC.pack "") -- RunGet () -- -- >>> runGet (pushFront (BC.pack "def") :: Get () ()) (BLC.pack "abc") -- RunGet () pushFront :: B.ByteString -> Get e () pushFront b = Get (\c q -> q (B.append b c) ()) {-# INLINE pushFront #-} xrunGetIncremental :: Get e a -> XDecoder e a xrunGetIncremental (Get k) = noMeansNo (k B.empty XDone) noMeansNo :: XDecoder e a -> XDecoder e a noMeansNo = let neverAgain (XPartial k) = neverAgain (k Nothing) neverAgain (XBytesRead i k) = XBytesRead i (neverAgain . k) neverAgain r@(XDone _ _) = r neverAgain r@(XFail _ _) = r go (XPartial k) = XPartial (\b -> (if isJust b then go else neverAgain) (k b)) go (XBytesRead i k) = XBytesRead i (go . k) go r@(XDone _ _) = r go r@(XFail _ _) = r in go prompt :: B.ByteString -> XDecoder e a -> (B.ByteString -> XDecoder e a) -> XDecoder e a prompt b d f = let loop = XPartial (maybe d (\s -> if B.null s then loop else f (b `B.append` s))) in loop -- | -- -- >>> runGet (bytesRead :: Get () Int64) (BLC.pack "") -- RunGet 0 -- -- >>> runGet (bytesRead :: Get () Int64) (BLC.pack "abc") -- RunGet 0 -- -- >>> runGet (getWord8 >> getWord16be >> getWord32le >> bytesRead) (BLC.pack "abcdefghijk") -- RunGet 7 bytesRead :: Get e Int64 bytesRead = Get (\b q -> XBytesRead (fromIntegral (B.length b)) (q b)) -- | -- -- >>> runGet (isolate 1 getWord8) (BLC.pack "ab") -- RunGet 97 -- -- >>> runGet (isolate 1 getWord8) (BLC.pack "abcde") -- RunGet 97 -- -- >>> runGet (isolate 2 getWord16le) (BLC.pack "abcde") -- RunGet 25185 -- -- >>> runGet (isolate 1 getWord16le) (BLC.pack "abcde") -- RunGetFail 0 (IsolateXFail ()) -- -- >>> runGet (isolate (-3) getWord16le) (BLC.pack "abcde") -- RunGetFail 0 NegativeSize -- -- >>> runGet (isolate 3 getWord16le) (BLC.pack "abcde") -- RunGetFail 2 (UnexpectedConsumed 2 3) isolate :: Int -> Get e a -> Get (IsolateError e) a isolate m (Get k) = let go !n (XDone l x) = if n == 0 && B.null l then return x else do pushFront l failGet (_UnexpectedConsumed # (m - n - B.length l, m)) go 0 (XPartial r) = go 0 (r Nothing) go n (XPartial r) = do i <- Get (\b q -> let takeLimited t = let (j, o) = B.splitAt n t in q o (Just j) in if B.null b then prompt b (q B.empty Nothing) takeLimited else takeLimited b) case i of Nothing -> go n (r Nothing) Just u -> go (n - B.length u) (r (Just u)) go _ (XFail b e) = pushFront b >> failGet (_IsolateXFail # e) go n (XBytesRead i r) = go n (r $! fromIntegral m - fromIntegral n - i) in if m < 0 then failGet (_NegativeSize # ()) else go m (k B.empty XDone) -- | -- -- >>> runGet demandInput (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet demandInput (BLC.pack "a") -- RunGet () -- -- >>> runGet demandInput (BLC.pack "abc") -- RunGet () demandInput :: Get () () demandInput = Get (\b q -> prompt b (XFail b ()) (`q` ())) -- | -- -- >>> runGet (getWord8 >>= \c -> skip 2 >> getWord8 >>= \d -> return (c,d)) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet (getWord8 >>= \c -> skip 2 >> getWord8 >>= \d -> return (c,d)) (BLC.pack "abcdefghi") -- RunGet (97,100) -- -- >>> runGet (getWord8 >>= \c -> skip 2 >> getWord8 >>= \d -> return (c,d)) (BLC.pack "abc") -- RunGetFail 3 () skip :: Int -> Get () () skip n = readN n (return ()) {-# INLINE skip #-} -- | -- -- >>> runGet isNotEmpty (BLC.pack "") -- RunGet False -- -- >>> runGet isNotEmpty (BLC.pack "abc") -- RunGet True -- -- >>> runGet (isNotEmpty >>= \p -> getWord8 >>= \w -> return (w, p)) (BLC.pack "abc") -- RunGet (97,True) -- -- >>> runGet (isNotEmpty >>= \p -> getWord8 >>= \w -> return (w, p)) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet (isNotEmpty >>= \p -> getWord8 >>= \w -> return (w, p)) (BLC.pack "a") -- RunGet (97,True) isNotEmpty :: Get e Bool isNotEmpty = fmap not isEmpty -- | -- -- >>> runGet isEmpty (BLC.pack "") -- RunGet True -- -- >>> runGet isEmpty (BLC.pack "abc") -- RunGet False -- -- >>> runGet (isEmpty >>= \p -> getWord8 >>= \w -> return (w, p)) (BLC.pack "abc") -- RunGet (97,False) -- -- >>> runGet (isEmpty >>= \p -> getWord8 >>= \w -> return (w, p)) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet (isEmpty >>= \p -> getWord8 >>= \w -> return (w, p)) (BLC.pack "a") -- RunGet (97,False) isEmpty :: Get e Bool isEmpty = Get (\b q -> if B.null b then prompt b (q b True) (`q` False) else q b False) -- | -- -- >>> runGet (lookAhead getWord8) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet (lookAhead getWord8) (BLC.pack "abc") -- RunGet 97 -- -- >>> runGet (lookAhead getWord8) (BLC.pack "a") -- RunGet 97 lookAhead :: Get e a -> Get e a lookAhead g = do (d, bs) <- runAndKeepTrack g case d of CompletedDone _ a -> pushBack bs >> return a CompletedFail inp s -> constant (XFail inp s) -- | -- -- >>> runGet (lookAheadM (getWord8 >>= \w -> return (if even w then Just (w + 5) else Nothing))) (BLC.pack "abc") -- RunGet Nothing -- -- >>> runGet (lookAheadM (getWord8 >>= \w -> return (if even w then Just (w + 5) else Nothing))) (BLC.pack "bc") -- RunGet (Just 103) -- -- >>> runGet (lookAheadM (getWord8 >>= \w -> return (if even w then Just (w + 5) else Nothing))) (BLC.pack "") -- RunGetFail 0 () lookAheadM :: Get e (Maybe a) -> Get e (Maybe a) lookAheadM g = let g' = fmap (maybe (Left ()) Right) g in fmap (either (return Nothing) Just) (lookAheadE g') -- | -- -- >>> runGet (lookAheadE (getWord8 >>= \w -> return (if even w then Left (w + 5) else Right (w - 4)))) (BLC.pack "abc") -- RunGet (Right 93) -- -- >>> runGet (lookAheadE (getWord8 >>= \w -> return (if even w then Left (w + 5) else Right (w - 4)))) (BLC.pack "bc") -- RunGet (Left 103) -- -- >>> runGet (lookAheadE (getWord8 >>= \w -> return (if even w then Left (w + 5) else Right (w - 4)))) (BLC.pack "") -- RunGetFail 0 () lookAheadE :: Get e (Either a b) -> Get e (Either a b) lookAheadE g = do (d, b) <- runAndKeepTrack g case d of CompletedDone _ (Left x) -> pushBack b >> return (Left x) CompletedDone i (Right x) -> Get (\_ q -> q i (Right x)) CompletedFail i s -> constant (XFail i s) -- | -- -- >>> runGet ([(), ()] !+ (setLabel [] getWord8)) (BLC.pack "") -- RunGetFail 0 [(),()] -- -- >>> runGet ([(), ()] !+ (setLabel [] getWord8)) (BLC.pack "abc") -- RunGet 97 (!+) :: Semigroup e => e -> Get e a -> Get e a (!+) = addLabel infixl 3 !+ -- | -- -- >>> runGet ([(), ()] `addLabel` (setLabel [] getWord8)) (BLC.pack "") -- RunGetFail 0 [(),()] -- -- >>> runGet ([(), ()] `addLabel` (setLabel [] getWord8)) (BLC.pack "abc") -- RunGet 97 addLabel :: Semigroup e => e -> Get e a -> Get e a addLabel m = modifyLabel (<> m) -- | -- -- >>> runGet ("error" !- getWord8) (BLC.pack "") -- RunGetFail 0 "error" -- -- >>> runGet ("error" !- getWord8) (BLC.pack "abc") -- RunGet 97 (!-) :: e -> Get d a -> Get e a (!-) = setLabel infixl 3 !- -- | -- -- >>> runGet ("error" `setLabel` getWord8) (BLC.pack "") -- RunGetFail 0 "error" -- -- >>> runGet ("error" `setLabel` getWord8) (BLC.pack "abc") -- RunGet 97 setLabel :: e -> Get d a -> Get e a setLabel = modifyLabel . return -- | -- -- >>> runGet (reverse !!- setLabel "error" getWord8) (BLC.pack "") -- RunGetFail 0 "rorre" -- -- >>> runGet (reverse !!- setLabel "error" getWord8) (BLC.pack "abc") -- RunGet 97 (!!-) :: (d -> e) -> Get d a -> Get e a (!!-) = modifyLabel infixl 3 !!- -- | -- -- >>> runGet (reverse `modifyLabel` setLabel "error" getWord8) (BLC.pack "") -- RunGetFail 0 "rorre" -- -- >>> runGet (reverse `modifyLabel` setLabel "error" getWord8) (BLC.pack "abc") -- RunGet 97 modifyLabel :: (d -> e) -> Get d a -> Get e a modifyLabel m = bimap m id -- | -- -- >>> runGet (getByteString (-3)) (BLC.pack "") -- RunGet "" -- -- >>> runGet (getByteString 3) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet (getByteString 3) (BLC.pack "abc") -- RunGet "abc" -- -- >>> runGet (getByteString 3) (BLC.pack "abcdef") -- RunGet "abc" getByteString :: Int -> Get () B.ByteString getByteString n = if n > 0 then readN n (BU.unsafeTake n) else return B.empty {-# INLINE getByteString #-} modify :: (B.ByteString -> B.ByteString) -> Get e () modify f = Get (\b q -> q (f b) ()) get :: Get e B.ByteString get = Get (\b q -> q b b) put :: B.ByteString -> Get e () put s = Get (\_ q -> q s ()) -- | -- -- >>> runGet (readN 3 id) (BLC.pack "abc") -- RunGet "abc" -- -- >>> runGet (readN 3 id) (BLC.pack "ab") -- RunGetFail 0 () -- -- >>> runGet (readN 3 id) (BLC.pack "abcdef") -- RunGet "abcdef" -- -- >>> runGet (readN (-3) id) (BLC.pack "abcdef") -- RunGet "" readN :: Int -> (B.ByteString -> a) -> Get () a readN !n f = ensureN n >> unsafeReadN n f {-# INLINE [0] readN #-} {-# RULES "readN/readN merge" forall n m f g. readN n f `apG` readN m g = readN (n+m) (\bs -> f bs (g (BU.unsafeDrop n bs))) "returnG/readN swap" [~1] forall f. returnG f = readN 0 (const f) "readN 0/returnG swapback" [1] forall f. readN 0 f = returnG (f B.empty) #-} -- | -- -- >>> runGet (ensureN 3) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet (ensureN 3) (BLC.pack "abc") -- RunGet () -- -- >>> runGet (ensureN 3) (BLC.pack "abcdef") -- RunGet () ensureN :: Int -> Get () () ensureN !m = Get (\i k -> let go n = Get (\b q -> if B.length b >= n then q b () else let Get g = demandInput >> go n in g b q) in if B.length i >= m then k i () else let Get g = go m in g i k) {-# INLINE ensureN #-} unsafeReadN :: Int -> (B.ByteString -> a) -> Get e a unsafeReadN !n f = Get (\b ks -> ks (BU.unsafeDrop n b) $! f b) readNWith :: Int -> (Ptr a -> IO a) -> Get () a readNWith n f = readN n (\s -> BI.inlinePerformIO (BU.unsafeUseAsCString s (f . castPtr))) {-# INLINE readNWith #-} data Decoder e a = Fail !B.ByteString {-# UNPACK #-} !Int64 e | Partial (Maybe B.ByteString -> Decoder e a) | Done !B.ByteString {-# UNPACK #-} !Int64 a -- | -- -- >>> decoder (\b i n -> B.length b + fromIntegral i + n) (\_ -> 99) (\b n a -> B.length b + fromIntegral n + a) (_Fail # (BC.pack "abc", 12, 19)) -- 34 -- -- >>> decoder (\b i n -> B.length b + fromIntegral i + n) (\_ -> 99) (\b n a -> B.length b + fromIntegral n + a) (_Partial # (\b -> _Fail # (fromMaybe (BC.pack "abc") b, 12, 19))) -- 99 -- -- >>> decoder (\b i n -> B.length b + fromIntegral i + n) (\_ -> 99) (\b n a -> B.length b + fromIntegral n + a) (_Done # (BC.pack "abc", 12, 19)) -- 34 decoder :: (B.ByteString -> Int64 -> e -> x) -> ((Maybe B.ByteString -> Decoder e a) -> x) -> (B.ByteString -> Int64 -> a -> x) -> Decoder e a -> x decoder f _ _ (Fail b i e) = f b i e decoder _ p _ (Partial k) = p k decoder _ _ d (Done b i a) = d b i a -- | -- -- >>> (_Fail # (BC.pack "abc", 19, 31)) ^? _Fail -- Just ("abc",19,31) -- -- >>> isNothing ((_Fail # (BC.pack "abc", 19, 31)) ^? _Partial) -- True -- -- >>> (_Fail # (BC.pack "abc", 19, 31)) ^? _Done -- Nothing _Fail :: Prism' (Decoder e a) (B.ByteString, Int64, e) _Fail = prism' (\(b, i, e) -> Fail b i e) (\x -> case x of Fail b i e -> Just (b, i, e) _ -> Nothing) -- | -- -- >>> (_Partial # (\b -> _Fail # (fromMaybe (BC.pack "abc") b, 12, 19))) ^? _Fail -- Nothing -- -- >>> isJust ((_Partial # (\b -> _Fail # (fromMaybe (BC.pack "abc") b, 12, 19))) ^? _Partial) -- True -- -- >>> (_Partial # (\b -> _Fail # (fromMaybe (BC.pack "abc") b, 12, 19))) ^? _Done -- Nothing _Partial :: Prism' (Decoder e a) (Maybe B.ByteString -> Decoder e a) _Partial = prism' Partial (\x -> case x of Partial k -> Just k _ -> Nothing) -- | -- -- >>> (_Done # (BC.pack "abc", 19, 31)) ^? _Fail -- Nothing -- -- >>> isNothing ((_Done # (BC.pack "abc", 19, 31)) ^? _Partial) -- True -- -- >>> (_Done # (BC.pack "abc", 19, 31)) ^? _Done -- Just ("abc",19,31) _Done :: Prism' (Decoder e a) (B.ByteString, Int64, a) _Done = prism' (\(b, i, a) -> Done b i a) (\x -> case x of Done b i a -> Just (b, i, a) _ -> Nothing) bimapD :: (e -> f) -> (a -> b) -> Decoder e a -> Decoder f b bimapD f _ (Fail b i e) = Fail b i (f e) bimapD f g (Partial k) = Partial (bimapD f g . k) bimapD _ g (Done b i a) = Done b i (g a) {-# INLINE bimapD #-} -- | -- -- >>> (bimap (+10) (*20) (_Fail # (BC.pack "abc", 19, 31))) ^? _Fail -- Just ("abc",19,41) -- -- >>> (bimap (+10) (*20) (_Done # (BC.pack "abc", 19, 31))) ^? _Done -- Just ("abc",19,620) instance Bifunctor Decoder where bimap = bimapD fmapD :: (a -> b) -> Decoder e a -> Decoder e b fmapD = bimapD id {-# INLINE fmapD #-} -- | -- -- >>> (fmap (+10) (_Fail # (BC.pack "abc", 19, 31))) ^? _Fail -- Just ("abc",19,31) -- -- >>> (fmap (+10) (_Done # (BC.pack "abc", 19, 31))) ^? _Done -- Just ("abc",19,41) instance Functor (Decoder e) where fmap = fmapD calculateOffset :: XDecoder e a -> Decoder e a calculateOffset s = let go r !acc = case r of XDone i a -> Done i (acc - fromIntegral (B.length i)) a XFail i e -> Fail i (acc - fromIntegral (B.length i)) e XPartial k -> Partial (\b -> case b of Nothing -> go (k Nothing) acc Just j -> go (k b) (acc + fromIntegral (B.length j))) XBytesRead i k -> go (k $! (acc - i)) acc in go s 0 runGetIncremental :: Get e a -> Decoder e a runGetIncremental = calculateOffset . xrunGetIncremental takeHeadChunk :: L.ByteString -> Maybe B.ByteString takeHeadChunk lbs = case lbs of (LI.Chunk bs _) -> Just bs _ -> Nothing dropHeadChunk :: L.ByteString -> L.ByteString dropHeadChunk lbs = case lbs of (LI.Chunk _ lbs') -> lbs' _ -> LI.Empty runGet :: Get e a -> L.ByteString -> RunGetResult e a runGet g b = let feedAll (Done _ _ x) _ = _RunGet # x feedAll (Partial k) c = feedAll (k (takeHeadChunk c)) (dropHeadChunk c) feedAll (Fail _ p e) _ = _RunGetFail # (p, e) in feedAll (runGetIncremental g) b pushChunk :: Decoder e a -> B.ByteString -> Decoder e a pushChunk r i = case r of Done j p a -> Done (j `B.append` i) p a Partial k -> k (Just i) Fail j p s -> Fail (j `B.append` i) p s pushChunks :: Decoder e a -> L.ByteString -> Decoder e a pushChunks r0 = let go r [] = r go (Done i p a) xs = Done (B.concat (i:xs)) p a go (Fail i p s) xs = Fail (B.concat (i:xs)) p s go (Partial k) (x:xs) = go (k (Just x)) xs in go r0 . L.toChunks pushEndOfInput :: Decoder e a -> Decoder e a pushEndOfInput r = case r of Done {} -> r Partial k -> k Nothing Fail {} -> r -- | -- -- >>> runGet (getLazyByteString 5) (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet (getLazyByteString 5) (BLC.pack "abc") -- RunGetFail 3 () -- -- >>> runGet (getLazyByteString 5) (BLC.pack "abcdefg") -- RunGet "abcde" getLazyByteString :: Int64 -> Get () L.ByteString getLazyByteString = let consume n s = if fromIntegral (B.length s) >= n then Right (B.splitAt (fromIntegral n) s) else Left (fromIntegral (B.length s)) go n = do s <- get case consume n s of Left u -> do put B.empty demandInput fmap (s:) (go (n - u)) Right (w, r) -> do put r return [w] in fmap L.fromChunks . go -- | -- -- >>> runGet getLazyByteStringNul (BLC.pack "") -- RunGetFail 0 () -- -- >>> runGet getLazyByteStringNul (BLC.pack "abc") -- RunGetFail 3 () -- -- >>> runGet getLazyByteStringNul (BLC.pack "abc\0") -- RunGet "abc" -- -- >>> runGet getLazyByteStringNul (BLC.pack "abc\0def") -- RunGet "abc" getLazyByteStringNul :: Get () L.ByteString getLazyByteStringNul = let findNull s = case B.break (==0) s of (w, r) -> if B.null r then Nothing else Just (w, B.drop 1 r) go = do s <- get case findNull s of Nothing -> do put B.empty demandInput fmap (s:) go Just (w, r) -> do put r return [w] in fmap L.fromChunks go -- | -- -- >>> runGet getRemainingLazyByteString (BLC.pack "") -- RunGet "" -- -- >>> runGet getRemainingLazyByteString (BLC.pack "abc") -- RunGet "abc" getRemainingLazyByteString :: Get e L.ByteString getRemainingLazyByteString = let go = do s <- get put B.empty d <- isEmpty if d then return [s] else fmap (s:) go in fmap L.fromChunks go getPtr :: Storable a => Int -> Get () a getPtr n = readNWith n peek {-# INLINE getPtr #-} {-# RULES "getWord8/readN" getWord8 = readN 1 BU.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 #-} -- | -- -- >>> runGet getWord8 (BLC.pack "abc") -- RunGet 97 -- -- >>> runGet getWord8 (BLC.pack "123") -- RunGet 49 getWord8 :: Get () Word8 getWord8 = readN 1 BU.unsafeHead {-# INLINE [0] getWord8 #-} word16be :: B.ByteString -> Word16 word16be s = (fromIntegral (s `BU.unsafeIndex` 0) `shiftlW16` 8) .|. fromIntegral (s `BU.unsafeIndex` 1) {-# INLINE word16be #-} -- | -- -- >>> runGet getWord16be (BLC.pack "abc") -- RunGet 24930 -- -- >>> runGet getWord16be (BLC.pack "123") -- RunGet 12594 getWord16be :: Get () Word16 getWord16be = readN 2 word16be {-# INLINE [0] getWord16be #-} word16le :: B.ByteString -> Word16 word16le s = (fromIntegral (s `BU.unsafeIndex` 1) `shiftlW16` 8) .|. fromIntegral (s `BU.unsafeIndex` 0) {-# INLINE word16le #-} -- | -- -- >>> runGet getWord16le (BLC.pack "abc") -- RunGet 25185 -- -- >>> runGet getWord16le (BLC.pack "123") -- RunGet 12849 getWord16le :: Get () Word16 getWord16le = readN 2 word16le {-# INLINE [0] getWord16le #-} word32be :: B.ByteString -> Word32 word32be s = (fromIntegral (s `BU.unsafeIndex` 0) `shiftlW32` 24) .|. (fromIntegral (s `BU.unsafeIndex` 1) `shiftlW32` 16) .|. (fromIntegral (s `BU.unsafeIndex` 2) `shiftlW32` 8) .|. fromIntegral (s `BU.unsafeIndex` 3) {-# INLINE word32be #-} -- | -- -- >>> runGet getWord32be (BLC.pack "abcdef") -- RunGet 1633837924 -- -- >>> runGet getWord32be (BLC.pack "123456") -- RunGet 825373492 getWord32be :: Get () Word32 getWord32be = readN 4 word32be {-# INLINE [0] getWord32be #-} word32le :: B.ByteString -> Word32 word32le s = (fromIntegral (s `BU.unsafeIndex` 3) `shiftlW32` 24) .|. (fromIntegral (s `BU.unsafeIndex` 2) `shiftlW32` 16) .|. (fromIntegral (s `BU.unsafeIndex` 1) `shiftlW32` 8) .|. fromIntegral (s `BU.unsafeIndex` 0) {-# INLINE word32le #-} -- | -- -- -- >>> runGet getWord32le (BLC.pack "abcdef") -- RunGet 1684234849 -- -- >>> runGet getWord32le (BLC.pack "123456") -- RunGet 875770417 getWord32le :: Get () Word32 getWord32le = readN 4 word32le {-# INLINE [0] getWord32le #-} word64be :: B.ByteString -> Word64 word64be s = (fromIntegral (s `BU.unsafeIndex` 0) `shiftlW64` 56) .|. (fromIntegral (s `BU.unsafeIndex` 1) `shiftlW64` 48) .|. (fromIntegral (s `BU.unsafeIndex` 2) `shiftlW64` 40) .|. (fromIntegral (s `BU.unsafeIndex` 3) `shiftlW64` 32) .|. (fromIntegral (s `BU.unsafeIndex` 4) `shiftlW64` 24) .|. (fromIntegral (s `BU.unsafeIndex` 5) `shiftlW64` 16) .|. (fromIntegral (s `BU.unsafeIndex` 6) `shiftlW64` 8) .|. fromIntegral (s `BU.unsafeIndex` 7) {-# INLINE word64be #-} -- | -- -- >>> runGet getWord64be (BLC.pack "abcdefghi") -- RunGet 7017280452245743464 -- -- >>> runGet getWord64be (BLC.pack "123456789") -- RunGet 3544952156018063160 getWord64be :: Get () Word64 getWord64be = readN 8 word64be {-# INLINE [0] getWord64be #-} word64le :: B.ByteString -> Word64 word64le s = (fromIntegral (s `BU.unsafeIndex` 7) `shiftlW64` 56) .|. (fromIntegral (s `BU.unsafeIndex` 6) `shiftlW64` 48) .|. (fromIntegral (s `BU.unsafeIndex` 5) `shiftlW64` 40) .|. (fromIntegral (s `BU.unsafeIndex` 4) `shiftlW64` 32) .|. (fromIntegral (s `BU.unsafeIndex` 3) `shiftlW64` 24) .|. (fromIntegral (s `BU.unsafeIndex` 2) `shiftlW64` 16) .|. (fromIntegral (s `BU.unsafeIndex` 1) `shiftlW64` 8) .|. fromIntegral (s `BU.unsafeIndex` 0) {-# INLINE word64le #-} -- | -- -- >>> runGet getWord64le (BLC.pack "abcdefghi") -- RunGet 7523094288207667809 -- -- >>> runGet getWord64le (BLC.pack "123456789") -- RunGet 4050765991979987505 getWord64le :: Get () Word64 getWord64le = readN 8 word64le {-# INLINE [0] getWord64le #-} -- | -- -- >>> runGet getWordhost (BLC.pack "abcdefghi") -- RunGet 7523094288207667809 -- -- >>> runGet getWordhost (BLC.pack "123456789") -- RunGet 4050765991979987505 getWordhost :: Get () Word getWordhost = getPtr (sizeOf (undefined :: Word)) {-# INLINE getWordhost #-} -- | -- -- >>> runGet getWord16host (BLC.pack "abcde") -- RunGet 25185 -- -- >>> runGet getWord16host (BLC.pack "12345") -- RunGet 12849 getWord16host :: Get () Word16 getWord16host = getPtr (sizeOf (undefined :: Word16)) {-# INLINE getWord16host #-} -- | -- -- >>> runGet getWord32host (BLC.pack "abcde") -- RunGet 1684234849 -- -- >>> runGet getWord32host (BLC.pack "12345") -- RunGet 875770417 getWord32host :: Get () Word32 getWord32host = getPtr (sizeOf (undefined :: Word32)) {-# INLINE getWord32host #-} -- | -- -- >>> runGet getWord64host (BLC.pack "abcdeghi") -- RunGet 7595434456733934177 -- -- >>> runGet getWord64host (BLC.pack "123456789") -- RunGet 4050765991979987505 getWord64host :: Get () Word64 getWord64host = getPtr (sizeOf (undefined :: Word64)) {-# INLINE getWord64host #-} ------------------------------------------------------------------------ -- Unchecked shifts shiftlW16 :: Word16 -> Int -> Word16 shiftlW32 :: Word32 -> Int -> Word32 shiftlW64 :: Word64 -> Int -> Word64 #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) shiftlW16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) shiftlW32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i) #if WORD_SIZE_IN_BITS < 64 shiftlW64 (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 shiftlW64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) #endif #else shiftlW16 = shiftL shiftlW32 = shiftL shiftlW64 = shiftL #endif ---- data XDecoder e a = XFail !B.ByteString e | XPartial (Maybe B.ByteString -> XDecoder e a) | XDone !B.ByteString a | XBytesRead {-# UNPACK #-} !Int64 (Int64 -> XDecoder e a) xdecoder :: (B.ByteString -> e -> x) -> ((Maybe B.ByteString -> XDecoder e a) -> x) -> (B.ByteString -> a -> x) -> (Int64 -> (Int64 -> XDecoder e a) -> x) -> XDecoder e a -> x xdecoder f _ _ _ (XFail b e) = f b e xdecoder _ p _ _ (XPartial k) = p k xdecoder _ _ d _ (XDone b a) = d b a xdecoder _ _ _ r (XBytesRead i k) = r i k _XFail :: Prism' (XDecoder e a) (B.ByteString, e) _XFail = prism' (uncurry XFail) (\x -> case x of XFail b e -> Just (b, e) _ -> Nothing) _XPartial :: Prism' (XDecoder e a) (Maybe B.ByteString -> XDecoder e a) _XPartial = prism' XPartial (\x -> case x of XPartial k -> Just k _ -> Nothing) _XDone :: Prism' (XDecoder e a) (B.ByteString, a) _XDone = prism' (uncurry XDone) (\x -> case x of XDone b a -> Just (b, a) _ -> Nothing) _XBytesRead :: Prism' (XDecoder e a) (Int64, Int64 -> XDecoder e a) _XBytesRead = prism' (uncurry XBytesRead) (\x -> case x of XBytesRead i k -> Just (i, k) _ -> Nothing) {-# INLINE _XFail #-} {-# INLINE _XPartial #-} {-# INLINE _XDone #-} {-# INLINE _XBytesRead #-} instance Functor (XDecoder e) where fmap = bimap id instance Bifunctor XDecoder where bimap f _ (XFail b e) = XFail b (f e) bimap f g (XPartial k) = XPartial (bimap f g . k) bimap _ g (XDone b a) = XDone b (g a) bimap f g (XBytesRead i k) = XBytesRead i (bimap f g . k) instance Bifoldable XDecoder where bifoldMap f _ (XFail _ e) = f e bifoldMap _ _ (XPartial _) = mempty bifoldMap _ g (XDone _ a) = g a bifoldMap _ _ (XBytesRead _ _) = mempty instance Foldable (XDecoder e) where foldMap _ (XFail _ _) = mempty foldMap _ (XPartial _) = mempty foldMap f (XDone _ a) = f a foldMap _ (XBytesRead _ _) = mempty data CompletedXDecoder e a = CompletedFail !B.ByteString e | CompletedDone !B.ByteString a deriving (Eq, Ord, Show) completedXDecoder :: (B.ByteString -> e -> x) -> (B.ByteString -> a -> x) -> CompletedXDecoder e a -> x completedXDecoder f _ (CompletedFail b e) = f b e completedXDecoder _ d (CompletedDone b a) = d b a _CompletedFail :: Prism' (CompletedXDecoder e a) (B.ByteString, e) _CompletedFail = prism' (uncurry CompletedFail) (\x -> case x of CompletedFail b e -> Just (b, e) _ -> Nothing) _CompletedDone :: Prism' (CompletedXDecoder e a) (B.ByteString, a) _CompletedDone = prism' (uncurry CompletedDone) (\x -> case x of CompletedDone b a -> Just (b, a) _ -> Nothing) completedIso :: Iso (CompletedXDecoder e a) (CompletedXDecoder f b) (Either e a, B.ByteString) (Either f b, B.ByteString) completedIso = iso (\d -> case d of CompletedFail b e -> (Left e, b) CompletedDone b a -> (Right a, b)) (\z -> case z of (Left e, b) -> CompletedFail b e (Right a, b) -> CompletedDone b a) {-# INLINE completedIso #-} completedByteString :: Lens' (CompletedXDecoder e a) B.ByteString completedByteString = lens (\d -> case d of CompletedFail b _ -> b CompletedDone b _ -> b) (\d b -> case d of CompletedFail _ e -> CompletedFail b e CompletedDone _ a -> CompletedDone b a) {-# INLINE completedByteString #-} completedValue :: Lens' (CompletedXDecoder e a) (Either e a) completedValue = lens (\d -> case d of CompletedFail _ e -> Left e CompletedDone _ a -> Right a) (\d z -> case d of CompletedFail b e -> CompletedFail b (either id (pure e) z) CompletedDone b a -> CompletedDone b (either (pure a) id z)) {-# INLINE completedValue #-} instance Functor (CompletedXDecoder e) where fmap = bimap id instance Bifunctor CompletedXDecoder where bimap f _ (CompletedFail b e) = CompletedFail b (f e) bimap _ g (CompletedDone b a) = CompletedDone b (g a) instance Foldable (CompletedXDecoder e) where foldMap _ (CompletedFail _ _) = mempty foldMap f (CompletedDone _ a) = f a instance Traversable (CompletedXDecoder e) where traverse = bitraverse pure instance Bifoldable CompletedXDecoder where bifoldMap f _ (CompletedFail _ e) = f e bifoldMap _ g (CompletedDone _ a) = g a instance Bitraversable CompletedXDecoder where bitraverse f _ (CompletedFail b e) = fmap (CompletedFail b) (f e) bitraverse _ g (CompletedDone b a) = fmap (CompletedDone b) (g a) uncomplete :: Prism' (XDecoder e a) (CompletedXDecoder e a) uncomplete = prism' (\d -> case d of CompletedFail b e -> XFail b e CompletedDone b a -> XDone b a) (\d -> case d of XFail b e -> Just (CompletedFail b e) XPartial _ -> Nothing XDone b a -> Just (CompletedDone b a) XBytesRead _ _ -> Nothing) {-# INLINE uncomplete #-} uncompletedByteString :: Traversal' (XDecoder e a) B.ByteString uncompletedByteString = uncomplete . completedByteString {-# INLINE uncompletedByteString #-} uncompletedValue :: Traversal' (XDecoder e a) (Either e a) uncompletedValue = uncomplete . completedValue {-# INLINE uncompletedValue #-}