{-# 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 Control.Tracer

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)
                         , Debuggee -> Tracer IO String
debuggeeTrace :: Tracer IO String
                         }

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 a. IO a -> ReaderT Debuggee IO a
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 a. a -> ReaderT Debuggee IO a
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 a. String -> Get a
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 String
s = 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 (MVar Handle)
Maybe (IORef (HashMap CommandId FetchStats))
MVar RequestCache
IORef BlockCache
Tracer IO String
debuggeeRequestCount :: Debuggee -> Maybe (IORef (HashMap CommandId FetchStats))
debuggeeBlockCache :: Debuggee -> IORef BlockCache
debuggeeRequestCache :: Debuggee -> MVar RequestCache
debuggeeHandle :: Debuggee -> Maybe (MVar Handle)
debuggeeTrace :: Debuggee -> Tracer IO String
debuggeeRequestCount :: Maybe (IORef (HashMap CommandId FetchStats))
debuggeeBlockCache :: IORef BlockCache
debuggeeRequestCache :: MVar RequestCache
debuggeeHandle :: Maybe (MVar Handle)
debuggeeTrace :: Tracer IO String
..} <- ReaderT Debuggee IO Debuggee
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO () -> ReaderT Debuggee IO ()
forall a. IO a -> ReaderT Debuggee IO a
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
$ Tracer IO String -> String -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer IO String
debuggeeTrace String
s

  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 a b. IO a -> (a -> IO b) -> IO b
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
Debuggee -> 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 a. 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 :: Tracer IO String -> Mode -> IO (DebugEnv DebugM)
newEnv Tracer IO String
t Mode
m = case Mode
m of
               SnapshotMode String
f -> Tracer IO String -> String -> IO Debuggee
mkSnapshotEnv Tracer IO String
t String
f
               SocketMode Handle
h -> Tracer IO String -> Handle -> IO Debuggee
mkHandleEnv Tracer IO String
t 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 (m :: * -> *) a. Monad m => m a -> ReaderT Debuggee m a
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 (MVar Handle)
Maybe (IORef (HashMap CommandId FetchStats))
MVar RequestCache
IORef BlockCache
Tracer IO String
debuggeeRequestCount :: Debuggee -> Maybe (IORef (HashMap CommandId FetchStats))
debuggeeBlockCache :: Debuggee -> IORef BlockCache
debuggeeRequestCache :: Debuggee -> MVar RequestCache
debuggeeHandle :: Debuggee -> Maybe (MVar Handle)
debuggeeTrace :: Debuggee -> Tracer IO String
debuggeeRequestCount :: Maybe (IORef (HashMap CommandId FetchStats))
debuggeeBlockCache :: IORef BlockCache
debuggeeRequestCache :: MVar RequestCache
debuggeeHandle :: Maybe (MVar Handle)
debuggeeTrace :: Tracer IO String
..} <- ReaderT Debuggee IO Debuggee
forall r (m :: * -> *). MonadReader r m => m r
ask
    RequestCache
_old_rc <- IO RequestCache -> ReaderT Debuggee IO RequestCache
forall (m :: * -> *) a. Monad m => m a -> ReaderT Debuggee m a
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 (m :: * -> *) a. Monad m => m a -> ReaderT Debuggee m a
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 (MVar Handle)
Maybe (IORef (HashMap CommandId FetchStats))
MVar RequestCache
IORef BlockCache
Tracer IO String
debuggeeRequestCount :: Debuggee -> Maybe (IORef (HashMap CommandId FetchStats))
debuggeeBlockCache :: Debuggee -> IORef BlockCache
debuggeeRequestCache :: Debuggee -> MVar RequestCache
debuggeeHandle :: Debuggee -> Maybe (MVar Handle)
debuggeeTrace :: Debuggee -> Tracer IO String
debuggeeRequestCount :: Maybe (IORef (HashMap CommandId FetchStats))
debuggeeBlockCache :: IORef BlockCache
debuggeeRequestCache :: MVar RequestCache
debuggeeHandle :: Maybe (MVar Handle)
debuggeeTrace :: Tracer IO String
..} <- 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 (m :: * -> *) a. Monad m => m a -> ReaderT Debuggee m a
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 (m :: * -> *) a. Monad m => m a -> ReaderT Debuggee m a
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 a. 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  =
  [RawBlock] -> BlockCache -> BlockCache
addBlocks (RequestCache -> [RawBlock]
lookupBlocks RequestCache
new_req_cache) 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 :: Tracer IO String
      -> (RequestCache, BlockCache)
      -> Maybe Handle
      -> IO Debuggee
