{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
-- | This module provides a simple implementation, which can be a lot faster if
-- network latency is not an issue.
module GHC.Debug.Client.Monad.Simple
  ( Debuggee
  , DebugM(..)
  , runSimple
  ) where

import Control.Concurrent
import GHC.Debug.Types
import qualified Data.HashMap.Strict as HM
import System.IO
import Data.IORef
import Data.List
import Data.Ord

import GHC.Debug.Client.BlockCache
import GHC.Debug.Client.RequestCache
import GHC.Debug.Client.Monad.Class

import Control.Monad.Fix
import Control.Monad.Reader
import Data.Binary
--import Debug.Trace


data Debuggee = Debuggee { -- Keep track of how many of each request we make
                           Debuggee -> Maybe (IORef (HashMap CommandId FetchStats))
debuggeeRequestCount :: Maybe (IORef (HM.HashMap CommandId FetchStats))
                         , Debuggee -> IORef BlockCache
debuggeeBlockCache :: IORef BlockCache
                         , Debuggee -> MVar RequestCache
debuggeeRequestCache :: MVar RequestCache
                         , Debuggee -> Maybe (MVar Handle)
debuggeeHandle :: Maybe (MVar Handle)
                         }

data FetchStats = FetchStats { FetchStats -> Int
_networkRequests :: !Int, FetchStats -> Int
_cachedRequests :: !Int }

logRequestIO :: Bool -> IORef (HM.HashMap CommandId FetchStats) -> Request resp -> IO ()
logRequestIO :: forall resp.
Bool
-> IORef (HashMap CommandId FetchStats) -> Request resp -> IO ()
logRequestIO Bool
cached IORef (HashMap CommandId FetchStats)
hmref Request resp
req =
  IORef (HashMap CommandId FetchStats)
-> (HashMap CommandId FetchStats
    -> (HashMap CommandId FetchStats, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (HashMap CommandId FetchStats)
hmref ((,()) (HashMap CommandId FetchStats
 -> (HashMap CommandId FetchStats, ()))
-> (HashMap CommandId FetchStats -> HashMap CommandId FetchStats)
-> HashMap CommandId FetchStats
-> (HashMap CommandId FetchStats, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe FetchStats -> Maybe FetchStats)
-> CommandId
-> HashMap CommandId FetchStats
-> HashMap CommandId FetchStats
forall k v.
(Eq k, Hashable k) =>
(Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v
HM.alter Maybe FetchStats -> Maybe FetchStats
alter_fn (Request resp -> CommandId
forall a. Request a -> CommandId
requestCommandId Request resp
req))

  where
    alter_fn :: Maybe FetchStats -> Maybe FetchStats
alter_fn = FetchStats -> Maybe FetchStats
forall a. a -> Maybe a
Just (FetchStats -> Maybe FetchStats)
-> (Maybe FetchStats -> FetchStats)
-> Maybe FetchStats
-> Maybe FetchStats
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FetchStats
-> (FetchStats -> FetchStats) -> Maybe FetchStats -> FetchStats
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FetchStats
emptyFetchStats FetchStats -> FetchStats
upd_fn
    emptyFetchStats :: FetchStats
emptyFetchStats = Int -> Int -> FetchStats
FetchStats Int
1 Int
0
    upd_fn :: FetchStats -> FetchStats
upd_fn (FetchStats Int
nr Int
cr)
      | Bool
cached = Int -> Int -> FetchStats
FetchStats Int
nr (Int
cr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      | Bool
otherwise = Int -> Int -> FetchStats
FetchStats (Int
nr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
cr

logRequest :: Bool -> Request resp -> ReaderT Debuggee IO ()
logRequest :: forall resp. Bool -> Request resp -> ReaderT Debuggee IO ()
logRequest Bool
cached Request resp
req = do
  Maybe (IORef (HashMap CommandId FetchStats))
mhm <- (Debuggee -> Maybe (IORef (HashMap CommandId FetchStats)))
-> ReaderT
     Debuggee IO (Maybe (IORef (HashMap CommandId FetchStats)))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Debuggee -> Maybe (IORef (HashMap CommandId FetchStats))
debuggeeRequestCount
  case Maybe (IORef (HashMap CommandId FetchStats))
mhm of
    Just IORef (HashMap CommandId FetchStats)
hm -> IO () -> ReaderT Debuggee IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Debuggee IO ())
-> IO () -> ReaderT Debuggee IO ()
forall a b. (a -> b) -> a -> b
$ Bool
-> IORef (HashMap CommandId FetchStats) -> Request resp -> IO ()
forall resp.
Bool
-> IORef (HashMap CommandId FetchStats) -> Request resp -> IO ()
logRequestIO Bool
cached IORef (HashMap CommandId FetchStats)
hm Request resp
req
    Maybe (IORef (HashMap CommandId FetchStats))
Nothing -> () -> ReaderT Debuggee IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

ppRequestLog :: HM.HashMap CommandId FetchStats -> String
ppRequestLog :: HashMap CommandId FetchStats -> String
ppRequestLog HashMap CommandId FetchStats
hm = [String] -> String
unlines (((CommandId, FetchStats) -> String)
-> [(CommandId, FetchStats)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (CommandId, FetchStats) -> String
forall {a}. Show a => (a, FetchStats) -> String
row [(CommandId, FetchStats)]
items)
  where
    row :: (a, FetchStats) -> String
row (a
cid, FetchStats Int
net Int
cache) = [String] -> String
unwords [a -> String
forall a. Show a => a -> String
show a
cid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":", Int -> String
forall a. Show a => a -> String
show Int
net, Int -> String
forall a. Show a => a -> String
show Int
cache]
    items :: [(CommandId, FetchStats)]
items = ((CommandId, FetchStats) -> (CommandId, FetchStats) -> Ordering)
-> [(CommandId, FetchStats)] -> [(CommandId, FetchStats)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((CommandId, FetchStats) -> CommandId)
-> (CommandId, FetchStats) -> (CommandId, FetchStats) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (CommandId, FetchStats) -> CommandId
forall a b. (a, b) -> a
fst) (HashMap CommandId FetchStats -> [(CommandId, FetchStats)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap CommandId FetchStats
hm)

data Snapshot = Snapshot {
                    Snapshot -> Word32
_version :: Word32
                  , Snapshot -> RequestCache
_rqc :: RequestCache
                  }

snapshotVersion :: Word32
snapshotVersion :: Word32
snapshotVersion = Word32
0

instance Binary Snapshot where
  get :: Get Snapshot
get = do
    Word32
v <- Get Word32
forall t. Binary t => Get t
get
    if Word32
v Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
snapshotVersion
      then Word32 -> RequestCache -> Snapshot
Snapshot Word32
v (RequestCache -> Snapshot) -> Get RequestCache -> Get Snapshot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get RequestCache
forall t. Binary t => Get t
get
      else String -> Get Snapshot
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Wrong snapshot version.\nGot: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nExpected: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
snapshotVersion)
  put :: Snapshot -> Put
put (Snapshot Word32
v RequestCache
c1) = do
    Word32 -> Put
forall t. Binary t => t -> Put
put Word32
v
    RequestCache -> Put
forall t. Binary t => t -> Put
put RequestCache
c1


instance DebugMonad DebugM where
  type DebugEnv DebugM = Debuggee
  request :: forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
request = ReaderT Debuggee IO resp -> DebugM resp
forall a. ReaderT Debuggee IO a -> DebugM a
DebugM (ReaderT Debuggee IO resp -> DebugM resp)
-> (Request resp -> ReaderT Debuggee IO resp)
-> Request resp
-> DebugM resp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request resp -> ReaderT Debuggee IO resp
forall resp. Request resp -> ReaderT Debuggee IO resp
simpleReq
  requestBlock :: forall resp.
(Show resp, Typeable resp) =>
BlockCacheRequest resp -> DebugM resp
requestBlock = BlockCacheRequest resp -> DebugM resp
forall resp. BlockCacheRequest resp -> DebugM resp
blockReq
  traceMsg :: String -> DebugM ()
traceMsg = ReaderT Debuggee IO () -> DebugM ()
forall a. ReaderT Debuggee IO a -> DebugM a
DebugM (ReaderT Debuggee IO () -> DebugM ())
-> (String -> ReaderT Debuggee IO ()) -> String -> DebugM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> ReaderT Debuggee IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Debuggee IO ())
-> (String -> IO ()) -> String -> ReaderT Debuggee IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn
  printRequestLog :: DebugEnv DebugM -> IO ()
printRequestLog DebugEnv DebugM
e = do
    case Debuggee -> Maybe (IORef (HashMap CommandId FetchStats))
debuggeeRequestCount DebugEnv DebugM
Debuggee
e of
      Just IORef (HashMap CommandId FetchStats)
hm_ref -> do
        IORef (HashMap CommandId FetchStats)
-> IO (HashMap CommandId FetchStats)
forall a. IORef a -> IO a
readIORef IORef (HashMap CommandId FetchStats)
hm_ref IO (HashMap CommandId FetchStats)
-> (HashMap CommandId FetchStats -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
putStrLn (String -> IO ())
-> (HashMap CommandId FetchStats -> String)
-> HashMap CommandId FetchStats
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap CommandId FetchStats -> String
ppRequestLog
      Maybe (IORef (HashMap CommandId FetchStats))
Nothing -> String -> IO ()
putStrLn String
"No request log in Simple(TM) mode"
  runDebug :: forall a. DebugEnv DebugM -> DebugM a -> IO a
runDebug = DebugEnv DebugM -> DebugM a -> IO a
forall a. Debuggee -> DebugM a -> IO a
runSimple
  runDebugTrace :: forall a. DebugEnv DebugM -> DebugM a -> IO (a, [String])
runDebugTrace DebugEnv DebugM
e DebugM a
a = (,[]) (a -> (a, [String])) -> IO a -> IO (a, [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DebugEnv DebugM -> DebugM a -> IO a
forall (m :: * -> *) a. DebugMonad m => DebugEnv m -> m a -> IO a
runDebug DebugEnv DebugM
e DebugM a
a
  newEnv :: Mode -> IO (DebugEnv DebugM)
newEnv Mode
m = case Mode
m of
               SnapshotMode String
f -> String -> IO Debuggee
mkSnapshotEnv String
f
               SocketMode Handle
h -> Handle -> IO Debuggee
mkHandleEnv Handle
h

  loadCache :: String -> DebugM ()
loadCache String
fp = ReaderT Debuggee IO () -> DebugM ()
forall a. ReaderT Debuggee IO a -> DebugM a
DebugM (ReaderT Debuggee IO () -> DebugM ())
-> ReaderT Debuggee IO () -> DebugM ()
forall a b. (a -> b) -> a -> b
$ do
    (Snapshot Word32
_ RequestCache
new_req_cache) <- IO Snapshot -> ReaderT Debuggee IO Snapshot
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Snapshot -> ReaderT Debuggee IO Snapshot)
-> IO Snapshot -> ReaderT Debuggee IO Snapshot
forall a b. (a -> b) -> a -> b
$ String -> IO Snapshot
forall a. Binary a => String -> IO a
decodeFile String
fp
    Debuggee{Maybe (IORef (HashMap CommandId FetchStats))
Maybe (MVar Handle)
IORef BlockCache
MVar RequestCache
debuggeeHandle :: Maybe (MVar Handle)
debuggeeRequestCache :: MVar RequestCache
debuggeeBlockCache :: IORef BlockCache
debuggeeRequestCount :: Maybe (IORef (HashMap CommandId FetchStats))
debuggeeHandle :: Debuggee -> Maybe (MVar Handle)
debuggeeRequestCache :: Debuggee -> MVar RequestCache
debuggeeBlockCache :: Debuggee -> IORef BlockCache
debuggeeRequestCount :: Debuggee -> Maybe (IORef (HashMap CommandId FetchStats))
..} <- ReaderT Debuggee IO Debuggee
forall r (m :: * -> *). MonadReader r m => m r
ask
    RequestCache
_old_rc <- IO RequestCache -> ReaderT Debuggee IO RequestCache
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO RequestCache -> ReaderT Debuggee IO RequestCache)
-> IO RequestCache -> ReaderT Debuggee IO RequestCache
forall a b. (a -> b) -> a -> b
$ MVar RequestCache -> RequestCache -> IO RequestCache
forall a. MVar a -> a -> IO a
swapMVar MVar RequestCache
debuggeeRequestCache RequestCache
new_req_cache
    -- Fill up the block cache with the cached blocks
    let block_c :: BlockCache
block_c = RequestCache -> BlockCache
initBlockCacheFromReqCache RequestCache
new_req_cache
    IO () -> ReaderT Debuggee IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ReaderT Debuggee IO ())
-> IO () -> ReaderT Debuggee IO ()
forall a b. (a -> b) -> a -> b
$ IORef BlockCache -> BlockCache -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef BlockCache
debuggeeBlockCache BlockCache
block_c

  saveCache :: String -> DebugM ()
saveCache String
fp = ReaderT Debuggee IO () -> DebugM ()
forall a. ReaderT Debuggee IO a -> DebugM a
DebugM (ReaderT Debuggee IO () -> DebugM ())
-> ReaderT Debuggee IO () -> DebugM ()
forall a b. (a -> b) -> a -> b
$ do
    Debuggee{Maybe (IORef (HashMap CommandId FetchStats))
Maybe (MVar Handle)
IORef BlockCache
MVar RequestCache
debuggeeHandle :: Maybe (MVar Handle)
debuggeeRequestCache :: MVar RequestCache
debuggeeBlockCache :: IORef BlockCache
debuggeeRequestCount :: Maybe (IORef (HashMap CommandId FetchStats))
debuggeeHandle :: Debuggee -> Maybe (MVar Handle)
debuggeeRequestCache :: Debuggee -> MVar RequestCache
debuggeeBlockCache :: Debuggee -> IORef BlockCache
debuggeeRequestCount :: Debuggee -> Maybe (IORef (HashMap CommandId FetchStats))
..} <- ReaderT Debuggee IO Debuggee
forall r (m :: * -> *). MonadReader r m => m r
ask
    Just RequestCache
req_cache <- IO (Maybe RequestCache) -> ReaderT Debuggee IO (Maybe RequestCache)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe RequestCache)
 -> ReaderT Debuggee IO (Maybe RequestCache))
-> IO (Maybe RequestCache)
-> ReaderT Debuggee IO (Maybe RequestCache)
forall a b. (a -> b) -> a -> b
$ MVar RequestCache -> IO (Maybe RequestCache)
forall a. MVar a -> IO (Maybe a)
tryReadMVar MVar RequestCache
debuggeeRequestCache
    IO () -> ReaderT Debuggee IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ReaderT Debuggee IO ())
-> IO () -> ReaderT Debuggee IO ()
forall a b. (a -> b) -> a -> b
$ String -> Snapshot -> IO ()
forall a. Binary a => String -> a -> IO ()
encodeFile String
fp (Word32 -> RequestCache -> Snapshot
Snapshot Word32
snapshotVersion RequestCache
req_cache)

  unsafeLiftIO :: forall a. IO a -> DebugM a
unsafeLiftIO IO a
f = ReaderT Debuggee IO a -> DebugM a
forall a. ReaderT Debuggee IO a -> DebugM a
DebugM (ReaderT Debuggee IO a -> DebugM a)
-> ReaderT Debuggee IO a -> DebugM a
forall a b. (a -> b) -> a -> b
$ IO a -> ReaderT Debuggee IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
f


initBlockCacheFromReqCache :: RequestCache -> BlockCache
initBlockCacheFromReqCache :: RequestCache -> BlockCache
initBlockCacheFromReqCache RequestCache
new_req_cache  =
  case Request [RawBlock] -> RequestCache -> Maybe [RawBlock]
forall resp. Request resp -> RequestCache -> Maybe resp
lookupReq Request [RawBlock]
RequestAllBlocks RequestCache
new_req_cache of
        Just [RawBlock]
bs -> [RawBlock] -> BlockCache -> BlockCache
addBlocks [RawBlock]
bs BlockCache
emptyBlockCache
        Maybe [RawBlock]
Nothing -> BlockCache
emptyBlockCache



runSimple :: Debuggee -> DebugM a -> IO a
runSimple :: forall a. Debuggee -> DebugM a -> IO a
runSimple Debuggee
d (DebugM ReaderT Debuggee IO a
a) = ReaderT Debuggee IO a -> Debuggee -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Debuggee IO a
a Debuggee
d

mkEnv :: (RequestCache, BlockCache) -> Maybe Handle -> IO Debuggee
mkEnv :: (RequestCache, BlockCache) -> Maybe Handle -> IO Debuggee
mkEnv (RequestCache
req_c, BlockCache
block_c) Maybe Handle
h = do
  let enable_stats :: Bool
enable_stats = Bool
False
  Maybe (IORef (HashMap CommandId FetchStats))
mcount <- if Bool
enable_stats then IORef (HashMap CommandId FetchStats)
-> Maybe (IORef (HashMap CommandId FetchStats))
forall a. a -> Maybe a
Just (IORef (HashMap CommandId FetchStats)
 -> Maybe (IORef (HashMap CommandId FetchStats)))
-> IO (IORef (HashMap CommandId FetchStats))
-> IO (Maybe (IORef (HashMap CommandId FetchStats)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap CommandId FetchStats
-> IO (IORef (HashMap CommandId FetchStats))
forall a. a -> IO (IORef a)
newIORef HashMap CommandId FetchStats
forall k v. HashMap k v
HM.empty else Maybe (IORef (HashMap CommandId FetchStats))
-> IO (Maybe (IORef (HashMap CommandId FetchStats)))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IORef (HashMap CommandId FetchStats))
forall a. Maybe a
Nothing
  IORef BlockCache
bc <- BlockCache -> IO (IORef BlockCache)
forall a. a -> IO (IORef a)
newIORef  BlockCache
block_c
  MVar RequestCache
rc <- RequestCache -> IO (MVar RequestCache)
forall a. a -> IO (MVar a)
newMVar RequestCache
req_c
  Maybe (MVar Handle)
mhdl <-  (Handle -> IO (MVar Handle))
-> Maybe Handle -> IO (Maybe (MVar Handle))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Handle -> IO (MVar Handle)
forall a. a -> IO (MVar a)
newMVar Maybe Handle
h
  return $ Maybe (IORef (HashMap CommandId FetchStats))
-> IORef BlockCache
-> MVar RequestCache
-> Maybe (MVar Handle)
-> Debuggee
Debuggee Maybe (IORef (HashMap CommandId FetchStats))
mcount IORef BlockCache
bc MVar RequestCache
rc Maybe (MVar Handle)
mhdl

mkHandleEnv :: Handle -> IO Debuggee
mkHandleEnv :: Handle -> IO Debuggee
mkHandleEnv Handle
h = (RequestCache, BlockCache) -> Maybe Handle -> IO Debuggee
mkEnv (RequestCache
emptyRequestCache, BlockCache
emptyBlockCache) (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
h)

mkSnapshotEnv :: FilePath -> IO Debuggee
mkSnapshotEnv :: String -> IO Debuggee
mkSnapshotEnv String
fp = do
  Snapshot Word32
_ RequestCache
req_c <- String -> IO Snapshot
forall a. Binary a => String -> IO a
decodeFile String
fp
  let block_c :: BlockCache
block_c = RequestCache -> BlockCache
initBlockCacheFromReqCache RequestCache
req_c
  (RequestCache, BlockCache) -> Maybe Handle -> IO Debuggee
mkEnv (RequestCache
req_c, BlockCache
block_c) Maybe Handle
forall a. Maybe a
Nothing

-- TODO: Sending multiple pauses will clear the cache, should keep track of
-- the pause state and only clear caches if the state changes.
simpleReq :: Request resp -> ReaderT Debuggee IO resp
simpleReq :: forall resp. Request resp -> ReaderT Debuggee IO resp
simpleReq Request resp
req | Request resp -> Bool
forall a. Request a -> Bool
isWriteRequest Request resp
req = ReaderT Debuggee IO Debuggee
forall r (m :: * -> *). MonadReader r m => m r
ask ReaderT Debuggee IO Debuggee
-> (Debuggee -> ReaderT Debuggee IO resp)
-> ReaderT Debuggee IO resp
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Debuggee{Maybe (IORef (HashMap CommandId FetchStats))
Maybe (MVar Handle)
IORef BlockCache
MVar RequestCache
debuggeeHandle :: Maybe (MVar Handle)
debuggeeRequestCache :: MVar RequestCache
debuggeeBlockCache :: IORef BlockCache
debuggeeRequestCount :: Maybe (IORef (HashMap CommandId FetchStats))
debuggeeHandle :: Debuggee -> Maybe (MVar Handle)
debuggeeRequestCache :: Debuggee -> MVar RequestCache
debuggeeBlockCache :: Debuggee -> IORef BlockCache
debuggeeRequestCount :: Debuggee -> Maybe (IORef (HashMap CommandId FetchStats))
..} -> IO resp -> ReaderT Debuggee IO resp
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO resp -> ReaderT Debuggee IO resp)
-> IO resp -> ReaderT Debuggee IO resp
forall a b. (a -> b) -> a -> b
$ Request resp
-> IO resp -> ((resp ~ ()) => Request resp -> IO resp) -> IO resp
forall a (r :: * -> *).
Request a -> r a -> ((a ~ ()) => Request a -> r a) -> r a
withWriteRequest Request resp
req (String -> IO resp
forall a. HasCallStack => String -> a
error String
"non-write") (((resp ~ ()) => Request resp -> IO resp) -> IO resp)
-> ((resp ~ ()) => Request resp -> IO resp) -> IO resp
forall a b. (a -> b) -> a -> b
$ \Request resp
wreq -> do
  case Maybe (MVar Handle)
debuggeeHandle of
    Just MVar Handle
h -> do
      IORef BlockCache -> (BlockCache -> (BlockCache, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef BlockCache
debuggeeBlockCache ((BlockCache, ()) -> BlockCache -> (BlockCache, ())
forall a b. a -> b -> a
const (BlockCache
emptyBlockCache, ()))
      MVar RequestCache -> (RequestCache -> IO RequestCache) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar RequestCache
debuggeeRequestCache (RequestCache -> IO RequestCache
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestCache -> IO RequestCache)
-> (RequestCache -> RequestCache)
-> RequestCache
-> IO RequestCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestCache -> RequestCache
clearMovableRequests)
      MVar Handle -> Request resp -> IO resp
forall a. MVar Handle -> Request a -> IO a
doRequest MVar Handle
h Request resp
wreq
    -- Ignore write requests in snapshot mode
    Maybe (MVar Handle)
Nothing -> resp -> IO resp
forall (m :: * -> *) a. Monad m => a -> m a
return ()
simpleReq Request resp
req = do
  MVar RequestCache
rc_var <- (Debuggee -> MVar RequestCache)
-> ReaderT Debuggee IO (MVar RequestCache)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Debuggee -> MVar RequestCache
debuggeeRequestCache
  RequestCache
rc <- IO RequestCache -> ReaderT Debuggee IO RequestCache
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO RequestCache -> ReaderT Debuggee IO RequestCache)
-> IO RequestCache -> ReaderT Debuggee IO RequestCache
forall a b. (a -> b) -> a -> b
$ MVar RequestCache -> IO RequestCache
forall a. MVar a -> IO a
readMVar MVar RequestCache
rc_var
  case Request resp -> RequestCache -> Maybe resp
forall resp. Request resp -> RequestCache -> Maybe resp
lookupReq Request resp
req RequestCache
rc of
    Just resp
res -> do
      Bool -> Request resp -> ReaderT Debuggee IO ()
forall resp. Bool -> Request resp -> ReaderT Debuggee IO ()
logRequest Bool
True Request resp
req
      return resp
res
    Maybe resp
Nothing -> do
      Maybe (MVar Handle)
mh <- (Debuggee -> Maybe (MVar Handle))
-> ReaderT Debuggee IO (Maybe (MVar Handle))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Debuggee -> Maybe (MVar Handle)
debuggeeHandle
      case Maybe (MVar Handle)
mh of
        Maybe (MVar Handle)
Nothing -> String -> ReaderT Debuggee IO resp
forall a. HasCallStack => String -> a
error (String
"Cache Miss:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Request resp -> String
forall a. Show a => a -> String
show Request resp
req)
        Just MVar Handle
h -> do
          resp
res <- IO resp -> ReaderT Debuggee IO resp
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO resp -> ReaderT Debuggee IO resp)
-> IO resp -> ReaderT Debuggee IO resp
forall a b. (a -> b) -> a -> b
$ MVar Handle -> Request resp -> IO resp
forall a. MVar Handle -> Request a -> IO a
doRequest MVar Handle
h Request resp
req
          IO () -> ReaderT Debuggee IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Debuggee IO ())
