Fix for recover with -fexternal-interpreter (#15418)
[ghc.git] / libraries / ghci / GHCi / Message.hs
1 {-# LANGUAGE GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables,
2 GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards #-}
3 {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}
4
5 -- |
6 -- Remote GHCi message types and serialization.
7 --
8 -- For details on Remote GHCi, see Note [Remote GHCi] in
9 -- compiler/ghci/GHCi.hs.
10 --
11 module GHCi.Message
12 ( Message(..), Msg(..)
13 , THMessage(..), THMsg(..)
14 , QResult(..)
15 , EvalStatus_(..), EvalStatus, EvalResult(..), EvalOpts(..), EvalExpr(..)
16 , SerializableException(..)
17 , toSerializableException, fromSerializableException
18 , THResult(..), THResultType(..)
19 , ResumeContext(..)
20 , QState(..)
21 , getMessage, putMessage, getTHMessage, putTHMessage
22 , Pipe(..), remoteCall, remoteTHCall, readPipe, writePipe
23 ) where
24
25 import Prelude -- See note [Why do we import Prelude here?]
26 import GHCi.RemoteTypes
27 import GHCi.FFI
28 import GHCi.TH.Binary ()
29 import GHCi.BreakArray
30
31 import GHC.LanguageExtensions
32 import GHC.Exts.Heap
33 import GHC.ForeignSrcLang
34 import GHC.Fingerprint
35 import Control.Concurrent
36 import Control.Exception
37 import Data.Binary
38 import Data.Binary.Get
39 import Data.Binary.Put
40 import Data.ByteString (ByteString)
41 import qualified Data.ByteString as B
42 import qualified Data.ByteString.Lazy as LB
43 import Data.Dynamic
44 import Data.Typeable (TypeRep)
45 import Data.IORef
46 import Data.Map (Map)
47 import Foreign
48 import GHC.Generics
49 import GHC.Stack.CCS
50 import qualified Language.Haskell.TH as TH
51 import qualified Language.Haskell.TH.Syntax as TH
52 import System.Exit
53 import System.IO
54 import System.IO.Error
55
56 -- -----------------------------------------------------------------------------
57 -- The RPC protocol between GHC and the interactive server
58
59 -- | A @Message a@ is a message that returns a value of type @a@.
60 -- These are requests sent from GHC to the server.
61 data Message a where
62 -- | Exit the iserv process
63 Shutdown :: Message ()
64
65 -- RTS Linker -------------------------------------------
66
67 -- These all invoke the corresponding functions in the RTS Linker API.
68 InitLinker :: Message ()
69 LookupSymbol :: String -> Message (Maybe (RemotePtr ()))
70 LookupClosure :: String -> Message (Maybe HValueRef)
71 LoadDLL :: String -> Message (Maybe String)
72 LoadArchive :: String -> Message () -- error?
73 LoadObj :: String -> Message () -- error?
74 UnloadObj :: String -> Message () -- error?
75 AddLibrarySearchPath :: String -> Message (RemotePtr ())
76 RemoveLibrarySearchPath :: RemotePtr () -> Message Bool
77 ResolveObjs :: Message Bool
78 FindSystemLibrary :: String -> Message (Maybe String)
79
80 -- Interpreter -------------------------------------------
81
82 -- | Create a set of BCO objects, and return HValueRefs to them
83 -- Note: Each ByteString contains a Binary-encoded [ResolvedBCO], not
84 -- a ResolvedBCO. The list is to allow us to serialise the ResolvedBCOs
85 -- in parallel. See @createBCOs@ in compiler/ghci/GHCi.hsc.
86 CreateBCOs :: [LB.ByteString] -> Message [HValueRef]
87
88 -- | Release 'HValueRef's
89 FreeHValueRefs :: [HValueRef] -> Message ()
90
91 -- | Add entries to the Static Pointer Table
92 AddSptEntry :: Fingerprint -> HValueRef -> Message ()
93
94 -- | Malloc some data and return a 'RemotePtr' to it
95 MallocData :: ByteString -> Message (RemotePtr ())
96 MallocStrings :: [ByteString] -> Message [RemotePtr ()]
97
98 -- | Calls 'GHCi.FFI.prepareForeignCall'
99 PrepFFI :: FFIConv -> [FFIType] -> FFIType -> Message (RemotePtr C_ffi_cif)
100
101 -- | Free data previously created by 'PrepFFI'
102 FreeFFI :: RemotePtr C_ffi_cif -> Message ()
103
104 -- | Create an info table for a constructor
105 MkConInfoTable
106 :: Int -- ptr words
107 -> Int -- non-ptr words
108 -> Int -- constr tag
109 -> Int -- pointer tag
110 -> [Word8] -- constructor desccription
111 -> Message (RemotePtr StgInfoTable)
112
113 -- | Evaluate a statement
114 EvalStmt
115 :: EvalOpts
116 -> EvalExpr HValueRef {- IO [a] -}
117 -> Message (EvalStatus [HValueRef]) {- [a] -}
118
119 -- | Resume evaluation of a statement after a breakpoint
120 ResumeStmt
121 :: EvalOpts
122 -> RemoteRef (ResumeContext [HValueRef])
123 -> Message (EvalStatus [HValueRef])
124
125 -- | Abandon evaluation of a statement after a breakpoint
126 AbandonStmt
127 :: RemoteRef (ResumeContext [HValueRef])
128 -> Message ()
129
130 -- | Evaluate something of type @IO String@
131 EvalString
132 :: HValueRef {- IO String -}
133 -> Message (EvalResult String)
134
135 -- | Evaluate something of type @String -> IO String@
136 EvalStringToString
137 :: HValueRef {- String -> IO String -}
138 -> String
139 -> Message (EvalResult String)
140
141 -- | Evaluate something of type @IO ()@
142 EvalIO
143 :: HValueRef {- IO a -}
144 -> Message (EvalResult ())
145
146 -- | Create a set of CostCentres with the same module name
147 MkCostCentres
148 :: String -- module, RemotePtr so it can be shared
149 -> [(String,String)] -- (name, SrcSpan)
150 -> Message [RemotePtr CostCentre]
151
152 -- | Show a 'CostCentreStack' as a @[String]@
153 CostCentreStackInfo
154 :: RemotePtr CostCentreStack
155 -> Message [String]
156
157 -- | Create a new array of breakpoint flags
158 NewBreakArray
159 :: Int -- size
160 -> Message (RemoteRef BreakArray)
161
162 -- | Enable a breakpoint
163 EnableBreakpoint
164 :: RemoteRef BreakArray
165 -> Int -- index
166 -> Bool -- on or off
167 -> Message ()
168
169 -- | Query the status of a breakpoint (True <=> enabled)
170 BreakpointStatus
171 :: RemoteRef BreakArray
172 -> Int -- index
173 -> Message Bool -- True <=> enabled
174
175 -- | Get a reference to a free variable at a breakpoint
176 GetBreakpointVar
177 :: HValueRef -- the AP_STACK from EvalBreak
178 -> Int
179 -> Message (Maybe HValueRef)
180
181 -- Template Haskell -------------------------------------------
182 -- For more details on how TH works with Remote GHCi, see
183 -- Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
184
185 -- | Start a new TH module, return a state token that should be
186 StartTH :: Message (RemoteRef (IORef QState))
187
188 -- | Evaluate a TH computation.
189 --
190 -- Returns a ByteString, because we have to force the result
191 -- before returning it to ensure there are no errors lurking
192 -- in it. The TH types don't have NFData instances, and even if
193 -- they did, we have to serialize the value anyway, so we might
194 -- as well serialize it to force it.
195 RunTH
196 :: RemoteRef (IORef QState)
197 -> HValueRef {- e.g. TH.Q TH.Exp -}
198 -> THResultType
199 -> Maybe TH.Loc
200 -> Message (QResult ByteString)
201
202 -- | Run the given mod finalizers.
203 RunModFinalizers :: RemoteRef (IORef QState)
204 -> [RemoteRef (TH.Q ())]
205 -> Message (QResult ())
206
207 -- | Remote interface to GHC.Exts.Heap.getClosureData. This is used by
208 -- the GHCi debugger to inspect values in the heap for :print and
209 -- type reconstruction.
210 GetClosure
211 :: HValueRef
212 -> Message (GenClosure HValueRef)
213
214 -- | Evaluate something. This is used to support :force in GHCi.
215 Seq
216 :: HValueRef
217 -> Message (EvalResult ())
218
219 deriving instance Show (Message a)
220
221
222 -- | Template Haskell return values
223 data QResult a
224 = QDone a
225 -- ^ RunTH finished successfully; return value follows
226 | QException String
227 -- ^ RunTH threw an exception
228 | QFail String
229 -- ^ RunTH called 'fail'
230 deriving (Generic, Show)
231
232 instance Binary a => Binary (QResult a)
233
234
235 -- | Messages sent back to GHC from GHCi.TH, to implement the methods
236 -- of 'Quasi'. For an overview of how TH works with Remote GHCi, see
237 -- Note [Remote Template Haskell] in GHCi.TH.
238 data THMessage a where
239 NewName :: String -> THMessage (THResult TH.Name)
240 Report :: Bool -> String -> THMessage (THResult ())
241 LookupName :: Bool -> String -> THMessage (THResult (Maybe TH.Name))
242 Reify :: TH.Name -> THMessage (THResult TH.Info)
243 ReifyFixity :: TH.Name -> THMessage (THResult (Maybe TH.Fixity))
244 ReifyInstances :: TH.Name -> [TH.Type] -> THMessage (THResult [TH.Dec])
245 ReifyRoles :: TH.Name -> THMessage (THResult [TH.Role])
246 ReifyAnnotations :: TH.AnnLookup -> TypeRep
247 -> THMessage (THResult [ByteString])
248 ReifyModule :: TH.Module -> THMessage (THResult TH.ModuleInfo)
249 ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness])
250
251 AddDependentFile :: FilePath -> THMessage (THResult ())
252 AddTempFile :: String -> THMessage (THResult FilePath)
253 AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())
254 AddCorePlugin :: String -> THMessage (THResult ())
255 AddTopDecls :: [TH.Dec] -> THMessage (THResult ())
256 AddForeignFilePath :: ForeignSrcLang -> FilePath -> THMessage (THResult ())
257 IsExtEnabled :: Extension -> THMessage (THResult Bool)
258 ExtsEnabled :: THMessage (THResult [Extension])
259
260 StartRecover :: THMessage ()
261 EndRecover :: Bool -> THMessage ()
262 FailIfErrs :: THMessage (THResult ())
263
264 -- | Indicates that this RunTH is finished, and the next message
265 -- will be the result of RunTH (a QResult).
266 RunTHDone :: THMessage ()
267
268 deriving instance Show (THMessage a)
269
270 data THMsg = forall a . (Binary a, Show a) => THMsg (THMessage a)
271
272 getTHMessage :: Get THMsg
273 getTHMessage = do
274 b <- getWord8
275 case b of
276 0 -> THMsg <$> NewName <$> get
277 1 -> THMsg <$> (Report <$> get <*> get)
278 2 -> THMsg <$> (LookupName <$> get <*> get)
279 3 -> THMsg <$> Reify <$> get
280 4 -> THMsg <$> ReifyFixity <$> get
281 5 -> THMsg <$> (ReifyInstances <$> get <*> get)
282 6 -> THMsg <$> ReifyRoles <$> get
283 7 -> THMsg <$> (ReifyAnnotations <$> get <*> get)
284 8 -> THMsg <$> ReifyModule <$> get
285 9 -> THMsg <$> ReifyConStrictness <$> get
286 10 -> THMsg <$> AddDependentFile <$> get
287 11 -> THMsg <$> AddTempFile <$> get
288 12 -> THMsg <$> AddTopDecls <$> get
289 13 -> THMsg <$> (IsExtEnabled <$> get)
290 14 -> THMsg <$> return ExtsEnabled
291 15 -> THMsg <$> return StartRecover
292 16 -> THMsg <$> EndRecover <$> get
293 17 -> THMsg <$> return FailIfErrs
294 18 -> return (THMsg RunTHDone)
295 19 -> THMsg <$> AddModFinalizer <$> get
296 20 -> THMsg <$> (AddForeignFilePath <$> get <*> get)
297 _ -> THMsg <$> AddCorePlugin <$> get
298
299 putTHMessage :: THMessage a -> Put
300 putTHMessage m = case m of
301 NewName a -> putWord8 0 >> put a
302 Report a b -> putWord8 1 >> put a >> put b
303 LookupName a b -> putWord8 2 >> put a >> put b
304 Reify a -> putWord8 3 >> put a
305 ReifyFixity a -> putWord8 4 >> put a
306 ReifyInstances a b -> putWord8 5 >> put a >> put b
307 ReifyRoles a -> putWord8 6 >> put a
308 ReifyAnnotations a b -> putWord8 7 >> put a >> put b
309 ReifyModule a -> putWord8 8 >> put a
310 ReifyConStrictness a -> putWord8 9 >> put a
311 AddDependentFile a -> putWord8 10 >> put a
312 AddTempFile a -> putWord8 11 >> put a
313 AddTopDecls a -> putWord8 12 >> put a
314 IsExtEnabled a -> putWord8 13 >> put a
315 ExtsEnabled -> putWord8 14
316 StartRecover -> putWord8 15
317 EndRecover a -> putWord8 16 >> put a
318 FailIfErrs -> putWord8 17
319 RunTHDone -> putWord8 18
320 AddModFinalizer a -> putWord8 19 >> put a
321 AddForeignFilePath lang a -> putWord8 20 >> put lang >> put a
322 AddCorePlugin a -> putWord8 21 >> put a
323
324
325 data EvalOpts = EvalOpts
326 { useSandboxThread :: Bool
327 , singleStep :: Bool
328 , breakOnException :: Bool
329 , breakOnError :: Bool
330 }
331 deriving (Generic, Show)
332
333 instance Binary EvalOpts
334
335 data ResumeContext a = ResumeContext
336 { resumeBreakMVar :: MVar ()
337 , resumeStatusMVar :: MVar (EvalStatus a)
338 , resumeThreadId :: ThreadId
339 }
340
341 -- | We can pass simple expressions to EvalStmt, consisting of values
342 -- and application. This allows us to wrap the statement to be
343 -- executed in another function, which is used by GHCi to implement
344 -- :set args and :set prog. It might be worthwhile to extend this
345 -- little language in the future.
346 data EvalExpr a
347 = EvalThis a
348 | EvalApp (EvalExpr a) (EvalExpr a)
349 deriving (Generic, Show)
350
351 instance Binary a => Binary (EvalExpr a)
352
353 type EvalStatus a = EvalStatus_ a a
354
355 data EvalStatus_ a b
356 = EvalComplete Word64 (EvalResult a)
357 | EvalBreak Bool
358 HValueRef{- AP_STACK -}
359 Int {- break index -}
360 Int {- uniq of ModuleName -}
361 (RemoteRef (ResumeContext b))
362 (RemotePtr CostCentreStack) -- Cost centre stack
363 deriving (Generic, Show)
364
365 instance Binary a => Binary (EvalStatus_ a b)
366
367 data EvalResult a
368 = EvalException SerializableException
369 | EvalSuccess a
370 deriving (Generic, Show)
371
372 instance Binary a => Binary (EvalResult a)
373
374 -- SomeException can't be serialized because it contains dynamic
375 -- types. However, we do very limited things with the exceptions that
376 -- are thrown by interpreted computations:
377 --
378 -- * We print them, e.g. "*** Exception: <something>"
379 -- * UserInterrupt has a special meaning
380 -- * In ghc -e, exitWith should exit with the appropriate exit code
381 --
382 -- So all we need to do is distinguish UserInterrupt and ExitCode, and
383 -- all other exceptions can be represented by their 'show' string.
384 --
385 data SerializableException
386 = EUserInterrupt
387 | EExitCode ExitCode
388 | EOtherException String
389 deriving (Generic, Show)
390
391 toSerializableException :: SomeException -> SerializableException
392 toSerializableException ex
393 | Just UserInterrupt <- fromException ex = EUserInterrupt
394 | Just (ec::ExitCode) <- fromException ex = (EExitCode ec)
395 | otherwise = EOtherException (show (ex :: SomeException))
396
397 fromSerializableException :: SerializableException -> SomeException
398 fromSerializableException EUserInterrupt = toException UserInterrupt
399 fromSerializableException (EExitCode c) = toException c
400 fromSerializableException (EOtherException str) = toException (ErrorCall str)
401
402 instance Binary ExitCode
403 instance Binary SerializableException
404
405 data THResult a
406 = THException String
407 | THComplete a
408 deriving (Generic, Show)
409
410 instance Binary a => Binary (THResult a)
411
412 data THResultType = THExp | THPat | THType | THDec | THAnnWrapper
413 deriving (Enum, Show, Generic)
414
415 instance Binary THResultType
416
417 -- | The server-side Template Haskell state. This is created by the
418 -- StartTH message. A new one is created per module that GHC
419 -- typechecks.
420 data QState = QState
421 { qsMap :: Map TypeRep Dynamic
422 -- ^ persistent data between splices in a module
423 , qsLocation :: Maybe TH.Loc
424 -- ^ location for current splice, if any
425 , qsPipe :: Pipe
426 -- ^ pipe to communicate with GHC
427 }
428 instance Show QState where show _ = "<QState>"
429
430 -- Orphan instances of Binary for Ptr / FunPtr by conversion to Word64.
431 -- This is to support Binary StgInfoTable which includes these.
432 instance Binary (Ptr a) where
433 put p = put (fromIntegral (ptrToWordPtr p) :: Word64)
434 get = (wordPtrToPtr . fromIntegral) <$> (get :: Get Word64)
435
436 instance Binary (FunPtr a) where
437 put = put . castFunPtrToPtr
438 get = castPtrToFunPtr <$> get
439
440 -- Binary instances to support the GetClosure message
441 instance Binary StgInfoTable
442 instance Binary ClosureType
443 instance Binary PrimType
444 instance Binary a => Binary (GenClosure a)
445
446 data Msg = forall a . (Binary a, Show a) => Msg (Message a)
447
448 getMessage :: Get Msg
449 getMessage = do
450 b <- getWord8
451 case b of
452 0 -> Msg <$> return Shutdown
453 1 -> Msg <$> return InitLinker
454 2 -> Msg <$> LookupSymbol <$> get
455 3 -> Msg <$> LookupClosure <$> get
456 4 -> Msg <$> LoadDLL <$> get
457 5 -> Msg <$> LoadArchive <$> get
458 6 -> Msg <$> LoadObj <$> get
459 7 -> Msg <$> UnloadObj <$> get
460 8 -> Msg <$> AddLibrarySearchPath <$> get
461 9 -> Msg <$> RemoveLibrarySearchPath <$> get
462 10 -> Msg <$> return ResolveObjs
463 11 -> Msg <$> FindSystemLibrary <$> get
464 12 -> Msg <$> CreateBCOs <$> get
465 13 -> Msg <$> FreeHValueRefs <$> get
466 14 -> Msg <$> MallocData <$> get
467 15 -> Msg <$> MallocStrings <$> get
468 16 -> Msg <$> (PrepFFI <$> get <*> get <*> get)
469 17 -> Msg <$> FreeFFI <$> get
470 18 -> Msg <$> (MkConInfoTable <$> get <*> get <*> get <*> get <*> get)
471 19 -> Msg <$> (EvalStmt <$> get <*> get)
472 20 -> Msg <$> (ResumeStmt <$> get <*> get)
473 21 -> Msg <$> (AbandonStmt <$> get)
474 22 -> Msg <$> (EvalString <$> get)
475 23 -> Msg <$> (EvalStringToString <$> get <*> get)
476 24 -> Msg <$> (EvalIO <$> get)
477 25 -> Msg <$> (MkCostCentres <$> get <*> get)
478 26 -> Msg <$> (CostCentreStackInfo <$> get)
479 27 -> Msg <$> (NewBreakArray <$> get)
480 28 -> Msg <$> (EnableBreakpoint <$> get <*> get <*> get)
481 29 -> Msg <$> (BreakpointStatus <$> get <*> get)
482 30 -> Msg <$> (GetBreakpointVar <$> get <*> get)
483 31 -> Msg <$> return StartTH
484 32 -> Msg <$> (RunModFinalizers <$> get <*> get)
485 33 -> Msg <$> (AddSptEntry <$> get <*> get)
486 34 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
487 35 -> Msg <$> (GetClosure <$> get)
488 _ -> Msg <$> (Seq <$> get)
489
490 putMessage :: Message a -> Put
491 putMessage m = case m of
492 Shutdown -> putWord8 0
493 InitLinker -> putWord8 1
494 LookupSymbol str -> putWord8 2 >> put str
495 LookupClosure str -> putWord8 3 >> put str
496 LoadDLL str -> putWord8 4 >> put str
497 LoadArchive str -> putWord8 5 >> put str
498 LoadObj str -> putWord8 6 >> put str
499 UnloadObj str -> putWord8 7 >> put str
500 AddLibrarySearchPath str -> putWord8 8 >> put str
501 RemoveLibrarySearchPath ptr -> putWord8 9 >> put ptr
502 ResolveObjs -> putWord8 10
503 FindSystemLibrary str -> putWord8 11 >> put str
504 CreateBCOs bco -> putWord8 12 >> put bco
505 FreeHValueRefs val -> putWord8 13 >> put val
506 MallocData bs -> putWord8 14 >> put bs
507 MallocStrings bss -> putWord8 15 >> put bss
508 PrepFFI conv args res -> putWord8 16 >> put conv >> put args >> put res
509 FreeFFI p -> putWord8 17 >> put p
510 MkConInfoTable p n t pt d -> putWord8 18 >> put p >> put n >> put t >> put pt >> put d
511 EvalStmt opts val -> putWord8 19 >> put opts >> put val
512 ResumeStmt opts val -> putWord8 20 >> put opts >> put val
513 AbandonStmt val -> putWord8 21 >> put val
514 EvalString val -> putWord8 22 >> put val
515 EvalStringToString str val -> putWord8 23 >> put str >> put val
516 EvalIO val -> putWord8 24 >> put val
517 MkCostCentres mod ccs -> putWord8 25 >> put mod >> put ccs
518 CostCentreStackInfo ptr -> putWord8 26 >> put ptr
519 NewBreakArray sz -> putWord8 27 >> put sz
520 EnableBreakpoint arr ix b -> putWord8 28 >> put arr >> put ix >> put b
521 BreakpointStatus arr ix -> putWord8 29 >> put arr >> put ix
522 GetBreakpointVar a b -> putWord8 30 >> put a >> put b
523 StartTH -> putWord8 31
524 RunModFinalizers a b -> putWord8 32 >> put a >> put b
525 AddSptEntry a b -> putWord8 33 >> put a >> put b
526 RunTH st q loc ty -> putWord8 34 >> put st >> put q >> put loc >> put ty
527 GetClosure a -> putWord8 35 >> put a
528 Seq a -> putWord8 36 >> put a
529
530 -- -----------------------------------------------------------------------------
531 -- Reading/writing messages
532
533 data Pipe = Pipe
534 { pipeRead :: Handle
535 , pipeWrite :: Handle
536 , pipeLeftovers :: IORef (Maybe ByteString)
537 }
538
539 remoteCall :: Binary a => Pipe -> Message a -> IO a
540 remoteCall pipe msg = do
541 writePipe pipe (putMessage msg)
542 readPipe pipe get
543
544 remoteTHCall :: Binary a => Pipe -> THMessage a -> IO a
545 remoteTHCall pipe msg = do
546 writePipe pipe (putTHMessage msg)
547 readPipe pipe get
548
549 writePipe :: Pipe -> Put -> IO ()
550 writePipe Pipe{..} put
551 | LB.null bs = return ()
552 | otherwise = do
553 LB.hPut pipeWrite bs
554 hFlush pipeWrite
555 where
556 bs = runPut put
557
558 readPipe :: Pipe -> Get a -> IO a
559 readPipe Pipe{..} get = do
560 leftovers <- readIORef pipeLeftovers
561 m <- getBin pipeRead get leftovers
562 case m of
563 Nothing -> throw $
564 mkIOError eofErrorType "GHCi.Message.remoteCall" (Just pipeRead) Nothing
565 Just (result, new_leftovers) -> do
566 writeIORef pipeLeftovers new_leftovers
567 return result
568
569 getBin
570 :: Handle -> Get a -> Maybe ByteString
571 -> IO (Maybe (a, Maybe ByteString))
572
573 getBin h get leftover = go leftover (runGetIncremental get)
574 where
575 go Nothing (Done leftover _ msg) =
576 return (Just (msg, if B.null leftover then Nothing else Just leftover))
577 go _ Done{} = throwIO (ErrorCall "getBin: Done with leftovers")
578 go (Just leftover) (Partial fun) = do
579 go Nothing (fun (Just leftover))
580 go Nothing (Partial fun) = do
581 -- putStrLn "before hGetSome"
582 b <- B.hGetSome h (32*1024)
583 -- printf "hGetSome: %d\n" (B.length b)
584 if B.null b
585 then return Nothing
586 else go Nothing (fun (Just b))
587 go _lft (Fail _rest _off str) =
588 throwIO (ErrorCall ("getBin: " ++ str))