mkEnv :: Tracer IO String
-> (RequestCache, BlockCache) -> Maybe Handle -> IO Debuggee
mkEnv Tracer IO String
trace_msg (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 a. a -> IO a
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe 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)
-> Tracer IO String
-> Debuggee
Debuggee Maybe (IORef (HashMap CommandId FetchStats))
mcount IORef BlockCache
bc MVar RequestCache
rc Maybe (MVar Handle)
mhdl Tracer IO String
trace_msg

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

mkSnapshotEnv :: Tracer IO String -> FilePath -> IO Debuggee
mkSnapshotEnv :: Tracer IO String -> String -> IO Debuggee
mkSnapshotEnv Tracer IO String
trace_msg 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
  Tracer IO String
-> (RequestCache, BlockCache) -> Maybe Handle -> IO Debuggee
mkEnv Tracer IO String
trace_msg (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 a b.
ReaderT Debuggee IO a
-> (a -> ReaderT Debuggee IO b) -> ReaderT Debuggee IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Debuggee{Maybe (MVar Handle)
Maybe (IORef (HashMap CommandId FetchStats))
MVar RequestCache
IORef BlockCache
Tracer IO String
debuggeeRequestCount :: Debuggee -> Maybe (IORef (HashMap CommandId FetchStats))
debuggeeBlockCache :: Debuggee -> IORef BlockCache
debuggeeRequestCache :: Debuggee -> MVar RequestCache
debuggeeHandle :: Debuggee -> Maybe (MVar Handle)
debuggeeTrace :: Debuggee -> Tracer IO String
debuggeeRequestCount :: Maybe (IORef (HashMap CommandId FetchStats))
debuggeeBlockCache :: IORef BlockCache
debuggeeRequestCache :: MVar RequestCache
debuggeeHandle :: Maybe (MVar Handle)
debuggeeTrace :: Tracer IO String
..} -> IO resp -> ReaderT Debuggee IO resp
forall a. IO a -> ReaderT Debuggee IO a
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 a. a -> IO a
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 a. a -> IO a
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 a. IO a -> ReaderT Debuggee IO a
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 a. IO a -> ReaderT Debuggee IO a
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 a. IO a -> ReaderT Debuggee IO a
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 a. a -> IO a
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
  Tracer IO String
tracer  <- (Debuggee -> Tracer IO String)
-> ReaderT Debuggee IO (Tracer IO String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Debuggee -> Tracer IO String
debuggeeTrace
  Debuggee
env <- ReaderT Debuggee IO Debuggee
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO resp -> ReaderT Debuggee IO resp
forall a. IO a -> ReaderT Debuggee IO a
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
$ Tracer IO String
-> (forall a. Request a -> IO a)
-> IORef BlockCache
-> BlockCacheRequest resp
-> IO resp
forall resp.
Tracer IO String
-> (forall a. Request a -> IO a)
-> IORef BlockCache
-> BlockCacheRequest resp
-> IO resp
handleBlockReq Tracer IO String
tracer (\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
$cfail :: forall a. String -> DebugM a
fail :: 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
$cfmap :: forall a b. (a -> b) -> DebugM a -> DebugM b
fmap :: forall a b. (a -> b) -> DebugM a -> DebugM b
$c<$ :: forall a b. a -> DebugM b -> DebugM a
<$ :: forall a b. a -> DebugM b -> DebugM a
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
$cpure :: forall a. a -> DebugM a
pure :: forall a. a -> DebugM a
$c<*> :: forall a b. DebugM (a -> b) -> DebugM a -> DebugM b
<*> :: forall a b. DebugM (a -> b) -> DebugM a -> DebugM b
$cliftA2 :: forall a b c. (a -> b -> c) -> DebugM a -> DebugM b -> DebugM c
liftA2 :: forall a b c. (a -> b -> c) -> DebugM a -> DebugM b -> DebugM c
$c*> :: forall a b. DebugM a -> DebugM b -> DebugM b
*> :: forall a b. DebugM a -> DebugM b -> DebugM b
$c<* :: forall a b. DebugM a -> DebugM b -> DebugM a
<* :: forall a b. DebugM a -> DebugM b -> 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
$c>>= :: forall a b. DebugM a -> (a -> DebugM b) -> DebugM b
>>= :: forall a b. DebugM a -> (a -> DebugM b) -> DebugM b
$c>> :: forall a b. DebugM a -> DebugM b -> DebugM b
>> :: forall a b. DebugM a -> DebugM b -> DebugM b
$creturn :: forall a. a -> DebugM a
return :: forall a. a -> DebugM a
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
$cmfix :: forall a. (a -> DebugM a) -> DebugM a
mfix :: forall a. (a -> DebugM a) -> DebugM a
MonadFix)