{-# 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)
  -- Don't cache the results of writes, such as pause/unpause
  | 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

-- 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       = 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

-- | 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 ((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)