diff --git a/client/src/GHC/Debug/Client/Monad/Simple.hs b/client/src/GHC/Debug/Client/Monad/Simple.hs index 6171fa659ae4efef082f380073617cadf1459c42..7ba7cb7b476944dd13583a9ed8d39c5be3b16594 100644 --- a/client/src/GHC/Debug/Client/Monad/Simple.hs +++ b/client/src/GHC/Debug/Client/Monad/Simple.hs @@ -123,9 +123,7 @@ instance DebugMonad DebugM where initBlockCacheFromReqCache :: RequestCache -> BlockCache initBlockCacheFromReqCache new_req_cache = - case lookupReq RequestAllBlocks new_req_cache of - Just bs -> addBlocks bs emptyBlockCache - Nothing -> emptyBlockCache + addBlocks (lookupBlocks new_req_cache) emptyBlockCache diff --git a/client/src/GHC/Debug/Client/RequestCache.hs b/client/src/GHC/Debug/Client/RequestCache.hs index 4352962581c342677134a31f63d71c482ad39d96..9e37cd7e097431e428cc6b522f62b52e9d7e78f0 100644 --- a/client/src/GHC/Debug/Client/RequestCache.hs +++ b/client/src/GHC/Debug/Client/RequestCache.hs @@ -4,6 +4,7 @@ module GHC.Debug.Client.RequestCache(RequestCache , cacheReq , lookupReq + , lookupBlocks , emptyRequestCache , clearMovableRequests , putCache @@ -33,6 +34,21 @@ lookupReq req (RequestCache rc) = coerceResult <$> HM.lookup (AnyReq req) rc coerceResult :: AnyResp -> resp coerceResult (AnyResp a _) = unsafeCoerce a +lookupBlocks :: RequestCache -> [RawBlock] +lookupBlocks c@(RequestCache rc) = + let all_blocks = case lookupReq RequestAllBlocks c of + Just bs -> bs + Nothing -> [] + + get_block :: AnyReq -> AnyResp -> [RawBlock] -> [RawBlock] + get_block (AnyReq (RequestBlock {})) (AnyResp resp _) bs = unsafeCoerce resp : bs + get_block _ _ bs = bs + + individual_blocks = HM.foldrWithKey get_block [] rc + + in (all_blocks ++ individual_blocks) + + emptyRequestCache :: RequestCache emptyRequestCache = RequestCache HM.empty