-> IO () -> ReaderT Debuggee IO ()
forall a b. (a -> b) -> a -> b
$ MVar RequestCache -> (RequestCache -> IO RequestCache) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar RequestCache
rc_var (RequestCache -> IO RequestCache
forall (m :: * -> *) a. Monad m => a -> m a
return (RequestCache -> IO RequestCache)
-> (RequestCache -> RequestCache)
-> RequestCache
-> IO RequestCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request resp -> resp -> RequestCache -> RequestCache
forall resp. Request resp -> resp -> RequestCache -> RequestCache
cacheReq Request resp
req resp
res)
          Bool -> Request resp -> ReaderT Debuggee IO ()
forall resp. Bool -> Request resp -> ReaderT Debuggee IO ()
logRequest Bool
False Request resp
req
          return resp
res

blockReq :: BlockCacheRequest resp -> DebugM resp
blockReq :: forall resp. BlockCacheRequest resp -> DebugM resp
blockReq BlockCacheRequest resp
req = ReaderT Debuggee IO resp -> DebugM resp
forall a. ReaderT Debuggee IO a -> DebugM a
DebugM (ReaderT Debuggee IO resp -> DebugM resp)
-> ReaderT Debuggee IO resp -> DebugM resp
forall a b. (a -> b) -> a -> b
$ do
  IORef BlockCache
