{-# 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

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)
  -- Don't cache the results of writes, such as pause/unpause
  | 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 (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert (forall req. Request req -> AnyReq
AnyReq Request resp
req) (forall a. a -> (a -> Put) -> AnyResp
AnyResp resp
resp (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) = forall resp. AnyResp -> resp
coerceResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (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
_) = forall a b. a -> b
unsafeCoerce a
a

emptyRequestCache :: RequestCache
emptyRequestCache :: RequestCache
emptyRequestCache = HashMap AnyReq AnyResp -> RequestCache
RequestCache forall k v. HashMap k v
HM.empty

-- These get/put functions are a lot like the ones for serialising info
-- to/from the debuggee but we are careful that each one reads a bounded
-- amount of input.

getResponseBinary :: Request a -> Get a
getResponseBinary :: forall a. Request a -> Get a
getResponseBinary 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
getResponseBinary (RequestPause {})    = forall t. Binary t => Get t
get
getResponseBinary Request a
RequestResume        = forall t. Binary t => Get t
get
getResponseBinary Request a
RequestRoots         = forall t. Binary t => Get t
get
getResponseBinary (RequestClosure {}) = 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)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (StgInfoTable, RawInfoTable)
getInfoTable
getResponseBinary (RequestSRT {}) = forall t. Binary t => Get t
get
getResponseBinary (RequestStackBitmap {}) = forall t. Binary t => Get t
get
getResponseBinary (RequestFunBitmap {}) = forall t. Binary t => Get t
get
getResponseBinary (RequestConstrDesc InfoTablePtr
_)  = Get ConstrDesc
getConstrDescCache
getResponseBinary Request a
RequestPoll          = forall t. Binary t => Get t
get
getResponseBinary Request a
RequestSavedObjects  = forall t. Binary t => Get t
get
getResponseBinary (RequestSourceInfo InfoTablePtr
_c) = Get (Maybe SourceInformation)
getIPE
getResponseBinary Request a
RequestAllBlocks = forall t. Binary t => Get t
get
getResponseBinary RequestBlock {}  = forall t. Binary t => Get t
get

putResponseBinary :: Request a -> a -> Put
putResponseBinary :: forall a. Request a -> a -> Put
putResponseBinary Request a
RequestVersion (Version Word32
w1 Word32
w2) = forall t. Binary t => t -> Put
put Word32
w1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put Word32
w2
putResponseBinary (RequestPause {}) a
w  = forall t. Binary t => t -> Put
put a
w
putResponseBinary Request a
RequestResume a
w      = forall t. Binary t => t -> Put
put a
w
putResponseBinary Request a
RequestRoots  a
rs     = forall t. Binary t => t -> Put
put a
rs
putResponseBinary (RequestClosure {}) a
rcs = forall t. Binary t => t -> Put
put a
rcs
putResponseBinary (RequestInfoTable {}) (StgInfoTableWithPtr
_, RawInfoTable
r) = RawInfoTable -> Put
putInfoTable RawInfoTable
r
putResponseBinary (RequestSRT {}) a
rcs = forall t. Binary t => t -> Put
put a
rcs
putResponseBinary (RequestStackBitmap {}) a
pbm = forall t. Binary t => t -> Put
put a
pbm
putResponseBinary (RequestFunBitmap {}) a
pbm = forall t. Binary t => t -> Put
put a
pbm
putResponseBinary (RequestConstrDesc InfoTablePtr
_) a
cd  = ConstrDesc -> Put
putConstrDescCache a
cd
putResponseBinary Request a
RequestPoll         a
r = forall t. Binary t => t -> Put
put a
r
putResponseBinary Request a
RequestSavedObjects a
os = forall t. Binary t => [t] -> Put
putList a
os
putResponseBinary (RequestSourceInfo InfoTablePtr
_c) a
ipe = Maybe SourceInformation -> Put
putIPE a
ipe
putResponseBinary Request a
RequestAllBlocks a
rs = forall t. Binary t => t -> Put
put a
rs
putResponseBinary RequestBlock {} a
r = forall t. Binary t => t -> Put
put a
r

putConstrDescCache :: ConstrDesc -> Put
putConstrDescCache :: ConstrDesc -> Put
putConstrDescCache (ConstrDesc String
a String
b String
c) = do
  forall t. Binary t => t -> Put
put String
a
  forall t. Binary t => t -> Put
put String
b
  forall t. Binary t => t -> Put
put String
c

getConstrDescCache :: Get ConstrDesc
getConstrDescCache :: Get ConstrDesc
getConstrDescCache =
  String -> String -> String -> ConstrDesc
ConstrDesc 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 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 = forall a. Request a -> Put
putRequest Request req
req forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Put
p a
resp 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 <- forall a. Request a -> Get a
getResponseBinary Request req
req
  return (forall req. Request req -> AnyReq
AnyReq Request req
req, forall a. a -> (a -> Put) -> AnyResp
AnyResp req
resp (forall a. Request a -> a -> Put
putResponseBinary Request req
req))

putCache :: RequestCache -> Put
putCache :: RequestCache -> Put
putCache (RequestCache HashMap AnyReq AnyResp
rc) = do
  forall t. Binary t => t -> Put
put (forall k v. HashMap k v -> Int
HM.size HashMap AnyReq AnyResp
rc)
  forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HM.foldrWithKey AnyReq -> AnyResp -> Put -> Put
putLine (forall (m :: * -> *) a. Monad m => a -> m a
return ()) HashMap AnyReq AnyResp
rc

getCache :: Get RequestCache
getCache :: Get RequestCache
getCache = do
  Int
n <- forall t. Binary t => Get t
get
  HashMap AnyReq AnyResp -> RequestCache
RequestCache forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n Get (AnyReq, AnyResp)
getCacheLine

-- | Clear the part of the cache which will become invalid after pausing
-- For example, we need to clear blocks, but can keep the info table
-- caches.
clearMovableRequests :: RequestCache -> RequestCache
clearMovableRequests :: RequestCache -> RequestCache
clearMovableRequests (RequestCache HashMap AnyReq AnyResp
rc) = HashMap AnyReq AnyResp -> RequestCache
RequestCache (forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HM.filterWithKey (\(AnyReq Request req
r) AnyResp
_ -> forall a. Request a -> Bool
isImmutableRequest Request req
r) HashMap AnyReq AnyResp
rc)