{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeOperators #-}

module GHC.Debug.Types(module T
                      , Request(..)
                      , ForkOrPause(..)
                      , requestCommandId
                      , doRequest
                      , isWriteRequest
                      , withWriteRequest
                      , isImmutableRequest
                      , AnyReq(..)
                      , AnyResp(..)
                      , CommandId(..)
                      , SourceInformation(..)
                      , ClosureType(..)
                      , Version(..)

                      -- * Serialisation functions
                      , getIPE
                      , putIPE
                      , getInfoTable
                      , putInfoTable
                      , putRequest
                      , getRequest ) where

import Control.Applicative
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import Data.Word
import System.IO
import Data.Functor

import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import Data.Hashable

import GHC.Debug.Types.Closures as T
import GHC.Debug.Types.Ptr as T
import GHC.Debug.Types.Version
import GHC.Debug.Utils
import GHC.Debug.Decode
import Control.Concurrent

-- | The decision about whether to fork the running process or
-- pause it running whilst we are debugging it.
data ForkOrPause = Pause | Fork deriving (ForkOrPause -> ForkOrPause -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ForkOrPause -> ForkOrPause -> Bool
$c/= :: ForkOrPause -> ForkOrPause -> Bool
== :: ForkOrPause -> ForkOrPause -> Bool
$c== :: ForkOrPause -> ForkOrPause -> Bool
Eq, Eq ForkOrPause
ForkOrPause -> ForkOrPause -> Bool
ForkOrPause -> ForkOrPause -> Ordering
ForkOrPause -> ForkOrPause -> ForkOrPause
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ForkOrPause -> ForkOrPause -> ForkOrPause
$cmin :: ForkOrPause -> ForkOrPause -> ForkOrPause
max :: ForkOrPause -> ForkOrPause -> ForkOrPause
$cmax :: ForkOrPause -> ForkOrPause -> ForkOrPause
>= :: ForkOrPause -> ForkOrPause -> Bool
$c>= :: ForkOrPause -> ForkOrPause -> Bool
> :: ForkOrPause -> ForkOrPause -> Bool
$c> :: ForkOrPause -> ForkOrPause -> Bool
<= :: ForkOrPause -> ForkOrPause -> Bool
$c<= :: ForkOrPause -> ForkOrPause -> Bool
< :: ForkOrPause -> ForkOrPause -> Bool
$c< :: ForkOrPause -> ForkOrPause -> Bool
compare :: ForkOrPause -> ForkOrPause -> Ordering
$ccompare :: ForkOrPause -> ForkOrPause -> Ordering
Ord, Int -> ForkOrPause -> ShowS
[ForkOrPause] -> ShowS
ForkOrPause -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ForkOrPause] -> ShowS
$cshowList :: [ForkOrPause] -> ShowS
show :: ForkOrPause -> String
$cshow :: ForkOrPause -> String
showsPrec :: Int -> ForkOrPause -> ShowS
$cshowsPrec :: Int -> ForkOrPause -> ShowS
Show, Int -> ForkOrPause
ForkOrPause -> Int
ForkOrPause -> [ForkOrPause]
ForkOrPause -> ForkOrPause
ForkOrPause -> ForkOrPause -> [ForkOrPause]
ForkOrPause -> ForkOrPause -> ForkOrPause -> [ForkOrPause]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ForkOrPause -> ForkOrPause -> ForkOrPause -> [ForkOrPause]
$cenumFromThenTo :: ForkOrPause -> ForkOrPause -> ForkOrPause -> [ForkOrPause]
enumFromTo :: ForkOrPause -> ForkOrPause -> [ForkOrPause]
$cenumFromTo :: ForkOrPause -> ForkOrPause -> [ForkOrPause]
enumFromThen :: ForkOrPause -> ForkOrPause -> [ForkOrPause]
$cenumFromThen :: ForkOrPause -> ForkOrPause -> [ForkOrPause]
enumFrom :: ForkOrPause -> [ForkOrPause]
$cenumFrom :: ForkOrPause -> [ForkOrPause]
fromEnum :: ForkOrPause -> Int
$cfromEnum :: ForkOrPause -> Int
toEnum :: Int -> ForkOrPause
$ctoEnum :: Int -> ForkOrPause
pred :: ForkOrPause -> ForkOrPause
$cpred :: ForkOrPause -> ForkOrPause
succ :: ForkOrPause -> ForkOrPause
$csucc :: ForkOrPause -> ForkOrPause
Enum)

instance Hashable ForkOrPause where
  hashWithSalt :: Int -> ForkOrPause -> Int
hashWithSalt Int
s ForkOrPause
v = Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (forall a. Enum a => a -> Int
fromEnum ForkOrPause
v)

instance Binary ForkOrPause where
  put :: ForkOrPause -> Put
put     = Word8 -> Put
putWord8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum
  get :: Get ForkOrPause
get     = Get Word8
getWord8 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a} {m :: * -> *} {a}.
(Eq a, Num a, Enum a, MonadFail m, Show a) =>
a -> m a
toBool
    where
      toBool :: a -> m a
toBool a
0 = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Enum a => Int -> a
toEnum Int
0)
      toBool a
1 = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Enum a => Int -> a
toEnum Int
1)
      toBool a
c = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Could not map value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
c forall a. [a] -> [a] -> [a]
++ String
" to ForkOrPause")