bc  <- (Debuggee -> IORef BlockCache)
-> ReaderT Debuggee IO (IORef BlockCache)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Debuggee -> IORef BlockCache
debuggeeBlockCache
  Debuggee
env <- ReaderT Debuggee IO Debuggee
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO resp -> ReaderT Debuggee IO resp
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO resp -> ReaderT Debuggee IO resp)
-> IO resp -> ReaderT Debuggee IO resp
forall a b. (a -> b) -> a -> b
$ (forall a. Request a -> IO a)
-> IORef BlockCache -> BlockCacheRequest resp -> IO resp
forall resp.
(forall a. Request a -> IO a)
-> IORef BlockCache -> BlockCacheRequest resp -> IO resp
handleBlockReq (\Request a
r -> ReaderT Debuggee IO a -> Debuggee -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Request a -> ReaderT Debuggee IO a
forall resp. Request resp -> ReaderT Debuggee IO resp
simpleReq Request a
r) Debuggee
env) IORef BlockCache
bc BlockCacheRequest resp
req

newtype DebugM a = DebugM (ReaderT Debuggee IO a)
                   -- Only derive the instances that DebugMonad needs
                    deriving (Monad DebugM
Monad DebugM -> (forall a. String -> DebugM a) -> MonadFail DebugM
forall a. String -> DebugM a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> DebugM a
$cfail :: forall a. String -> DebugM a
MonadFail, (forall a b. (a -> b) -> DebugM a -> DebugM b)
-> (forall a b. a -> DebugM b -> DebugM a) -> Functor DebugM
forall a b. a -> DebugM b -> DebugM a
forall a b. (a -> b) -> DebugM a -> DebugM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> DebugM b -> DebugM a
$c<$ :: forall a b. a -> DebugM b -> DebugM a
fmap :: forall a b. (a -> b) -> DebugM a -> DebugM b
$cfmap :: forall a b. (a -> b) -> DebugM a -> DebugM b
Functor, Functor DebugM
Functor DebugM
-> (forall a. a -> DebugM a)
-> (forall a b. DebugM (a -> b) -> DebugM a -> DebugM b)
-> (forall a b c.
    (a -> b -> c) -> DebugM a -> DebugM b -> DebugM c)
-> (forall a b. DebugM a -> DebugM b -> DebugM b)
-> (forall a b. DebugM a -> DebugM b -> DebugM a)
-> Applicative DebugM
forall a. a -> DebugM a
forall a b. DebugM a -> DebugM b -> DebugM a
forall a b. DebugM a -> DebugM b -> DebugM b
forall a b. DebugM (a -> b) -> DebugM a -> DebugM b
forall a b c. (a -> b -> c) -> DebugM a -> DebugM b -> DebugM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. DebugM a -> DebugM b -> DebugM a
$c<* :: forall a b. DebugM a -> DebugM b -> DebugM a
*> :: forall a b. DebugM a -> DebugM b -> DebugM b
$c*> :: forall a b. DebugM a -> DebugM b -> DebugM b
liftA2 :: forall a b c. (a -> b -> c) -> DebugM a -> DebugM b -> DebugM c
$cliftA2 :: forall a b c. (a -> b -> c) -> DebugM a -> DebugM b -> DebugM c
<*> :: forall a b. DebugM (a -> b) -> DebugM a -> DebugM b
$c<*> :: forall a b. DebugM (a -> b) -> DebugM a -> DebugM b
pure :: forall a. a -> DebugM a
$cpure :: forall a. a -> DebugM a
Applicative, Applicative DebugM
Applicative DebugM
-> (forall a b. DebugM a -> (a -> DebugM b) -> DebugM b)
-> (forall a b. DebugM a -> DebugM b -> DebugM b)
-> (forall a. a -> DebugM a)
-> Monad DebugM
forall a. a -> DebugM a
forall a b. DebugM a -> DebugM b -> DebugM b
forall a b. DebugM a -> (a -> DebugM b) -> DebugM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> DebugM a
$creturn :: forall a. a -> DebugM a
>> :: forall a b. DebugM a -> DebugM b -> DebugM b
$c>> :: forall a b. DebugM a -> DebugM b -> DebugM b
>>= :: forall a b. DebugM a -> (a -> DebugM b) -> DebugM b
$c>>= :: forall a b. DebugM a -> (a -> DebugM b) -> DebugM b
Monad, Monad DebugM
Monad DebugM
-> (forall a. (a -> DebugM a) -> DebugM a) -> MonadFix DebugM
forall a. (a -> DebugM a) -> DebugM a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
mfix :: forall a. (a -> DebugM a) -> DebugM a
$cmfix :: forall a. (a -> DebugM a) -> DebugM a
MonadFix)