summaryrefslogtreecommitdiff
path: root/Text/ProtocolBuffers/Get.hs
blob: e8b64f56651749eac74bc8e870ba3eaee4ad6017 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
{-# LANGUAGE CPP,MagicHash,ScopedTypeVariables,FlexibleInstances,RankNTypes,TypeSynonymInstances,MultiParamTypeClasses,BangPatterns,CPP #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
-- | 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.
--
-- Modified the monad to be strict for version 2.0.0
--
-- 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.
--
--
-- Add specialized high-bit-run
module Text.ProtocolBuffers.Get
    (Get,runGet,runGetAll,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,highBitRun
    ,getWord8,getByteString
    ,getWord16be,getWord32be,getWord64be
    ,getWord16le,getWord32le,getWord64le
    ,getWordhost,getWord16host,getWord32host,getWord64host
    --
    -- ,scan
    ,decode7,decode7size,decode7unrolled
    ) 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(Alternative(empty,(<|>)))
import Control.Monad(MonadPlus(mzero,mplus),when)
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(replicateM,(>=>))           -- XXX testing
--import qualified Data.ByteString as S(unpack)    -- XXX testing
--import qualified Data.ByteString.Lazy as L(pack) -- XXX testing
import Control.Monad(ap)                             -- instead of Functor.fmap; ap for Applicative
import qualified Control.Monad.Fail as Fail
import Data.Bits(Bits((.|.),(.&.)),shiftL)
import qualified Data.ByteString as S(concat,length,null,splitAt,findIndex)
import qualified Data.ByteString.Internal as S(ByteString(..),toForeignPtr,inlinePerformIO)
import qualified Data.ByteString.Unsafe as S(unsafeIndex,unsafeDrop {-,unsafeTake-})
import qualified Data.ByteString.Lazy as L(take,drop,length,span,toChunks,fromChunks,null,findIndex)
import qualified Data.ByteString.Lazy.Internal as L(ByteString(..),chunk)
import qualified Data.Foldable as F(foldr,foldr1)    -- used with Seq
import Data.Int(Int32,Int64)                         -- index type for L.ByteString
import Data.Word(Word8,Word16,Word32,Word64)
import Data.Sequence(Seq,null,(|>))                  -- used for future queue in handler state
import Foreign.ForeignPtr(withForeignPtr)
import Foreign.Ptr(Ptr,castPtr,plusPtr,minusPtr,nullPtr)
import Foreign.Storable(Storable(peek,sizeOf))
import System.IO.Unsafe(unsafePerformIO)
#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
import GHC.Base(Int(..),uncheckedShiftL#)
import GHC.Word(Word16(..),Word32(..),Word64(..),uncheckedShiftL64#)
#endif
--import Debug.Trace(trace)

trace :: a -> b -> b
trace _ = id

-- Simple external return type
data Result a = Failed {-# UNPACK #-} !Int64 String
              | Finished !L.ByteString {-# UNPACK #-} !Int64 a
              | Partial (Maybe L.ByteString -> Result a)

-- Internal state type, not exposed to the user.
-- Invariant: (S.null _top) implies (L.null _current)
data S = S { _top :: {-# UNPACK #-} !S.ByteString
           , _current :: !L.ByteString
           , consumed :: {-# UNPACK #-} !Int64
           } deriving Show

data T3 s = T3 !Int !s !Int

--data TU s = TU'OK !s !Int | TU'DO (Get s)
data TU s = TU'OK !s !Int

{-# SPECIALIZE decode7unrolled :: Get Int64 #-}
{-# SPECIALIZE decode7unrolled :: Get Int32 #-}
{-# SPECIALIZE decode7unrolled :: Get Word64 #-}
{-# SPECIALIZE decode7unrolled :: Get Word32 #-}
{-# SPECIALIZE decode7unrolled :: Get Int #-}
{-# SPECIALIZE decode7unrolled :: Get Integer #-}
decode7unrolled :: forall s. (Num s,Integral s, Bits s) => Get s
-- NOINLINE decode7unrolled removed to allow SPECIALIZE to work
decode7unrolled = Get $ \ sc sIn@(S ss@(S.PS fp off len) bs n) pc -> trace ("decode7unrolled: "++show (len,n)) $
  if S.null ss
    then trace ("decode7unrolled: S.null ss") $ unGet decode7 sc sIn pc -- decode7 will try suspend then will fail if still bad
    else
      let (TU'OK x i) =
            unsafePerformIO $ withForeignPtr fp $ \ptr0 -> do
                if ptr0 == nullPtr || len < 1 then error "Get.decode7unrolled: ByteString invariant failed" else do
                let ok :: s -> Int -> IO (TU s)
                    ok x0 i0 = return (TU'OK x0 i0)
                    more,err :: IO (TU s)
                    more = return (TU'OK 0 0)  -- decode7
                    err = return (TU'OK 0 (-1))  -- throwError
                    {-# INLINE ok #-}
                    {-# INLINE more #-}
                    {-# INLINE err #-}

--                -- Next line is segfault fix for null bytestrings from Nathan Howell <nhowell@alphaheavy.com>
--                if ptr0 == nullPtr then more else do

                let start = ptr0 `plusPtr` off :: Ptr Word8
                b'1 <- peek start
                if b'1 < 128 then ok (fromIntegral b'1) 1 else do
                let !val'1 = fromIntegral (b'1 .&. 0x7F)
                    !end = start `plusPtr` len
                    !ptr2 = start `plusPtr` 1 :: Ptr Word8
                if ptr2 >= end then more else do

                b'2 <- peek ptr2
                if b'2 < 128 then ok (val'1 .|. (fromIntegral b'2 `shiftL` 7)) 2 else do
                let !val'2 = (val'1 .|. (fromIntegral (b'2 .&. 0x7F) `shiftL` 7))
                    !ptr3 = ptr2 `plusPtr` 1
                if ptr3 >= end then more else do

                b'3::Word8 <- peek ptr3
                if b'3 < 128 then ok (val'2 .|. (fromIntegral b'3 `shiftL` 14)) 3 else do
                let !val'3 = (val'2 .|. (fromIntegral (b'3 .&. 0x7F) `shiftL` 14))
                    !ptr4 = ptr3 `plusPtr` 1
                if ptr4 >= end then more else do

                b'4::Word8 <- peek ptr4
                if b'4 < 128 then ok (val'3 .|. (fromIntegral b'4 `shiftL` 21)) 4 else do
                let !val'4 = (val'3 .|. (fromIntegral (b'4 .&. 0x7F) `shiftL` 21))
                    !ptr5 = ptr4 `plusPtr` 1
                if ptr5 >= end then more else do

                b'5::Word8 <- peek ptr5
                if b'5 < 128 then ok (val'4 .|. (fromIntegral b'5 `shiftL` 28)) 5 else do
                let !val'5 = (val'4 .|. (fromIntegral (b'5 .&. 0x7F) `shiftL` 28))
                    !ptr6 = ptr5 `plusPtr` 1
                if ptr6 >= end then more else do

                b'6::Word8 <- peek ptr6
                if b'6 < 128 then ok (val'5 .|. (fromIntegral b'6 `shiftL` 35)) 6 else do
                let !val'6 = (val'5 .|. (fromIntegral (b'6 .&. 0x7F) `shiftL` 35))
                    !ptr7 = ptr6 `plusPtr` 1
                if ptr7 >= end then more else do

                b'7::Word8 <- peek ptr7
                if b'7 < 128 then ok (val'6 .|. (fromIntegral b'7 `shiftL` 42)) 7 else do
                let !val'7 = (val'6 .|. (fromIntegral (b'7 .&. 0x7F) `shiftL` 42))
                    !ptr8 = ptr7 `plusPtr` 1
                if ptr8 >= end then more else do

                b'8::Word8 <- peek ptr8
                if b'8 < 128 then ok (val'7 .|. (fromIntegral b'8 `shiftL` 49)) 8 else do
                let !val'8 = (val'7 .|. (fromIntegral (b'8 .&. 0x7F) `shiftL` 49))
                    !ptr9 = ptr8 `plusPtr` 1
                if ptr9 >= end then more else do

                b'9::Word8 <- peek ptr9
                if b'9 < 128 then ok (val'8 .|. (fromIntegral b'9 `shiftL` 56)) 9 else do
                let !val'9 = (val'8 .|. (fromIntegral (b'9 .&. 0x7F) `shiftL` 56))
                    !ptrA = ptr9 `plusPtr` 1
                if ptrA >= end then more else do

                b'A::Word8 <- peek ptrA
                if b'A < 128 then ok (val'9 .|. (fromIntegral b'A `shiftL` 63)) 10 else do
                err

      in if i > 0
           then let ss' = (S.unsafeDrop i ss)
                    n' = n+fromIntegral i
                    s'safe = make_safe (S ss' bs n')
                in sc x s'safe pc
           else if i==0 then unGet decode7 sc sIn pc
                        else unGet (throwError $ "Text.ProtocolBuffers.Get.decode7unrolled: more than 10 bytes needed at bytes read of "++show n) sc sIn pc

{-# SPECIALIZE decode7 :: Get Int64 #-}
{-# SPECIALIZE decode7 :: Get Int32 #-}
{-# SPECIALIZE decode7 :: Get Word64 #-}
{-# SPECIALIZE decode7 :: Get Word32 #-}
{-# SPECIALIZE decode7 :: Get Int #-}
{-# SPECIALIZE decode7 :: Get Integer #-}
decode7 :: forall s. (Integral s, Bits s) => Get s
-- NOINLINE decode7 removed to allow SPECIALIZE to work
decode7 = go 0 0
 where
  go !s1 !shift1 = trace ("decode7.go: "++show (toInteger s1, shift1)) $ do
    let -- scanner's inner loop decodes only in current top strict bytestring, does not advance input state
        scanner (S.PS fp off len) =
          withForeignPtr fp $ \ptr0 -> do
           if ptr0 == nullPtr || len < 1 then error "Get.decode7: ByteString invariant failed" else do
            let start = ptr0 `plusPtr` off   -- start is a pointer to the next valid byte
                end   = start `plusPtr` len  -- end is a pointer one byte past the last valid byte
                inner :: (Ptr Word8) -> s -> Int -> IO (T3 s)
                inner !ptr !s !shift
                  | ptr < end = do
                      w <- peek ptr
                      trace ("w: " ++ show w) $ do
                      if (128>) w
                        then return $ T3 (succ (ptr `minusPtr` start) )            -- length of capture
                                         (s .|. ((fromIntegral w) `shiftL` shift)) -- put the last bits into high position
                                         (-1)                                      -- negative shift indicates satisfied
                        else inner (ptr `plusPtr` 1)  -- loop on next byte
                                   (s .|. ((fromIntegral (w .&. 0x7F)) `shiftL` shift)) -- put the new bits into high position
                                   (shift+7)          -- increase high position for next loop
                  | otherwise = return $ T3 (ptr `minusPtr` start)  -- length so far (ptr past end-of-string so no succ)
                                            s                       -- value so far
                                            shift                   -- next shift to use
            inner start s1 shift1
    (S ss bs n) <- getFull
    trace ("getFull says: "++ show ((S.length ss,ss),(L.length bs),n)) $ do
    if S.null ss
      then do
        continue <- suspend
        if continue
          then go s1 shift1
          else fail "Get.decode7: Zero length input" -- XXX can be triggered!
      else do
        let (T3 i sOut shiftOut) = unsafePerformIO $ scanner ss
            t = S.unsafeDrop i ss -- Warning: 't' may be mempty
            n' = n + fromIntegral i
        trace ("scanner says "++show ((i,toInteger sOut,shiftOut),(S.length t,n'))) $ do
        if 0 <= shiftOut
          then do
            putFull_unsafe (make_state bs n')
            if L.null bs
              then do
                continue <- suspend
                if continue
                  then go sOut shiftOut
                  else return sOut
              else do
                go sOut shiftOut
          else do
            putFull_safe (S t bs n') -- bs from getFull is still valid
            return sOut

data T2 = T2 !Int64 !Bool

decode7size :: Get Int64
decode7size = go 0
 where
  go !len1 = do
    let scanner (S.PS fp off len) =
          withForeignPtr fp $ \ptr0 -> do
           if ptr0 == nullPtr || len < 1 then error "Get.decode7size: ByteString invariant failed" else do
            let start = ptr0 `plusPtr` off
                end   = start `plusPtr` len
                inner :: (Ptr Word8) -> IO T2
                inner !ptr
                  | ptr < end = do
                      w <- peek ptr
                      if (128>) w
                        then return $ T2 (fromIntegral (ptr `minusPtr` start)) True
                        else inner (ptr `plusPtr` 1)
                  | otherwise = return $ T2 (fromIntegral (ptr `minusPtr` start)) False
            inner start
    (S ss bs n) <- getFull
    if S.null ss
      then do
        continue <- suspend
        if continue
          then go len1
          else fail "Get.decode7size: zero length input"
      else do
        let (T2 i ok) = unsafePerformIO $ scanner ss
            t = S.unsafeDrop (fromIntegral i) ss
            n' = n + i
            len2 = len1 + i
        if ok
          then do
            putFull_unsafe (S t bs n')
            return len2
          else do
            putFull_unsafe (make_state bs n')
            if L.null bs
              then do
                continue <- suspend
                if continue
                  then go len2
                  else return len2
              else
                go len2

-- 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/shallower/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 _ _ _) frame ->
  case frame of
    (HandlerFrame Nothing s future pc) -> sc () (collect s future) pc
    _ -> error "Text.ProtocolBuffers.Get: Impossible useCheckpoint frame!"

clearCheckpoint = Get $ \ sc s frame ->
   case frame of
     (HandlerFrame Nothing _s _future pc) -> sc () s pc
     _ -> error "Text.ProtocolBuffers.Get: Impossible clearCheckpoint frame!"

-- | '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 (const 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 (const useCheckpoint) (const 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 = make_safe $ s
                             | otherwise = make_safe $ 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 <Maybe Data.ByteString.Lazy.ByteString-> Result a)"++)

instance Show (FrameStack b) where
  showsPrec _ (ErrorFrame _ p) =(++) "(ErrorFrame <e->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 = make_state bsIn 0
        ec msg sOut = Failed (consumed sOut) msg

-- | 'runGetAll' is the simple executor, and will not ask for any continuation because this lazy bytestring is all the input
runGetAll :: Get a -> L.ByteString -> Result a
runGetAll (Get f) bsIn = f scIn sIn (ErrorFrame ec False)
  where scIn a (S ss bs n) _pc = Finished (L.chunk ss bs) n a
        sIn = make_state bsIn 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' = make_state bsNew 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 = make_state (mappend whole bsNew) n1
      rebuild x@(ErrorFrame {}) = x
  in sc () s' (rebuild pc)

-- Internal access to full internal state, as helper functions
getFull :: Get S
getFull = Get $ \ sc s pc -> sc s s pc

{-# INLINE putFull_unsafe #-}
putFull_unsafe :: S -> Get ()
putFull_unsafe !s = Get $ \ sc _s pc -> sc () s pc

{-# INLINE make_safe #-}
make_safe :: S -> S
make_safe s@(S ss bs n) =
  if S.null ss
    then make_state bs n
    else s

{-# INLINE make_state #-}
make_state :: L.ByteString -> Int64 -> S
make_state L.Empty n = S mempty mempty n
make_state (L.Chunk ss bs) n = S ss bs n

putFull_safe :: S -> Get ()
putFull_safe= putFull_unsafe . make_safe

-- | 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
  when continue suspendUntilComplete

-- | 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 S.null ss
    then suspendMsg "ensureBytes failed" >> ensureBytes n
    else do
      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 input, 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
  if S.null ss
    then do
      suspendMsg ("getLazyByteString S.null ss failed with "++show (n,(S.length ss,L.length bs,offset)))
      getLazyByteString n
    else do
      case splitAtOrDie n (L.chunk ss bs) of  -- safe use of L.chunk because of S.null ss check above
        Just (consume,rest) -> do
           putFull_unsafe (make_state rest (offset+n))
           return $! consume
        Nothing -> do
           suspendMsg ("getLazyByteString (Nothing from splitAtOrDie) failed with "++show (n,(S.length ss,L.length bs,offset)))
           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 (
      let checkBool (ErrorFrame _ b) = b
          checkBool (HandlerFrame _ _ _ pc) = checkBool pc
          -- 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
          rememberFalse (ErrorFrame ec _) = ErrorFrame ec False
          rememberFalse (HandlerFrame catcher s future pc) =
                         HandlerFrame catcher s future (rememberFalse pc)
      in \ 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' = make_safe (S ss (mappend bs bs') n)

-- 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
  -- Could ignore impossible S.null ss due to (ensureBytes m) and (0 < m) but be paranoid
  let lbs = L.chunk ss bs -- L.chunk is safe
  putFull_unsafe (make_state (L.drop m lbs) (n+m))  -- drop will not perform less than 'm' bytes due to ensureBytes above

-- | 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 = isEmpty >>= loop
 where loop False = return False
       loop True = do
         continue <- suspend
         if continue
           then isReallyEmpty
           else return True

-- | get the longest prefix of the input where the high bit is set as well as following byte.
-- This made getVarInt slower.
highBitRun :: Get Int64
{-# INLINE highBitRun #-}
highBitRun = loop where
  loop :: Get Int64
  {-# INLINE loop #-}
  loop = do
    (S ss bs _n) <- getFull
    -- S.null ss is okay, will lead to Nothing, Nothing, suspend below
    let mi = S.findIndex (128>) ss
    case mi of
      Just i -> return (succ $ fromIntegral i)
      Nothing -> do
        let mj = L.findIndex (128>) bs
        case mj of
          Just j -> return (fromIntegral (S.length ss) + succ j)
          Nothing -> do
            continue <- suspend
            if continue then loop
              else fail "highBitRun has failed"

-- | get the longest prefix of the input where all the bytes satisfy the predicate.
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) -- L.chunk is safe
                            putFull_unsafe (make_state post (n + L.length pre))
                            if L.null post
                              then do continue <- suspend
                                      if continue then fmap ((L.toChunks pre)++) 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 -- Leave at least one character of 'ss' in 'post' allowing putFull_unsafe below
    then do let (pre,post) = S.splitAt nIn ss
            putFull_unsafe (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 do now <- fmap (S.concat . L.toChunks) (getLazyByteString (fromIntegral nIn))
            return $! now
{-# 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 #-}

-- 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 = seq a $ Get (\sc -> sc a)
  {-# INLINE return #-}
  m >>= k  = Get (\sc -> unGet m (\ a -> seq a $ unGet (k a) sc))
  {-# INLINE (>>=) #-}
#if !MIN_VERSION_base(4,11,0)
  fail = Fail.fail
#endif

instance Fail.MonadFail Get where
  fail = throwError . strMsg

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 (mempty, 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 mempty, 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...

-- Assume n>0
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)
-- Assume sizeOf (undefined :: a)) > 0
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)

#else
shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
#endif

#else
shiftl_w16 = shiftL
shiftl_w32 = shiftL
shiftl_w64 = shiftL
#endif