-- | A request sent from the debugger to the debuggee parametrized on the result type.
data Request a where
    -- | Request protocol version
    RequestVersion :: Request Version
    -- | Pause the debuggee.
    RequestPause :: ForkOrPause -> Request ()
    -- | Resume the debuggee.
    RequestResume :: Request ()
    -- | Request the debuggee's root pointers.
    RequestRoots :: Request [ClosurePtr]
    -- | Request a closure
    RequestClosure :: ClosurePtr -> Request RawClosure
    -- | Request an info table
    RequestInfoTable :: InfoTablePtr -> Request (StgInfoTableWithPtr, RawInfoTable)

    -- | Request the SRT of an info table. Some closures, like constructors, can never have SRTs.
    -- Thunks, functions and stack frames may have SRTs.
    -- Returns Nothing when the closure does not have an SRT.
    RequestSRT :: InfoTablePtr -> Request (Maybe ClosurePtr)

    -- | Wait for the debuggee to pause itself and then
    -- execute an action. It currently impossible to resume after
    -- a pause caused by a poll.
    RequestPoll :: Request ()
    -- | A client can save objects by calling a special RTS method
    -- This function returns the closures it saved.
    RequestSavedObjects :: Request [ClosurePtr]
    -- | Request the pointer bitmap for a stack frame at a given offset
    -- from a StackPtr.
    RequestStackBitmap :: StackPtr -> Word32 -> Request PtrBitmap
    -- | Decode the bitmap contained in a StgFunInfoTable
    -- Used by PAP and AP closure types.
    RequestFunBitmap :: Word16 -> ClosurePtr -> Request PtrBitmap
    -- | Request the constructor description for an info table.
    -- The info table must be from a 'ConstrClosure'
    RequestConstrDesc :: InfoTablePtr -> Request ConstrDesc
    -- | Lookup source information of an info table
    RequestSourceInfo :: InfoTablePtr -> Request (Maybe SourceInformation)
    -- | Copy all blocks from the process at once
    RequestAllBlocks :: Request [RawBlock]
    -- | Request the block which contains a specific pointer
    RequestBlock :: ClosurePtr -> Request RawBlock

data SourceInformation = SourceInformation { SourceInformation -> String
infoName        :: !String
                                         , SourceInformation -> ClosureType
infoClosureType :: !ClosureType
                                         , SourceInformation -> String
infoType        :: !String
                                         , SourceInformation -> String
infoLabel       :: !String
                                         , SourceInformation -> String
infoModule      :: !String
                                         , SourceInformation -> String
infoPosition    :: !String }
                                         deriving (Int -> SourceInformation -> ShowS
[SourceInformation] -> ShowS
SourceInformation -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SourceInformation] -> ShowS
$cshowList :: [SourceInformation] -> ShowS
show :: SourceInformation -> String
$cshow :: SourceInformation -> String
showsPrec :: Int -> SourceInformation -> ShowS
$cshowsPrec :: Int -> SourceInformation -> ShowS
Show, SourceInformation -> SourceInformation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SourceInformation -> SourceInformation -> Bool
$c/= :: SourceInformation -> SourceInformation -> Bool
== :: SourceInformation -> SourceInformation -> Bool
$c== :: SourceInformation -> SourceInformation -> Bool
Eq, Eq SourceInformation
SourceInformation -> SourceInformation -> Bool
SourceInformation -> SourceInformation -> Ordering
SourceInformation -> SourceInformation -> SourceInformation
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SourceInformation -> SourceInformation -> SourceInformation
$cmin :: SourceInformation -> SourceInformation -> SourceInformation
max :: SourceInformation -> SourceInformation -> SourceInformation
$cmax :: SourceInformation -> SourceInformation -> SourceInformation
>= :: SourceInformation -> SourceInformation -> Bool
$c>= :: SourceInformation -> SourceInformation -> Bool
> :: SourceInformation -> SourceInformation -> Bool
$c> :: SourceInformation -> SourceInformation -> Bool
<= :: SourceInformation -> SourceInformation -> Bool
$c<= :: SourceInformation -> SourceInformation -> Bool
< :: SourceInformation -> SourceInformation -> Bool
$c< :: SourceInformation -> SourceInformation -> Bool
compare :: SourceInformation -> SourceInformation -> Ordering
$ccompare :: SourceInformation -> SourceInformation -> Ordering
Ord)

eq1request :: Request a -> Request b -> Bool
eq1request :: forall a b. Request a -> Request b -> Bool
eq1request Request a
r1 Request b
r2 =
  case Request a
r1 of
    Request a
RequestVersion -> case Request b
r2 of {Request b
RequestVersion -> Bool
True; Request b
_ -> Bool
False}
    RequestPause ForkOrPause
f1 -> case Request b
r2 of {RequestPause ForkOrPause
f2 -> ForkOrPause
f1 forall a. Eq a => a -> a -> Bool
== ForkOrPause
f2; Request b
_ -> Bool
False }
    Request a
RequestResume  -> case Request b
r2 of {Request b
RequestResume -> Bool
True; Request b
_ -> Bool
False }
    Request a
RequestRoots   -> case Request b
r2 of {Request b
RequestRoots -> Bool
True; Request b
_ -> Bool
False }
    RequestClosure ClosurePtr
