{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
module GHC.Debug.Client.RequestCache(RequestCache
, cacheReq
, lookupReq
, emptyRequestCache
, clearMovableRequests
, putCache
, getCache ) where
import qualified Data.HashMap.Strict as HM
import GHC.Debug.Types
import Unsafe.Coerce
import Data.Binary
import Control.Monad
import Data.Binary.Put
import Data.Binary.Get
newtype RequestCache = RequestCache (HM.HashMap AnyReq AnyResp)
instance Binary RequestCache where
get :: Get RequestCache
get = Get RequestCache
getCache
put :: RequestCache -> Put
put = RequestCache -> Put
putCache
cacheReq :: Request resp -> resp -> RequestCache -> RequestCache
cacheReq :: forall resp. Request resp -> resp -> RequestCache -> RequestCache
cacheReq Request resp
req resp
resp (RequestCache HashMap AnyReq AnyResp
rc)
| Request resp -> Bool
forall a. Request a -> Bool
isWriteRequest Request resp
req = HashMap AnyReq AnyResp -> RequestCache
RequestCache HashMap AnyReq AnyResp
rc
| Bool
otherwise = HashMap AnyReq AnyResp -> RequestCache
RequestCache (AnyReq
-> AnyResp -> HashMap AnyReq AnyResp -> HashMap AnyReq AnyResp
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert (Request resp -> AnyReq
forall req. Request req -> AnyReq
AnyReq Request resp
req) (resp -> (resp -> Put) -> AnyResp
forall a. a -> (a -> Put) -> AnyResp
AnyResp resp
resp (Request resp -> resp -> Put
forall a. Request a -> a -> Put
putResponseBinary Request resp
req)) HashMap AnyReq AnyResp
rc)
lookupReq :: forall resp . Request resp -> RequestCache -> Maybe resp
lookupReq :: forall resp. Request resp -> RequestCache -> Maybe resp
lookupReq Request resp
req (RequestCache HashMap AnyReq AnyResp
rc) = AnyResp -> resp
forall resp. AnyResp -> resp
coerceResult (AnyResp -> resp) -> Maybe AnyResp -> Maybe resp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnyReq -> HashMap AnyReq AnyResp -> Maybe AnyResp
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Request resp -> AnyReq
forall req. Request req -> AnyReq
AnyReq Request resp
req) HashMap AnyReq AnyResp
rc
where
coerceResult :: AnyResp -> resp
coerceResult :: forall resp. AnyResp -> resp
coerceResult (AnyResp a
a a -> Put
_) = a -> resp
forall a b. a -> b
unsafeCoerce a
a
emptyRequestCache :: RequestCache
emptyRequestCache :: RequestCache
emptyRequestCache = HashMap AnyReq AnyResp -> RequestCache
RequestCache HashMap AnyReq AnyResp
forall k v. HashMap k v
HM.empty
getResponseBinary :: Request a -> Get a
getResponseBinary :: forall a. Request a -> Get a
getResponseBinary Request a
RequestVersion = Get a
Get Word32
getWord32be
getResponseBinary (RequestPause {}) = Get a
forall t. Binary t => Get t
get
getResponseBinary Request a
RequestResume = Get a
forall t. Binary t => Get t
get
getResponseBinary Request a
RequestRoots = Get a
forall t. Binary t => Get t
get
getResponseBinary (RequestClosure {}) = Get a
forall t. Binary t => Get t
get
getResponseBinary (RequestInfoTable InfoTablePtr
itps) =
(\(StgInfoTable
it, RawInfoTable
r) -> (InfoTablePtr -> StgInfoTable -> StgInfoTableWithPtr
StgInfoTableWithPtr InfoTablePtr
itps 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
getResponseBinary (RequestStackBitmap {}) = Get a
forall t. Binary t => Get t
get
getResponseBinary (RequestFunBitmap {}) = Get a
forall t. Binary t => Get t
get
getResponseBinary (RequestConstrDesc InfoTablePtr
_) = Get a
Get ConstrDesc
getConstrDescCache
getResponseBinary Request a
RequestPoll = Get a
forall t. Binary t => Get t
get
getResponseBinary Request a
RequestSavedObjects = Get a
forall t. Binary t => Get t
get
getResponseBinary (RequestSourceInfo InfoTablePtr
_c) = Get a
Get (Maybe SourceInformation)
getIPE
getResponseBinary Request a
RequestAllBlocks = Get a
forall t. Binary t => Get t
get
getResponseBinary RequestBlock {} = Get a
forall t. Binary t => Get t
get
putResponseBinary :: Request a -> a -> Put
putResponseBinary :: forall a. Request a -> a -> Put
putResponseBinary Request a
RequestVersion a
w = Word32 -> Put
putWord32be a
Word32
w
putResponseBinary (RequestPause {}) a
w = a -> Put
forall t. Binary t => t -> Put
put a
w
putResponseBinary Request a
RequestResume a
w = a -> Put
forall t. Binary t => t -> Put
put a
w
putResponseBinary Request a
RequestRoots a
rs = a -> Put
forall t. Binary t => t -> Put
put a
rs
putResponseBinary (RequestClosure {}) a
rcs = a -> Put
forall t. Binary t => t -> Put
put a
rcs
putResponseBinary (RequestInfoTable {}) (StgInfoTableWithPtr
_, RawInfoTable
r) = RawInfoTable -> Put
putInfoTable RawInfoTable
r
putResponseBinary (RequestStackBitmap {}) a
pbm = a -> Put
forall t. Binary t => t -> Put
put a
pbm
putResponseBinary (RequestFunBitmap {}) a
pbm = a -> Put
forall t. Binary t => t -> Put
put a
pbm
putResponseBinary (RequestConstrDesc InfoTablePtr
_) a
cd = ConstrDesc -> Put
putConstrDescCache a
ConstrDesc
cd
putResponseBinary Request a
RequestPoll a
r = a -> Put
forall t. Binary t => t -> Put
put a
r
putResponseBinary Request a
RequestSavedObjects a
os = [ClosurePtr] -> Put
forall t. Binary t => [t] -> Put
putList a
[ClosurePtr]
os
putResponseBinary (RequestSourceInfo InfoTablePtr
_c) a
ipe = Maybe SourceInformation -> Put
putIPE a
Maybe SourceInformation
ipe
putResponseBinary Request a
RequestAllBlocks a
rs = a -> Put
forall t. Binary t => t -> Put
put a
rs
putResponseBinary RequestBlock {} a
r = a -> Put
forall t. Binary t => t -> Put
put a
r
putConstrDescCache :: ConstrDesc -> Put
putConstrDescCache :: ConstrDesc -> Put
putConstrDescCache (ConstrDesc String
a String
b String
c) = do
String -> Put
forall t. Binary t => t -> Put
put String
a
String -> Put
forall t. Binary t => t -> Put
put String
b
String -> Put
forall t. Binary t => t -> Put
put String
c
getConstrDescCache :: Get ConstrDesc
getConstrDescCache :: Get ConstrDesc
getConstrDescCache =
String -> String -> String -> ConstrDesc
ConstrDesc (String -> String -> String -> ConstrDesc)
-> Get String -> Get (String -> String -> ConstrDesc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get String
forall t. Binary t => Get t
get Get (String -> String -> ConstrDesc)
-> Get String -> Get (String -> ConstrDesc)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get String
forall t. Binary t => Get t
get Get (String -> ConstrDesc) -> Get String -> Get ConstrDesc
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get String
forall t. Binary t => Get t
get
putLine :: AnyReq -> AnyResp -> Put -> Put
putLine :: AnyReq -> AnyResp -> Put -> Put
putLine (AnyReq Request req
req) (AnyResp a
resp a -> Put
p) Put
k = Request req -> Put
forall a. Request a -> Put
putRequest Request req
req Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Put
p a
resp Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Put
k
getCacheLine :: Get (AnyReq, AnyResp)
getCacheLine :: Get (AnyReq, AnyResp)
getCacheLine = do
AnyReq Request req
req <- Get AnyReq
getRequest
req
resp <- Request req -> Get req
forall a. Request a -> Get a
getResponseBinary Request req
req
return (Request req -> AnyReq
forall req. Request req -> AnyReq
AnyReq Request req
req, req -> (req -> Put) -> AnyResp
forall a. a -> (a -> Put) -> AnyResp
AnyResp req
resp (Request req -> req -> Put
forall a. Request a -> a -> Put
putResponseBinary Request req
req))
putCache :: RequestCache -> Put
putCache :: RequestCache -> Put
putCache (RequestCache HashMap AnyReq AnyResp
rc) = do
Int -> Put
forall t. Binary t => t -> Put
put (HashMap AnyReq AnyResp -> Int
forall k v. HashMap k v -> Int
HM.size HashMap AnyReq AnyResp
rc)
(AnyReq -> AnyResp -> Put -> Put)
-> Put -> HashMap AnyReq AnyResp -> Put
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HM.foldrWithKey AnyReq -> AnyResp -> Put -> Put
putLine (() -> Put
forall (m :: * -> *) a. Monad m => a -> m a
return ()) HashMap AnyReq AnyResp
rc
getCache :: Get RequestCache
getCache :: Get RequestCache
getCache = do
Int
n <- Get Int
forall t. Binary t => Get t
get
HashMap AnyReq AnyResp -> RequestCache
RequestCache (HashMap AnyReq AnyResp -> RequestCache)
-> ([(AnyReq, AnyResp)] -> HashMap AnyReq AnyResp)
-> [(AnyReq, AnyResp)]
-> RequestCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(AnyReq, AnyResp)] -> HashMap AnyReq AnyResp
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(AnyReq, AnyResp)] -> RequestCache)
-> Get [(AnyReq, AnyResp)] -> Get RequestCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get (AnyReq, AnyResp) -> Get [(AnyReq, AnyResp)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n Get (AnyReq, AnyResp)
getCacheLine
clearMovableRequests :: RequestCache -> RequestCache
clearMovableRequests :: RequestCache -> RequestCache
clearMovableRequests (RequestCache HashMap AnyReq AnyResp
rc) = HashMap AnyReq AnyResp -> RequestCache
RequestCache ((AnyReq -> AnyResp -> Bool)
-> HashMap AnyReq AnyResp -> HashMap AnyReq AnyResp
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HM.filterWithKey (\(AnyReq Request req
r) AnyResp
_ -> Request req -> Bool
forall a. Request a -> Bool
isImmutableRequest Request req
r) HashMap AnyReq AnyResp
rc)