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

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

                      -- * 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.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.Exts.Heap.ClosureTypes
import GHC.Debug.Decode
import Control.Concurrent
import Debug.Trace

-- | 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
(ForkOrPause -> ForkOrPause -> Bool)
-> (ForkOrPause -> ForkOrPause -> Bool) -> Eq ForkOrPause
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
Eq ForkOrPause
-> (ForkOrPause -> ForkOrPause -> Ordering)
-> (ForkOrPause -> ForkOrPause -> Bool)
-> (ForkOrPause -> ForkOrPause -> Bool)
-> (ForkOrPause -> ForkOrPause -> Bool)
-> (ForkOrPause -> ForkOrPause -> Bool)
-> (ForkOrPause -> ForkOrPause -> ForkOrPause)
-> (ForkOrPause -> ForkOrPause -> ForkOrPause)
-> Ord 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
(Int -> ForkOrPause -> ShowS)
-> (ForkOrPause -> String)
-> ([ForkOrPause] -> ShowS)
-> Show ForkOrPause
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]
(ForkOrPause -> ForkOrPause)
-> (ForkOrPause -> ForkOrPause)
-> (Int -> ForkOrPause)
-> (ForkOrPause -> Int)
-> (ForkOrPause -> [ForkOrPause])
-> (ForkOrPause -> ForkOrPause -> [ForkOrPause])
-> (ForkOrPause -> ForkOrPause -> [ForkOrPause])
-> (ForkOrPause -> ForkOrPause -> ForkOrPause -> [ForkOrPause])
-> Enum 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 Int -> Int -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (ForkOrPause -> Int
forall a. Enum a => a -> Int
fromEnum ForkOrPause
v)

instance Binary ForkOrPause where
  put :: ForkOrPause -> Put
put     = Word8 -> Put
putWord8 (Word8 -> Put) -> (ForkOrPause -> Word8) -> ForkOrPause -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (ForkOrPause -> Int) -> ForkOrPause -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForkOrPause -> Int
forall a. Enum a => a -> Int
fromEnum
  get :: Get ForkOrPause
get     = Get Word8
getWord8 Get Word8 -> (Word8 -> Get ForkOrPause) -> Get ForkOrPause
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get ForkOrPause
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 = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> a
forall a. Enum a => Int -> a
toEnum Int
0)
      toBool a
1 = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> a
forall a. Enum a => Int -> a
toEnum Int
1)
      toBool a
c = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Could not map value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
c String -> ShowS
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 Word32
    -- | 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)
    -- | 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