cs -> case Request b
r2 of {(RequestClosure ClosurePtr
cs') -> ClosurePtr
cs forall a. Eq a => a -> a -> Bool
== ClosurePtr
cs'; Request b
_ -> Bool
False }
    RequestInfoTable InfoTablePtr
itp -> case Request b
r2 of { (RequestInfoTable InfoTablePtr
itp') ->  InfoTablePtr
itp forall a. Eq a => a -> a -> Bool
== InfoTablePtr
itp'; Request b
_ -> Bool
False }
    RequestSRT InfoTablePtr
itp -> case Request b
r2 of { (RequestSRT InfoTablePtr
itp') ->  InfoTablePtr
itp forall a. Eq a => a -> a -> Bool
== InfoTablePtr
itp'; Request b
_ -> Bool
False }
    Request a
RequestPoll           -> case Request b
r2 of { Request b
RequestPoll -> Bool
True; Request b
_ -> Bool
False }
    Request a
RequestSavedObjects    -> case Request b
r2 of {Request b
RequestSavedObjects -> Bool
True; Request b
_ -> Bool
False }
    RequestStackBitmap StackPtr
p Word32
o      -> case Request b
r2 of {(RequestStackBitmap StackPtr
p' Word32
o') -> StackPtr
p forall a. Eq a => a -> a -> Bool
== StackPtr
p' Bool -> Bool -> Bool
&& Word32
o forall a. Eq a => a -> a -> Bool
== Word32
o'; Request b
_ -> Bool
False }
    RequestFunBitmap Word16
n ClosurePtr
cp    -> case Request b
r2 of {(RequestFunBitmap Word16
n' ClosurePtr
cp') -> Word16
n forall a. Eq a => a -> a -> Bool
== Word16
n' Bool -> Bool -> Bool
&& ClosurePtr
cp forall a. Eq a => a -> a -> Bool
== ClosurePtr
cp'; Request b
_ -> Bool
False }
    RequestConstrDesc InfoTablePtr
cp   -> case Request b
r2 of { (RequestConstrDesc InfoTablePtr
cp') -> InfoTablePtr
cp forall a. Eq a => a -> a -> Bool
== InfoTablePtr
cp'; Request b
_ -> Bool
False }
    RequestSourceInfo InfoTablePtr
itp  -> case Request b
r2 of { (RequestSourceInfo InfoTablePtr
itp') -> InfoTablePtr
itp forall a. Eq a => a -> a -> Bool
== InfoTablePtr
itp'; Request b
_ -> Bool
False }
    Request a
RequestAllBlocks       -> case Request b
r2 of { Request b
RequestAllBlocks -> Bool
True; Request b
_ -> Bool
False }
    RequestBlock ClosurePtr
cp        -> case Request b
r2 of { RequestBlock ClosurePtr
cp' -> ClosurePtr
cp forall a. Eq a => a -> a -> Bool
== ClosurePtr
cp'; Request b
_ -> Bool
False }

-- | Whether a request mutates the debuggee state, don't cache these ones
isWriteRequest :: Request a -> Bool
isWriteRequest :: forall a. Request a -> Bool
isWriteRequest Request a
r = forall {k} a (b :: k). Const a b -> a
getConst forall a b. (a -> b) -> a -> b
$ forall a (r :: * -> *).
Request a -> r a -> ((a ~ ()) => Request a -> r a) -> r a
withWriteRequest Request a
r (forall {k} a (b :: k). a -> Const a b
Const Bool
False) (forall a b. a -> b -> a
const (forall {k} a (b :: k). a -> Const a b
Const Bool
True))

withWriteRequest :: Request a -> r a -> ((a ~ ()) => Request a -> r a) -> r a
withWriteRequest :: forall a (r :: * -> *).
Request a -> r a -> ((a ~ ()) => Request a -> r a) -> r a
withWriteRequest Request a
r r a
def (a ~ ()) => Request a -> r a
k =
  case Request a
r of
    RequestPause ForkOrPause
f -> (a ~ ()) => Request a -> r a
k (ForkOrPause -> Request ()
RequestPause ForkOrPause
f)
    Request a
RequestResume -> (a ~ ()) => Request a -> r a
k Request ()
RequestResume
    Request a
RequestPoll -> (a ~ ()) => Request a -> r a
k Request ()
RequestPoll
    Request a
_ -> r a
def

-- | Requests which will always answer the same.
-- For example, info tables are immutable and so requesting an info table
-- will always result in the same value and is safe to cache across pause
-- lines.
isImmutableRequest :: Request a -> Bool
isImmutableRequest :: forall a. Request a -> Bool
isImmutableRequest Request a
r =
  case Request a
r of
    RequestVersion {} -> Bool
True
    RequestInfoTable {} -> Bool
True
    RequestSRT {} -> Bool
True
    RequestSourceInfo {} -> Bool
True
    RequestConstrDesc {} -> Bool
True
    Request a
_ -> Bool
False


deriving instance Show (Request a)
deriving instance Eq (Request a)

instance Hashable (Request a) where
  hashWithSalt :: Int -> Request a -> Int
hashWithSalt Int
s Request a
r = case Request a
r of
    Request a
RequestVersion ->  Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestVersion
    RequestPause ForkOrPause
f ->  Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` ForkOrPause
f forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestPause
    Request a
RequestResume  ->  Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestResume
    Request a
RequestRoots   -> Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestRoots
    RequestClosure ClosurePtr
cs -> Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestClosures forall a. Hashable a => Int -> a -> Int
`hashWithSalt` ClosurePtr
cs
    RequestInfoTable InfoTablePtr
itp -> Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestInfoTables forall a. Hashable a => Int -> a -> Int
`hashWithSalt` InfoTablePtr
itp
    RequestSRT InfoTablePtr
itp        -> Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestSRT forall a. Hashable a => Int -> a -> Int
`hashWithSalt` InfoTablePtr
itp
    Request a
RequestPoll           -> Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestPoll
    Request a
RequestSavedObjects    -> Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestSavedObjects
    RequestStackBitmap StackPtr
p Word32
o -> Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestStackBitmap forall a. Hashable a => Int -> a -> Int
`hashWithSalt` StackPtr
p forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word32
o
    RequestFunBitmap Word16
n ClosurePtr
cp  -> Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestFunBitmap forall a. Hashable a => Int -> a -> Int
`hashWithSalt` ClosurePtr
cp forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word16
n
    RequestConstrDesc InfoTablePtr
cp   -> Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestConstrDesc forall a. Hashable a => Int -> a -> Int
`hashWithSalt` InfoTablePtr
cp
    RequestSourceInfo InfoTablePtr
itp  -> Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestSourceInfo forall a. Hashable a => Int -> a -> Int
`hashWithSalt` InfoTablePtr
itp
    Request a
RequestAllBlocks       -> Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestAllBlocks
    RequestBlock ClosurePtr
cp        -> Int
s forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestBlock forall a. Hashable a => Int -> a -> Int
`hashWithSalt` ClosurePtr
cp


newtype CommandId = CommandId Word32
                  deriving (CommandId -> CommandId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommandId -> CommandId -> Bool
$c/= :: CommandId -> CommandId -> Bool
== :: CommandId -> CommandId -> Bool
$c== :: CommandId -> CommandId -> Bool
Eq, Eq CommandId
CommandId -> CommandId -> Bool
CommandId -> CommandId -> Ordering
CommandId -> CommandId -> CommandId
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CommandId -> CommandId -> CommandId
$cmin :: CommandId -> CommandId -> CommandId
max :: CommandId -> CommandId -> CommandId
$cmax :: CommandId -> CommandId -> CommandId
>= :: CommandId -> CommandId -> Bool
$c>= :: CommandId -> CommandId -> Bool
> :: CommandId -> CommandId -> Bool
$c> :: CommandId -> CommandId -> Bool
<= :: CommandId -> CommandId -> Bool
$c<= :: CommandId -> CommandId -> Bool
< :: CommandId -> CommandId -> Bool
$c< :: CommandId -> CommandId -> Bool
compare :: CommandId -> CommandId -> Ordering
$ccompare :: CommandId -> CommandId -> Ordering
Ord, Int -> CommandId -> ShowS
[CommandId] -> ShowS
CommandId -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommandId] -> ShowS
$cshowList :: [CommandId] -> ShowS
show :: CommandId -> String
$cshow :: CommandId -> String
showsPrec :: Int -> CommandId -> ShowS
$cshowsPrec :: Int -> CommandId -> ShowS
Show)
                  deriving newtype (Get CommandId
[CommandId] -> Put
CommandId -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [CommandId] -> Put
$cputList :: [CommandId] -> Put
get :: Get CommandId
$cget :: Get CommandId
put :: CommandId -> Put
$cput :: CommandId -> Put
Binary, Eq CommandId
Int -> CommandId -> Int
CommandId -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: CommandId -> Int
$chash :: CommandId -> Int
hashWithSalt :: Int -> CommandId -> Int
$chashWithSalt :: Int -> CommandId -> Int
Hashable)

requestCommandId :: Request a -> CommandId
requestCommandId :: forall a. Request a -> CommandId
requestCommandId Request a
r = case Request a
r of
    RequestVersion {} -> CommandId
cmdRequestVersion
    RequestPause {}   -> CommandId
cmdRequestPause
    RequestResume {}  -> CommandId
cmdRequestResume
    RequestRoots {}   -> CommandId
cmdRequestRoots
    RequestClosure {}  -> CommandId
cmdRequestClosures
    RequestInfoTable {}  -> CommandId
cmdRequestInfoTables
    RequestSRT {}        -> CommandId
cmdRequestSRT
    RequestPoll {}         -> CommandId
cmdRequestPoll
    RequestSavedObjects {} -> CommandId
cmdRequestSavedObjects
    RequestStackBitmap {}       -> CommandId
cmdRequestStackBitmap
    RequestFunBitmap {}       -> CommandId
cmdRequestFunBitmap
    RequestConstrDesc {}   -> CommandId
cmdRequestConstrDesc
    RequestSourceInfo {}   -> CommandId
cmdRequestSourceInfo
    RequestAllBlocks {} -> CommandId
cmdRequestAllBlocks
    RequestBlock {} -> CommandId
cmdRequestBlock

cmdRequestVersion :: CommandId
cmdRequestVersion :: CommandId
cmdRequestVersion = Word32 -> CommandId
CommandId Word32
1

cmdRequestPause :: CommandId
cmdRequestPause :: CommandId
cmdRequestPause = Word32 -> CommandId
CommandId Word32
2

cmdRequestResume :: CommandId
cmdRequestResume :: CommandId
cmdRequestResume = Word32 -> CommandId
CommandId Word32
3

cmdRequestRoots :: CommandId
cmdRequestRoots :: CommandId
cmdRequestRoots = Word32 -> CommandId
CommandId Word32
4

cmdRequestClosures :: CommandId
cmdRequestClosures :: CommandId
cmdRequestClosures = Word32 -> CommandId
CommandId Word32
5

cmdRequestInfoTables :: CommandId
cmdRequestInfoTables :: CommandId
cmdRequestInfoTables = Word32 -> CommandId
CommandId Word32
6

cmdRequestStackBitmap :: CommandId
cmdRequestStackBitmap :: CommandId
cmdRequestStackBitmap = Word32 -> CommandId
CommandId Word32
7

cmdRequestPoll :: CommandId
cmdRequestPoll :: CommandId
cmdRequestPoll = Word32 -> CommandId
CommandId Word32
8

cmdRequestSavedObjects :: CommandId
cmdRequestSavedObjects :: CommandId
cmdRequestSavedObjects = Word32 -> CommandId
CommandId Word32
9

cmdRequestConstrDesc :: CommandId
cmdRequestConstrDesc :: CommandId
cmdRequestConstrDesc = Word32 -> CommandId
CommandId Word32
11

cmdRequestSourceInfo :: CommandId
cmdRequestSourceInfo :: CommandId
cmdRequestSourceInfo = Word32 -> CommandId
CommandId Word32
12

cmdRequestAllBlocks :: CommandId
cmdRequestAllBlocks :: CommandId
cmdRequestAllBlocks = Word32 -> CommandId
CommandId Word32
14

cmdRequestBlock :: CommandId
cmdRequestBlock :: CommandId
cmdRequestBlock = Word32 -> CommandId
CommandId Word32
15

cmdRequestFunBitmap :: CommandId
cmdRequestFunBitmap :: CommandId
cmdRequestFunBitmap = Word32 -> CommandId
CommandId Word32
16

cmdRequestSRT :: CommandId
cmdRequestSRT :: CommandId
cmdRequestSRT  = Word32 -> CommandId
CommandId Word32
17

data AnyReq = forall req . AnyReq !(Request req)

instance Hashable AnyReq where
  hashWithSalt :: Int -> AnyReq -> Int
hashWithSalt Int
s (AnyReq Request req
r) = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s Request req
r

instance Eq AnyReq where
  (AnyReq Request req
r1) == :: AnyReq -> AnyReq -> Bool
== (AnyReq Request req
r2) = forall a b. Request a -> Request b -> Bool
eq1request Request req
r1 Request req
r2

data AnyResp = forall a . AnyResp !a !(a -> Put)

putCommand :: CommandId -> Put -> Put
putCommand :: CommandId -> Put -> Put
putCommand CommandId
c Put
body = do
    Word32 -> Put
putWord32be forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
4 forall a. Num a => a -> a -> a
+ ByteString -> Int64
BSL.length ByteString
body')
    forall t. Binary t => t -> Put
put CommandId
c
    ByteString -> Put
putLazyByteString ByteString
body'
  where
    body' :: ByteString
body' = Put -> ByteString
runPut Put
body

putRequest :: Request a -> Put
putRequest :: forall a. Request a -> Put
putRequest Request a
RequestVersion        = CommandId -> Put -> Put
putCommand CommandId
cmdRequestVersion forall a. Monoid a => a
mempty
putRequest (RequestPause ForkOrPause
p)      = CommandId -> Put -> Put
putCommand CommandId
cmdRequestPause (forall t. Binary t => t -> Put
put ForkOrPause
p)
putRequest Request a
RequestResume         = CommandId -> Put -> Put
putCommand CommandId
cmdRequestResume forall a. Monoid a => a
mempty
putRequest Request a
RequestRoots          = CommandId -> Put -> Put
putCommand CommandId
cmdRequestRoots forall a. Monoid a => a
mempty
putRequest (RequestClosure ClosurePtr
cs)  =
  CommandId -> Put -> Put
putCommand CommandId
cmdRequestClosures forall a b. (a -> b) -> a -> b
$ do
    Word16 -> Put
putWord16be Word16
1
    forall t. Binary t => t -> Put
put ClosurePtr
cs
putRequest (RequestInfoTable InfoTablePtr
ts) =
  CommandId -> Put -> Put
putCommand CommandId
cmdRequestInfoTables forall a b. (a -> b) -> a -> b
$ do
    Word16 -> Put
putWord16be Word16
1
    forall t. Binary t => t -> Put
put InfoTablePtr
ts
putRequest (RequestSRT InfoTablePtr
ts) =
  CommandId -> Put -> Put
putCommand CommandId
cmdRequestSRT forall a b. (a -> b) -> a -> b
$ do
    Word16 -> Put
putWord16be Word16
1
    forall t. Binary t => t -> Put
put InfoTablePtr
ts
putRequest (RequestStackBitmap StackPtr
sp Word32
o)       =
  CommandId -> Put -> Put
putCommand CommandId
cmdRequestStackBitmap forall a b. (a -> b) -> a -> b
$ forall t. Binary t => t -> Put
put StackPtr
sp forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
putWord32be Word32
o
putRequest (RequestFunBitmap Word16
n ClosurePtr
cp)       =
  CommandId -> Put -> Put
putCommand CommandId
cmdRequestFunBitmap forall a b. (a -> b) -> a -> b
$ forall t. Binary t => t -> Put
put ClosurePtr
cp forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be Word16
n
putRequest (RequestConstrDesc InfoTablePtr
itb) =
  CommandId -> Put -> Put
putCommand CommandId
cmdRequestConstrDesc forall a b. (a -> b) -> a -> b
$ forall t. Binary t => t -> Put
put InfoTablePtr
itb
putRequest Request a
RequestPoll           = CommandId -> Put -> Put
putCommand CommandId
cmdRequestPoll forall a. Monoid a => a
mempty
putRequest Request a
RequestSavedObjects   = CommandId -> Put -> Put
putCommand CommandId
cmdRequestSavedObjects forall a. Monoid a => a
mempty
--putRequest (RequestFindPtr c)       =
--  putCommand cmdRequestFindPtr $ put c
putRequest (RequestSourceInfo InfoTablePtr
it) = CommandId -> Put -> Put
putCommand CommandId
cmdRequestSourceInfo forall a b. (a -> b) -> a -> b
$ forall t. Binary t => t -> Put
put InfoTablePtr
it
putRequest (Request a
RequestAllBlocks) = CommandId -> Put -> Put
putCommand CommandId
cmdRequestAllBlocks forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
putRequest (RequestBlock ClosurePtr
cp)  = CommandId -> Put -> Put
putCommand CommandId
cmdRequestBlock forall a b. (a -> b) -> a -> b
$ forall t. Binary t => t -> Put
put ClosurePtr
cp

-- This is used to serialise the RequestCache
getRequest :: Get AnyReq
getRequest :: Get AnyReq
getRequest = do
  Word32
len <- Get Word32
getWord32be
  forall a. Int -> Get a -> Get a
isolate (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len) forall a b. (a -> b) -> a -> b
$ do
    CommandId
cmd <- forall t. Binary t => Get t
get
    if
      | CommandId
cmd forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestVersion -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall req. Request req -> AnyReq
AnyReq Request Version
RequestVersion)
      | CommandId
cmd forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestPause   -> do
          ForkOrPause
b <- forall t. Binary t => Get t
get
          return (forall req. Request req -> AnyReq
AnyReq (ForkOrPause -> Request ()
RequestPause ForkOrPause
b))
      | CommandId
cmd forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestResume  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall req. Request req -> AnyReq
AnyReq Request ()
RequestResume)
      | CommandId
cmd forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestRoots   -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall req. Request req -> AnyReq
AnyReq Request [ClosurePtr]
RequestRoots)
      | CommandId
cmd forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestClosures -> do
          Word16
_n <- Get Word16
getWord16be
--          cs <- replicateM (fromIntegral n) get
          ClosurePtr
cp <- forall t. Binary t => Get t
get
          return (forall req. Request req -> AnyReq
AnyReq (ClosurePtr -> Request RawClosure
RequestClosure ClosurePtr
cp))
      | CommandId
cmd forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestInfoTables -> do
          Word16
_n <- Get Word16
getWord16be
          --itbs <- replicateM (fromIntegral n) get
          InfoTablePtr
itb <- forall t. Binary t => Get t
get
          return (forall req. Request req -> AnyReq
AnyReq (InfoTablePtr -> Request (StgInfoTableWithPtr, RawInfoTable)
RequestInfoTable InfoTablePtr
itb))
      | CommandId
cmd forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestSRT -> do
          Word16
_n <- Get Word16
getWord16be
          InfoTablePtr
itb <- forall t. Binary t => Get t
get
          return (forall req. Request req -> AnyReq
AnyReq (InfoTablePtr -> Request (Maybe ClosurePtr)
RequestSRT InfoTablePtr
itb))
      | CommandId
cmd forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestStackBitmap -> do
          StackPtr
sp <- forall t. Binary t => Get t
get
          Word32
o  <- Get Word32
getWord32be
          return (forall req. Request req -> AnyReq
AnyReq (StackPtr -> Word32 -> Request PtrBitmap
RequestStackBitmap StackPtr
sp Word32
o))
      | CommandId
cmd forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestFunBitmap -> do
          ClosurePtr
cp <- forall t. Binary t => Get t
get
          Word16
n <- Get Word16
getWord16be
          return (forall req. Request req -> AnyReq
AnyReq (Word16 -> ClosurePtr -> Request PtrBitmap
RequestFunBitmap Word16
n ClosurePtr
cp))
      | CommandId
cmd forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestConstrDesc -> do
          InfoTablePtr
itb <- forall t. Binary t => Get t
get
          return (forall req. Request req -> AnyReq
AnyReq (InfoTablePtr -> Request ConstrDesc
RequestConstrDesc InfoTablePtr
itb))
      | CommandId
cmd forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestPoll -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall req. Request req -> AnyReq
AnyReq Request ()
RequestPoll)
      | CommandId
cmd forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestSavedObjects -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall req. Request req -> AnyReq
AnyReq Request [ClosurePtr]
RequestSavedObjects)
      | CommandId
cmd forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestSourceInfo -> do
          InfoTablePtr
it <- forall t. Binary t => Get t
get
          return (forall req. Request req -> AnyReq
AnyReq (InfoTablePtr -> Request (Maybe SourceInformation)
RequestSourceInfo InfoTablePtr
it))
      | CommandId
cmd forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestAllBlocks -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall req. Request req -> AnyReq
AnyReq Request [RawBlock]
RequestAllBlocks)
      | CommandId
cmd forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestBlock -> do
            ClosurePtr
cp <- forall t. Binary t => Get t
get
            return (forall req. Request req -> AnyReq
AnyReq (ClosurePtr -> Request RawBlock
RequestBlock ClosurePtr
cp))
      | Bool
otherwise -> forall a. HasCallStack => String -> a
error (forall a. Show a => a -> String
show CommandId
cmd)


getResponse :: Request a -> Get a
getResponse :: forall a. Request a -> Get a
getResponse Request a
RequestVersion       = Word32 -> Word32 -> Version
Version forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get
getResponse RequestPause {}      = forall t. Binary t => Get t
get
getResponse Request a
RequestResume        = forall t. Binary t => Get t
get
getResponse Request a
RequestRoots         = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall t. Binary t => Get t
get
getResponse (RequestClosure {}) = forall t. Binary t => Get t
get
getResponse (RequestInfoTable InfoTablePtr
itbp) = (\(StgInfoTable
it, RawInfoTable
r) -> (InfoTablePtr -> StgInfoTable -> StgInfoTableWithPtr
StgInfoTableWithPtr InfoTablePtr
itbp StgInfoTable
it, RawInfoTable
r)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (StgInfoTable, RawInfoTable)
getInfoTable
getResponse (RequestSRT {}) = do
  ClosurePtr
cptr <- forall t. Binary t => Get t
get
  pure $ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ClosurePtr
cptr forall a. Eq a => a -> a -> Bool
/= Word64 -> ClosurePtr
UntaggedClosurePtr Word64
0) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ClosurePtr
cptr

--    zipWith (\p (it, r) -> (StgInfoTableWithPtr p it, r)) itps
--      <$> replicateM (length itps) getInfoTable
getResponse (RequestStackBitmap {}) = forall t. Binary t => Get t
get
getResponse (RequestFunBitmap {}) = forall t. Binary t => Get t
get
getResponse (RequestConstrDesc InfoTablePtr
_)  = Get ConstrDesc
getConstrDesc
getResponse Request a
RequestPoll          = forall t. Binary t => Get t
get
getResponse Request a
RequestSavedObjects  = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall t. Binary t => Get t
get
getResponse (RequestSourceInfo InfoTablePtr
_c) = Get (Maybe SourceInformation)
getIPE
getResponse Request a
RequestAllBlocks = forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall t. Binary t => Get t
get
getResponse RequestBlock {}  = forall t. Binary t => Get t
get


getConstrDesc :: Get ConstrDesc
getConstrDesc :: Get ConstrDesc
getConstrDesc = do
  Int32
len <- Get Int32
getInt32be
  String -> ConstrDesc
parseConstrDesc forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
C8.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
len)

getIPE :: Get (Maybe SourceInformation)
getIPE :: Get (Maybe SourceInformation)
getIPE = do
  Int32
num <- Get Int32
getInt32be
  [String]
res <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
num) Get String
getOne
  case [String]
res of
    (String
id_name:String
cty:String
ty:String
lab:String
modu:String
loc:[]) ->
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! String
-> ClosureType
-> String
-> String
-> String
-> String
-> SourceInformation
SourceInformation String
id_name (String -> ClosureType
readCTy String
cty) String
ty String
lab String
modu String
loc
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    [String]
fs -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (forall a. Show a => a -> String
show (String
"Expecting 6 or 0 fields in IPE" :: String,  [String]
fs,Int32
num))
  where
    getOne :: Get String
getOne = do
      !Int32
len <- Get Int32
getInt32be
      !String
res <- ByteString -> String
C8.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
len)
      forall (m :: * -> *) a. Monad m => a -> m a
return String
res
    -- All constructor nodes get 0, this is a wibble in the implementation
    -- of IPEs
    readCTy :: String -> ClosureType
readCTy String
"0" = ClosureType
CONSTR
    readCTy String
n   = forall a. Enum a => Int -> a
toEnum (forall a. Read a => String -> a
read @Int String
n)

putIPE :: Maybe SourceInformation -> Put
putIPE :: Maybe SourceInformation -> Put
putIPE Maybe SourceInformation
Nothing = Int32 -> Put
putInt32be Int32
0
putIPE (Just (SourceInformation String
a ClosureType
ty String
b String
c String
d String
e)) = do
  Int32 -> Put
putInt32be Int32
6
  String -> Put
putOne String
a
  String -> Put
putOne (forall a. Show a => a -> String
show (forall a. Enum a => a -> Int
fromEnum ClosureType
ty))
  String -> Put
putOne String
b
  String -> Put
putOne String
c
  String -> Put
putOne String
d
  String -> Put
putOne String
e
  where
    putOne :: String -> Put
putOne String
s = do
      Int32 -> Put
putInt32be (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s)
      ByteString -> Put
putByteString (String -> ByteString
C8.pack String
s)




getInfoTable :: Get (StgInfoTable, RawInfoTable)
getInfoTable :: Get (StgInfoTable, RawInfoTable)
getInfoTable = do
  !Int32
len <- Get Int32
getInt32be
  !RawInfoTable
r <- ByteString -> RawInfoTable
RawInfoTable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
len)
  let !it :: StgInfoTable
it = RawInfoTable -> StgInfoTable
decodeInfoTable RawInfoTable
r
  forall (m :: * -> *) a. Monad m => a -> m a
return (StgInfoTable
it, RawInfoTable
r)

putInfoTable :: RawInfoTable -> Put
putInfoTable :: RawInfoTable -> Put
putInfoTable (RawInfoTable ByteString
rc) = do
  let n :: Int
n = ByteString -> Int
BS.length ByteString
rc
  Word32 -> Put
putWord32be (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
  ByteString -> Put
putByteString ByteString
rc



data Error = BadCommand
           | BadStack
           | AlreadyPaused
           | NotPaused
           | NoResume
           deriving stock (Error -> Error -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq, Eq Error
Error -> Error -> Bool
Error -> Error -> Ordering
Error -> Error -> Error
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Error -> Error -> Error
$cmin :: Error -> Error -> Error
max :: Error -> Error -> Error
$cmax :: Error -> Error -> Error
>= :: Error -> Error -> Bool
$c>= :: Error -> Error -> Bool
> :: Error -> Error -> Bool
$c> :: Error -> Error -> Bool
<= :: Error -> Error -> Bool
$c<= :: Error -> Error -> Bool
< :: Error -> Error -> Bool
$c< :: Error -> Error -> Bool
compare :: Error -> Error -> Ordering
$ccompare :: Error -> Error -> Ordering
Ord, Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)

instance Exception Error

data ResponseCode = Okay
                  | OkayContinues
                  | Error Error
                  deriving stock (ResponseCode -> ResponseCode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResponseCode -> ResponseCode -> Bool
$c/= :: ResponseCode -> ResponseCode -> Bool
== :: ResponseCode -> ResponseCode -> Bool
$c== :: ResponseCode -> ResponseCode -> Bool
Eq, Eq ResponseCode
ResponseCode -> ResponseCode -> Bool
ResponseCode -> ResponseCode -> Ordering
ResponseCode -> ResponseCode -> ResponseCode
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ResponseCode -> ResponseCode -> ResponseCode
$cmin :: ResponseCode -> ResponseCode -> ResponseCode
max :: ResponseCode -> ResponseCode -> ResponseCode
$cmax :: ResponseCode -> ResponseCode -> ResponseCode
>= :: ResponseCode -> ResponseCode -> Bool
$c>= :: ResponseCode -> ResponseCode -> Bool
> :: ResponseCode -> ResponseCode -> Bool
$c> :: ResponseCode -> ResponseCode -> Bool
<= :: ResponseCode -> ResponseCode -> Bool
$c<= :: ResponseCode -> ResponseCode -> Bool
< :: ResponseCode -> ResponseCode -> Bool
$c< :: ResponseCode -> ResponseCode -> Bool
compare :: ResponseCode -> ResponseCode -> Ordering
$ccompare :: ResponseCode -> ResponseCode -> Ordering
Ord, Int -> ResponseCode -> ShowS
[ResponseCode] -> ShowS
ResponseCode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResponseCode] -> ShowS
$cshowList :: [ResponseCode] -> ShowS
show :: ResponseCode -> String
$cshow :: ResponseCode -> String
showsPrec :: Int -> ResponseCode -> ShowS
$cshowsPrec :: Int -> ResponseCode -> ShowS
Show)

getResponseCode :: Get ResponseCode
getResponseCode :: Get ResponseCode
getResponseCode = Get Word16
getWord16be forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a} {f :: * -> *}.
(Eq a, Num a, MonadFail f) =>
a -> f ResponseCode
f
  where
    f :: a -> f ResponseCode
f a
0x0   = forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseCode
Okay
    f a
0x1   = forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseCode
OkayContinues
    f a
0x100 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Error -> ResponseCode
Error Error
BadCommand
    f a
0x104 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Error -> ResponseCode
Error Error
BadStack
    f a
0x101 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Error -> ResponseCode
Error Error
AlreadyPaused
    f a
0x102 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Error -> ResponseCode
Error Error
NotPaused
    f a
0x103 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Error -> ResponseCode
Error Error
NoResume
    f a
_     = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unknown response code"

data Stream a r = Next !a (Stream a r)
                | End r

readFrames :: Handle -> IO (Stream BS.ByteString (Maybe Error))
readFrames :: Handle -> IO (Stream ByteString (Maybe Error))
readFrames Handle
hdl = do
    (Word32
respLen, ResponseCode
status) <- forall a. HasCallStack => Get a -> ByteString -> a
runGet_ Get (Word32, ResponseCode)
frameHeader forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> Int -> IO ByteString
BSL.hGet Handle
hdl Int
6
    ByteString
respBody <- Handle -> Int -> IO ByteString
BS.hGet Handle
hdl (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
respLen)
    case ResponseCode
status of
      ResponseCode
OkayContinues -> do Stream ByteString (Maybe Error)
rest <- Handle -> IO (Stream ByteString (Maybe Error))
readFrames Handle
hdl
                          return $ forall a r. a -> Stream a r -> Stream a r
Next ByteString
respBody Stream ByteString (Maybe Error)
rest
      ResponseCode
Okay     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a r. a -> Stream a r -> Stream a r
Next ByteString
respBody (forall a r. r -> Stream a r
End forall a. Maybe a
Nothing)
      Error Error
err-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a r. r -> Stream a r
End (forall a. a -> Maybe a
Just Error
err)
  where
    frameHeader :: Get (Word32, ResponseCode)
    frameHeader :: Get (Word32, ResponseCode)
frameHeader =
      (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ResponseCode
getResponseCode

throwStream :: Exception e => Stream a (Maybe e) -> [a]
throwStream :: forall e a. Exception e => Stream a (Maybe e) -> [a]
throwStream = forall e a. Exception e => Stream a (Maybe e) -> [a]
f
  where
    f :: Stream a (Maybe e) -> [a]
f (Next a
x Stream a (Maybe e)
rest)  = a
x forall a. a -> [a] -> [a]
: Stream a (Maybe e) -> [a]
f Stream a (Maybe e)
rest
    f (End Maybe e
Nothing)  = []
    f (End (Just e
e)) = forall a e. Exception e => e -> a
throw e
e

concatStream :: Stream BS.ByteString (Maybe Error) -> BSL.ByteString
concatStream :: Stream ByteString (Maybe Error) -> ByteString
concatStream = [ByteString] -> ByteString
BSL.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => Stream a (Maybe e) -> [a]
throwStream

-- | Perform a request
doRequest :: MVar Handle -> Request a -> IO a
doRequest :: forall a. MVar Handle -> Request a -> IO a
doRequest MVar Handle
mhdl Request a
req = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Handle
mhdl forall a b. (a -> b) -> a -> b
$ \Handle
hdl -> do
    Handle -> ByteString -> IO ()
BSL.hPutStr Handle
hdl forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPut forall a b. (a -> b) -> a -> b
$ forall a. Request a -> Put
putRequest Request a
req
    Stream ByteString (Maybe Error)
bframes <- Handle -> IO (Stream ByteString (Maybe Error))
readFrames Handle
hdl
    let x :: a
x = forall a. HasCallStack => Get a -> ByteString -> a
runGet_ (forall a. Request a -> Get a
getResponse Request a
req) (Stream ByteString (Maybe Error) -> ByteString
concatStream Stream ByteString (Maybe Error)
bframes)
    return a
x