(Int -> SourceInformation -> ShowS)
-> (SourceInformation -> String)
-> ([SourceInformation] -> ShowS)
-> Show SourceInformation
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
(SourceInformation -> SourceInformation -> Bool)
-> (SourceInformation -> SourceInformation -> Bool)
-> Eq SourceInformation
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
Eq SourceInformation
-> (SourceInformation -> SourceInformation -> Ordering)
-> (SourceInformation -> SourceInformation -> Bool)
-> (SourceInformation -> SourceInformation -> Bool)
-> (SourceInformation -> SourceInformation -> Bool)
-> (SourceInformation -> SourceInformation -> Bool)
-> (SourceInformation -> SourceInformation -> SourceInformation)
-> (SourceInformation -> SourceInformation -> SourceInformation)
-> Ord 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 ForkOrPause -> ForkOrPause -> Bool
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 ClosurePtr -> ClosurePtr -> Bool
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 InfoTablePtr -> InfoTablePtr -> Bool
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 StackPtr -> StackPtr -> Bool
forall a. Eq a => a -> a -> Bool
== StackPtr
p' Bool -> Bool -> Bool
&& Word32
o Word32 -> Word32 -> Bool
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 Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
n' Bool -> Bool -> Bool
&& ClosurePtr
cp ClosurePtr -> ClosurePtr -> Bool
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 InfoTablePtr -> InfoTablePtr -> Bool
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 InfoTablePtr -> InfoTablePtr -> Bool
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 ClosurePtr -> ClosurePtr -> Bool
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 = Const Bool a -> Bool
forall {k} a (b :: k). Const a b -> a
getConst (Const Bool a -> Bool) -> Const Bool a -> Bool
forall a b. (a -> b) -> a -> b
$ Request a
-> Const Bool a
-> ((a ~ ()) => Request a -> Const Bool a)
-> Const Bool a
forall a (r :: * -> *).
Request a -> r a -> ((a ~ ()) => Request a -> r a) -> r a
withWriteRequest Request a
r (Bool -> Const Bool a
forall {k} a (b :: k). a -> Const a b
Const Bool
False) (Const Bool a -> Request a -> Const Bool a
forall a b. a -> b -> a
const (Bool -> Const Bool a
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
Request a -> r a
k (ForkOrPause -> Request ()
RequestPause ForkOrPause
f)
    Request a
RequestResume -> (a ~ ()) => Request a -> r a
Request a -> r a
k Request a
Request ()
RequestResume
    Request a
RequestPoll -> (a ~ ()) => Request a -> r a
Request a -> r a
k Request a
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
    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 Int -> CommandId -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestVersion
    RequestPause ForkOrPause
f ->  Int
s Int -> ForkOrPause -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` ForkOrPause
f Int -> CommandId -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestPause
    Request a
RequestResume  ->  Int
s Int -> CommandId -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestResume
    Request a
RequestRoots   -> Int
s Int -> CommandId -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestRoots
    RequestClosure ClosurePtr
cs -> Int
s Int -> CommandId -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestClosures Int -> ClosurePtr -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` ClosurePtr
cs
    RequestInfoTable InfoTablePtr
itp -> Int
s Int -> CommandId -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestInfoTables Int -> InfoTablePtr -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` InfoTablePtr
itp
    Request a
RequestPoll           -> Int
s Int -> CommandId -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestPoll
    Request a
RequestSavedObjects    -> Int
s Int -> CommandId -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestSavedObjects
    RequestStackBitmap StackPtr
p Word32
o -> Int
s Int -> CommandId -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestStackBitmap Int -> StackPtr -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` StackPtr
p Int -> Word32 -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word32
o
    RequestFunBitmap Word16
n ClosurePtr
cp  -> Int
s Int -> CommandId -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestFunBitmap Int -> ClosurePtr -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` ClosurePtr
cp Int -> Word16 -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Word16
n
    RequestConstrDesc InfoTablePtr
cp   -> Int
s Int -> CommandId -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestConstrDesc Int -> InfoTablePtr -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` InfoTablePtr
cp
    RequestSourceInfo InfoTablePtr
itp  -> Int
s Int -> CommandId -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestSourceInfo Int -> InfoTablePtr -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` InfoTablePtr
itp
    Request a
RequestAllBlocks       -> Int
s Int -> CommandId -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestAllBlocks
    RequestBlock ClosurePtr
cp        -> Int
s Int -> CommandId -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` CommandId
cmdRequestBlock Int -> ClosurePtr -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` ClosurePtr
cp


newtype CommandId = CommandId Word32
                  deriving (CommandId -> CommandId -> Bool
(CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> Bool) -> Eq CommandId
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
Eq CommandId
-> (CommandId -> CommandId -> Ordering)
-> (CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> Bool)
-> (CommandId -> CommandId -> CommandId)
-> (CommandId -> CommandId -> CommandId)
-> Ord 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
(Int -> CommandId -> ShowS)
-> (CommandId -> String)
-> ([CommandId] -> ShowS)
-> Show CommandId
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
(CommandId -> Put)
-> Get CommandId -> ([CommandId] -> Put) -> Binary CommandId
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, Int -> CommandId -> Int
CommandId -> Int
(Int -> CommandId -> Int)
-> (CommandId -> Int) -> Hashable CommandId
forall 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
    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

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

instance Hashable AnyReq where
  hashWithSalt :: Int -> AnyReq -> Int
hashWithSalt Int
s (AnyReq Request req
r) = Int -> Request req -> Int
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) = Request req -> Request req -> Bool
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 (Word32 -> Put) -> Word32 -> Put
forall a b. (a -> b) -> a -> b
$ Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64
4 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ ByteString -> Int64
BSL.length ByteString
body')
    CommandId -> Put
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 Put
forall a. Monoid a => a
mempty
putRequest (RequestPause ForkOrPause
p)      = CommandId -> Put -> Put
putCommand CommandId
cmdRequestPause (ForkOrPause -> Put
forall t. Binary t => t -> Put
put ForkOrPause
p)
putRequest Request a
RequestResume         = CommandId -> Put -> Put
putCommand CommandId
cmdRequestResume Put
forall a. Monoid a => a
mempty
putRequest Request a
RequestRoots          = CommandId -> Put -> Put
putCommand CommandId
cmdRequestRoots Put
forall a. Monoid a => a
mempty
putRequest (RequestClosure ClosurePtr
cs)  =
  CommandId -> Put -> Put
putCommand CommandId
cmdRequestClosures (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ do
    Word16 -> Put
putWord16be Word16
1
    ClosurePtr -> Put
forall t. Binary t => t -> Put
put ClosurePtr
cs
putRequest (RequestInfoTable InfoTablePtr
ts) =
  CommandId -> Put -> Put
putCommand CommandId
cmdRequestInfoTables (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ do
    Word16 -> Put
putWord16be Word16
1
    InfoTablePtr -> Put
forall t. Binary t => t -> Put
put InfoTablePtr
ts
putRequest (RequestStackBitmap StackPtr
sp Word32
o)       =
  CommandId -> Put -> Put
putCommand CommandId
cmdRequestStackBitmap (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ StackPtr -> Put
forall t. Binary t => t -> Put
put StackPtr
sp Put -> Put -> Put
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 (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ ClosurePtr -> Put
forall t. Binary t => t -> Put
put ClosurePtr
cp Put -> Put -> Put
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 (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ InfoTablePtr -> Put
forall t. Binary t => t -> Put
put InfoTablePtr
itb
putRequest Request a
RequestPoll           = CommandId -> Put -> Put
putCommand CommandId
cmdRequestPoll Put
forall a. Monoid a => a
mempty
putRequest Request a
RequestSavedObjects   = CommandId -> Put -> Put
putCommand CommandId
cmdRequestSavedObjects Put
forall a. Monoid a => a
mempty
--putRequest (RequestFindPtr c)       =
--  putCommand cmdRequestFindPtr $ put c
putRequest (RequestSourceInfo InfoTablePtr
it) = CommandId -> Put -> Put
putCommand CommandId
cmdRequestSourceInfo (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ InfoTablePtr -> Put
forall t. Binary t => t -> Put
put InfoTablePtr
it
putRequest (Request a
RequestAllBlocks) = CommandId -> Put -> Put
putCommand CommandId
cmdRequestAllBlocks (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ () -> Put
forall (m :: * -> *) a. Monad m => a -> m a
return ()
putRequest (RequestBlock ClosurePtr
cp)  = CommandId -> Put -> Put
putCommand CommandId
cmdRequestBlock (Put -> Put) -> Put -> Put
forall a b. (a -> b) -> a -> b
$ ClosurePtr -> Put
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
  Int -> Get AnyReq -> Get AnyReq
forall a. Int -> Get a -> Get a
isolate (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len) (Get AnyReq -> Get AnyReq) -> Get AnyReq -> Get AnyReq
forall a b. (a -> b) -> a -> b
$ do
    CommandId
cmd <- Get CommandId
forall t. Binary t => Get t
get
    if
      | CommandId
cmd CommandId -> CommandId -> Bool
forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestVersion -> AnyReq -> Get AnyReq
forall (m :: * -> *) a. Monad m => a -> m a
return (Request Word32 -> AnyReq
forall req. Request req -> AnyReq
AnyReq Request Word32
RequestVersion)
      | CommandId
cmd CommandId -> CommandId -> Bool
forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestPause   -> do
          ForkOrPause
b <- Get ForkOrPause
forall t. Binary t => Get t
get
          return (Request () -> AnyReq
forall req. Request req -> AnyReq
AnyReq (ForkOrPause -> Request ()
RequestPause ForkOrPause
b))
      | CommandId
cmd CommandId -> CommandId -> Bool
forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestResume  -> AnyReq -> Get AnyReq
forall (m :: * -> *) a. Monad m => a -> m a
return (Request () -> AnyReq
forall req. Request req -> AnyReq
AnyReq Request ()
RequestResume)
      | CommandId
cmd CommandId -> CommandId -> Bool
forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestRoots   -> AnyReq -> Get AnyReq
forall (m :: * -> *) a. Monad m => a -> m a
return (Request [ClosurePtr] -> AnyReq
forall req. Request req -> AnyReq
AnyReq Request [ClosurePtr]
RequestRoots)
      | CommandId
cmd CommandId -> CommandId -> Bool
forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestClosures -> do
          Word16
_n <- Get Word16
getWord16be
--          cs <- replicateM (fromIntegral n) get
          ClosurePtr
cp <- Get ClosurePtr
forall t. Binary t => Get t
get
          return (Request RawClosure -> AnyReq
forall req. Request req -> AnyReq
AnyReq (ClosurePtr -> Request RawClosure
RequestClosure ClosurePtr
cp))
      | CommandId
cmd CommandId -> CommandId -> Bool
forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestInfoTables -> do
          Word16
_n <- Get Word16
getWord16be
          --itbs <- replicateM (fromIntegral n) get
          InfoTablePtr
itb <- Get InfoTablePtr
forall t. Binary t => Get t
get
          return (Request (StgInfoTableWithPtr, RawInfoTable) -> AnyReq
forall req. Request req -> AnyReq
AnyReq (InfoTablePtr -> Request (StgInfoTableWithPtr, RawInfoTable)
RequestInfoTable InfoTablePtr
itb))
      | CommandId
cmd CommandId -> CommandId -> Bool
forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestStackBitmap -> do
          StackPtr
sp <- Get StackPtr
forall t. Binary t => Get t
get
          Word32
o  <- Get Word32
getWord32be
          return (Request PtrBitmap -> AnyReq
forall req. Request req -> AnyReq
AnyReq (StackPtr -> Word32 -> Request PtrBitmap
RequestStackBitmap StackPtr
sp Word32
o))
      | CommandId
cmd CommandId -> CommandId -> Bool
forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestFunBitmap -> do
          ClosurePtr
cp <- Get ClosurePtr
forall t. Binary t => Get t
get
          Word16
n <- Get Word16
getWord16be
          return (Request PtrBitmap -> AnyReq
forall req. Request req -> AnyReq
AnyReq (Word16 -> ClosurePtr -> Request PtrBitmap
RequestFunBitmap Word16
n ClosurePtr
cp))
      | CommandId
cmd CommandId -> CommandId -> Bool
forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestConstrDesc -> do
          InfoTablePtr
itb <- Get InfoTablePtr
forall t. Binary t => Get t
get
          return (Request ConstrDesc -> AnyReq
forall req. Request req -> AnyReq
AnyReq (InfoTablePtr -> Request ConstrDesc
RequestConstrDesc InfoTablePtr
itb))
      | CommandId
cmd CommandId -> CommandId -> Bool
forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestPoll -> AnyReq -> Get AnyReq
forall (m :: * -> *) a. Monad m => a -> m a
return (Request () -> AnyReq
forall req. Request req -> AnyReq
AnyReq Request ()
RequestPoll)
      | CommandId
cmd CommandId -> CommandId -> Bool
forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestSavedObjects -> AnyReq -> Get AnyReq
forall (m :: * -> *) a. Monad m => a -> m a
return (Request [ClosurePtr] -> AnyReq
forall req. Request req -> AnyReq
AnyReq Request [ClosurePtr]
RequestSavedObjects)
      | CommandId
cmd CommandId -> CommandId -> Bool
forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestSourceInfo -> do
          InfoTablePtr
it <- Get InfoTablePtr
forall t. Binary t => Get t
get
          return (Request (Maybe SourceInformation) -> AnyReq
forall req. Request req -> AnyReq
AnyReq (InfoTablePtr -> Request (Maybe SourceInformation)
RequestSourceInfo InfoTablePtr
it))
      | CommandId
cmd CommandId -> CommandId -> Bool
forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestAllBlocks -> AnyReq -> Get AnyReq
forall (m :: * -> *) a. Monad m => a -> m a
return (Request [RawBlock] -> AnyReq
forall req. Request req -> AnyReq
AnyReq Request [RawBlock]
RequestAllBlocks)
      | CommandId
cmd CommandId -> CommandId -> Bool
forall a. Eq a => a -> a -> Bool
== CommandId
cmdRequestBlock -> do
            ClosurePtr
cp <- Get ClosurePtr
forall t. Binary t => Get t
get
            return (Request RawBlock -> AnyReq
forall req. Request req -> AnyReq
AnyReq (ClosurePtr -> Request RawBlock
RequestBlock ClosurePtr
cp))
      | Bool
otherwise -> String -> Get AnyReq
forall a. HasCallStack => String -> a
error (CommandId -> String
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       = Get a
Get Word32
getWord32be
getResponse RequestPause {}      = Get a
forall t. Binary t => Get t
get
getResponse Request a
RequestResume        = Get a
forall t. Binary t => Get t
get
getResponse Request a
RequestRoots         = Get ClosurePtr -> Get [ClosurePtr]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Get ClosurePtr
forall t. Binary t => Get t
get
getResponse (RequestClosure {}) = Get a
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)) ((StgInfoTable, RawInfoTable) -> a)
-> Get (StgInfoTable, RawInfoTable) -> Get a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (StgInfoTable, RawInfoTable)
getInfoTable
--    zipWith (\p (it, r) -> (StgInfoTableWithPtr p it, r)) itps
--      <$> replicateM (length itps) getInfoTable
getResponse (RequestStackBitmap {}) = Get a
forall t. Binary t => Get t
get
getResponse (RequestFunBitmap {}) = Get a
forall t. Binary t => Get t
get
getResponse (RequestConstrDesc InfoTablePtr
_)  = Get a
Get ConstrDesc
getConstrDesc
getResponse Request a
RequestPoll          = Get a
forall t. Binary t => Get t
get
getResponse Request a
RequestSavedObjects  = Get ClosurePtr -> Get [ClosurePtr]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Get ClosurePtr
forall t. Binary t => Get t
get
getResponse (RequestSourceInfo InfoTablePtr
_c) = Get a
Get (Maybe SourceInformation)
getIPE
getResponse Request a
RequestAllBlocks = Get RawBlock -> Get [RawBlock]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Get RawBlock
forall t. Binary t => Get t
get
getResponse RequestBlock {}  = Get a
forall t. Binary t => Get t
get


getConstrDesc :: Get ConstrDesc
getConstrDesc :: Get ConstrDesc
getConstrDesc = do
  Int32
len <- Get Int32
getInt32be
  String -> ConstrDesc
parseConstrDesc (String -> ConstrDesc)
-> (ByteString -> String) -> ByteString -> ConstrDesc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
C8.unpack (ByteString -> ConstrDesc) -> Get ByteString -> Get ConstrDesc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString (Int32 -> Int
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 <- Int -> Get String -> Get [String]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int32 -> Int
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:[]) ->
      Maybe SourceInformation -> Get (Maybe SourceInformation)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SourceInformation -> Get (Maybe SourceInformation))
-> (SourceInformation -> Maybe SourceInformation)
-> SourceInformation
-> Get (Maybe SourceInformation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceInformation -> Maybe SourceInformation
forall a. a -> Maybe a
Just (SourceInformation -> Get (Maybe SourceInformation))
-> SourceInformation -> Get (Maybe SourceInformation)
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
    [] -> Maybe SourceInformation -> Get (Maybe SourceInformation)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SourceInformation
forall a. Maybe a
Nothing
    [String]
fs -> String -> Get (Maybe SourceInformation)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ((String, [String], Int32) -> String
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 (ByteString -> String) -> Get ByteString -> Get String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
len)
      String -> Get String
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   = Int -> ClosureType
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 (Int -> String
forall a. Show a => a -> String
show (ClosureType -> Int
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 (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> Int -> Int32
forall a b. (a -> b) -> a -> b
$ String -> Int
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 (ByteString -> RawInfoTable) -> Get ByteString -> Get RawInfoTable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getByteString (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
len)
  let !it :: StgInfoTable
it = RawInfoTable -> StgInfoTable
decodeInfoTable RawInfoTable
r
  (StgInfoTable, RawInfoTable) -> Get (StgInfoTable, RawInfoTable)
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 (Int -> Word32
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
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
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
Eq Error
-> (Error -> Error -> Ordering)
-> (Error -> Error -> Bool)
-> (Error -> Error -> Bool)
-> (Error -> Error -> Bool)
-> (Error -> Error -> Bool)
-> (Error -> Error -> Error)
-> (Error -> Error -> Error)
-> Ord 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
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
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
(ResponseCode -> ResponseCode -> Bool)
-> (ResponseCode -> ResponseCode -> Bool) -> Eq ResponseCode
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
Eq ResponseCode
-> (ResponseCode -> ResponseCode -> Ordering)
-> (ResponseCode -> ResponseCode -> Bool)
-> (ResponseCode -> ResponseCode -> Bool)
-> (ResponseCode -> ResponseCode -> Bool)
-> (ResponseCode -> ResponseCode -> Bool)
-> (ResponseCode -> ResponseCode -> ResponseCode)
-> (ResponseCode -> ResponseCode -> ResponseCode)
-> Ord 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
(Int -> ResponseCode -> ShowS)
-> (ResponseCode -> String)
-> ([ResponseCode] -> ShowS)
-> Show ResponseCode
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 Get Word16 -> (Word16 -> Get ResponseCode) -> Get ResponseCode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word16 -> Get ResponseCode
forall {a} {f :: * -> *}.
(Eq a, Num a, MonadFail f) =>
a -> f ResponseCode
f
  where
    f :: a -> f ResponseCode
f a
0x0   = ResponseCode -> f ResponseCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseCode
Okay
    f a
0x1   = ResponseCode -> f ResponseCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseCode
OkayContinues
    f a
0x100 = ResponseCode -> f ResponseCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResponseCode -> f ResponseCode) -> ResponseCode -> f ResponseCode
forall a b. (a -> b) -> a -> b
$ Error -> ResponseCode
Error Error
BadCommand
    f a
0x104 = ResponseCode -> f ResponseCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResponseCode -> f ResponseCode) -> ResponseCode -> f ResponseCode
forall a b. (a -> b) -> a -> b
$ Error -> ResponseCode
Error Error
BadStack
    f a
0x101 = ResponseCode -> f ResponseCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResponseCode -> f ResponseCode) -> ResponseCode -> f ResponseCode
forall a b. (a -> b) -> a -> b
$ Error -> ResponseCode
Error Error
AlreadyPaused
    f a
0x102 = ResponseCode -> f ResponseCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResponseCode -> f ResponseCode) -> ResponseCode -> f ResponseCode
forall a b. (a -> b) -> a -> b
$ Error -> ResponseCode
Error Error
NotPaused
    f a
0x103 = ResponseCode -> f ResponseCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResponseCode -> f ResponseCode) -> ResponseCode -> f ResponseCode
forall a b. (a -> b) -> a -> b
$ Error -> ResponseCode
Error Error
NoResume
    f a
_     = String -> f ResponseCode
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) <- Get (Word32, ResponseCode) -> ByteString -> (Word32, ResponseCode)
forall a. Get a -> ByteString -> a
runGet Get (Word32, ResponseCode)
frameHeader (ByteString -> (Word32, ResponseCode))
-> IO ByteString -> IO (Word32, ResponseCode)
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 (Word32 -> Int
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 $ ByteString
-> Stream ByteString (Maybe Error)
-> Stream ByteString (Maybe Error)
forall a r. a -> Stream a r -> Stream a r
Next ByteString
respBody Stream ByteString (Maybe Error)
rest
      ResponseCode
Okay     -> Stream ByteString (Maybe Error)
-> IO (Stream ByteString (Maybe Error))
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream ByteString (Maybe Error)
 -> IO (Stream ByteString (Maybe Error)))
-> Stream ByteString (Maybe Error)
-> IO (Stream ByteString (Maybe Error))
forall a b. (a -> b) -> a -> b
$ ByteString
-> Stream ByteString (Maybe Error)
-> Stream ByteString (Maybe Error)
forall a r. a -> Stream a r -> Stream a r
Next ByteString
respBody (Maybe Error -> Stream ByteString (Maybe Error)
forall a r. r -> Stream a r
End Maybe Error
forall a. Maybe a
Nothing)
      Error Error
err-> Stream ByteString (Maybe Error)
-> IO (Stream ByteString (Maybe Error))
forall (m :: * -> *) a. Monad m => a -> m a
return (Stream ByteString (Maybe Error)
 -> IO (Stream ByteString (Maybe Error)))
-> Stream ByteString (Maybe Error)
-> IO (Stream ByteString (Maybe Error))
forall a b. (a -> b) -> a -> b
$ Maybe Error -> Stream ByteString (Maybe Error)
forall a r. r -> Stream a r
End (Error -> Maybe Error
forall a. a -> Maybe a
Just Error
err)
  where
    frameHeader :: Get (Word32, ResponseCode)
    frameHeader :: Get (Word32, ResponseCode)
frameHeader =
      (,) (Word32 -> ResponseCode -> (Word32, ResponseCode))
-> Get Word32 -> Get (ResponseCode -> (Word32, ResponseCode))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
          Get (ResponseCode -> (Word32, ResponseCode))
-> Get ResponseCode -> Get (Word32, ResponseCode)
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 = Stream a (Maybe e) -> [a]
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 a -> [a] -> [a]
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)) = e -> [a]
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 ([ByteString] -> ByteString)
-> (Stream ByteString (Maybe Error) -> [ByteString])
-> Stream ByteString (Maybe Error)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream ByteString (Maybe Error) -> [ByteString]
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 = MVar Handle -> (Handle -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Handle
mhdl ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
hdl -> do
    Handle -> ByteString -> IO ()
BSL.hPutStr Handle
hdl (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Request a -> Put
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 = Get a -> ByteString -> a
forall a. Get a -> ByteString -> a
runGet (Request a -> Get a
forall a. Request a -> Get a
getResponse Request a
req) (Stream ByteString (Maybe Error) -> ByteString
concatStream Stream ByteString (Maybe Error)
bframes)
    return a
x