{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module GHC.Debug.Client.Monad.Haxl
( Debuggee(..)
, Request(..)
, DebugM
, Env(..)
) where
import GHC.Debug.Types
import qualified Data.HashMap.Strict as HM
import System.IO
import Control.Concurrent
import GHC.Debug.Client.BlockCache
import GHC.Debug.Client.Monad.Class
import Haxl.Core hiding (Request, env)
import Data.Typeable
import Data.IORef
data Debuggee = Debuggee {
Debuggee -> IORef (HashMap CommandId Int)
debuggeeRequestCount :: IORef (HM.HashMap CommandId Int)
, Debuggee -> BatchMode
debuggeeBatchMode :: BatchMode
}
data BatchMode = Batch | OneByOne deriving (BatchMode -> BatchMode -> Bool
(BatchMode -> BatchMode -> Bool)
-> (BatchMode -> BatchMode -> Bool) -> Eq BatchMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BatchMode -> BatchMode -> Bool
$c/= :: BatchMode -> BatchMode -> Bool
== :: BatchMode -> BatchMode -> Bool
$c== :: BatchMode -> BatchMode -> Bool
Eq, Int -> BatchMode -> ShowS
[BatchMode] -> ShowS
BatchMode -> String
(Int -> BatchMode -> ShowS)
-> (BatchMode -> String)
-> ([BatchMode] -> ShowS)
-> Show BatchMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BatchMode] -> ShowS
$cshowList :: [BatchMode] -> ShowS
show :: BatchMode -> String
$cshow :: BatchMode -> String
showsPrec :: Int -> BatchMode -> ShowS
$cshowsPrec :: Int -> BatchMode -> ShowS
Show)
instance DebugMonad (GenHaxl Debuggee String) where
type DebugEnv (GenHaxl Debuggee String) = Env Debuggee String
request :: forall resp.
(Show resp, Typeable resp) =>
Request resp -> GenHaxl Debuggee String resp
request = Request resp -> GenHaxl Debuggee String resp
forall u (r :: * -> *) a w.
(DataSource u r, Request r a) =>
r a -> GenHaxl u w a
dataFetch
requestBlock :: forall resp.
(Show resp, Typeable resp) =>
BlockCacheRequest resp -> GenHaxl Debuggee String resp
requestBlock = BlockCacheRequest resp -> GenHaxl Debuggee String resp
forall u (r :: * -> *) a w.
(DataSource u r, Request r a) =>
r a -> GenHaxl u w a
dataFetch
traceMsg :: String -> GenHaxl Debuggee String ()
traceMsg = String -> GenHaxl Debuggee String ()
forall w u. w -> GenHaxl u w ()
tellWrite
printRequestLog :: DebugEnv (GenHaxl Debuggee String) -> IO ()
printRequestLog = DebugEnv (GenHaxl Debuggee String) -> IO ()
forall u w. Env u w -> IO ()
traceRequestLog
runDebug :: forall a.
DebugEnv (GenHaxl Debuggee String)
-> GenHaxl Debuggee String a -> IO a
runDebug = DebugEnv (GenHaxl Debuggee String)
-> GenHaxl Debuggee String a -> IO a
forall u w a. Env u w -> GenHaxl u w a -> IO a
runHaxl
runDebugTrace :: forall a.
DebugEnv (GenHaxl Debuggee String)
-> GenHaxl Debuggee String a -> IO (a, [String])
runDebugTrace = DebugEnv (GenHaxl Debuggee String)
-> GenHaxl Debuggee String a -> IO (a, [String])
forall u w a. Env u w -> GenHaxl u w a -> IO (a, [w])
runHaxlWithWrites
newEnv :: Mode -> IO (DebugEnv (GenHaxl Debuggee String))
newEnv Mode
args =
case Mode
args of
SnapshotMode String
_e -> String -> IO (Env Debuggee String)
forall a. HasCallStack => String -> a
error String
"Loading from snapshot not supported"
SocketMode Handle
h -> Handle -> IO (Env Debuggee String)
mkEnv Handle
h
saveCache :: String -> GenHaxl Debuggee String ()
saveCache = String -> String -> GenHaxl Debuggee String ()
forall a. HasCallStack => String -> a
error String
"TODO"
loadCache :: String -> GenHaxl Debuggee String ()
loadCache = String -> String -> GenHaxl Debuggee String ()
forall a. HasCallStack => String -> a
error String
"TODO"
unsafeLiftIO :: forall a. IO a -> GenHaxl Debuggee String a
unsafeLiftIO = String -> IO a -> GenHaxl Debuggee String a
forall a. HasCallStack => String -> a
error String
"TODO"
type DebugM = GenHaxl Debuggee String
instance StateKey Request where
data State Request = RequestState (MVar Handle)
instance DataSourceName Request where
dataSourceName :: Proxy Request -> Text
dataSourceName Proxy Request
Proxy = Text
"ghc-debug"
instance ShowP Request where
showp :: forall a. Request a -> String
showp = Request a -> String
forall a. Show a => a -> String
show
_singleFetches :: MVar Handle -> [BlockedFetch Request] -> IO ()
_singleFetches :: MVar Handle -> [BlockedFetch Request] -> IO ()
_singleFetches MVar Handle
h [BlockedFetch Request]
bs = (BlockedFetch Request -> IO ()) -> [BlockedFetch Request] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockedFetch Request -> IO ()
do_one [BlockedFetch Request]
bs
where
do_one :: BlockedFetch Request -> IO ()
do_one (BlockedFetch Request a
req ResultVar a
resp) = do
a
res <- MVar Handle -> Request a -> IO a
forall a. MVar Handle -> Request a -> IO a
doRequest MVar Handle
h Request a
req
ResultVar a -> a -> IO ()
forall a. ResultVar a -> a -> IO ()
putSuccess ResultVar a
resp a
res
instance DataSource Debuggee Request where
fetch :: State Request -> Flags -> Debuggee -> PerformFetch Request
fetch (RequestState MVar Handle
h) Flags
_fs Debuggee
u =
([BlockedFetch Request] -> IO ()) -> PerformFetch Request
forall (req :: * -> *).
([BlockedFetch req] -> IO ()) -> PerformFetch req
SyncFetch (([BlockedFetch Request] -> IO ()) -> PerformFetch Request)
-> ([BlockedFetch Request] -> IO ()) -> PerformFetch Request
forall a b. (a -> b) -> a -> b
$
case Debuggee -> BatchMode
debuggeeBatchMode Debuggee
u of
BatchMode
_ -> MVar Handle -> [BlockedFetch Request] -> IO ()
_singleFetches MVar Handle
h
instance StateKey BlockCacheRequest where
data State BlockCacheRequest = BCRequestState (IORef BlockCache) (MVar Handle)
instance DataSourceName BlockCacheRequest where
dataSourceName :: Proxy BlockCacheRequest -> Text
dataSourceName Proxy BlockCacheRequest
Proxy = Text
"block-cache"
instance ShowP BlockCacheRequest where
showp :: forall a. BlockCacheRequest a -> String
showp = BlockCacheRequest a -> String
forall a. Show a => a -> String
show
instance DataSource u BlockCacheRequest where
fetch :: State BlockCacheRequest
-> Flags -> u -> PerformFetch BlockCacheRequest
fetch (BCRequestState IORef BlockCache
ref MVar Handle
h) Flags
_fs u
_u =
([BlockedFetch BlockCacheRequest] -> IO ())
-> PerformFetch BlockCacheRequest
forall (req :: * -> *).
([BlockedFetch req] -> IO ()) -> PerformFetch req
SyncFetch ((BlockedFetch BlockCacheRequest -> IO ())
-> [BlockedFetch BlockCacheRequest] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BlockedFetch BlockCacheRequest -> IO ()
do_one)
where
do_one :: BlockedFetch BlockCacheRequest -> IO ()
do_one :: BlockedFetch BlockCacheRequest -> IO ()
do_one (BlockedFetch BlockCacheRequest a
bcr ResultVar a
resp) = do
a
res <- (forall a. Request a -> IO a)
-> IORef BlockCache -> BlockCacheRequest a -> IO a
forall resp.
(forall a. Request a -> IO a)
-> IORef BlockCache -> BlockCacheRequest resp -> IO resp
handleBlockReq (MVar Handle -> Request a -> IO a
forall a. MVar Handle -> Request a -> IO a
doRequest MVar Handle
h) IORef BlockCache
ref BlockCacheRequest a
bcr
ResultVar a -> a -> IO ()
forall a. ResultVar a -> a -> IO ()
putSuccess ResultVar a
resp a
res
mkEnv :: Handle -> IO (Env Debuggee String)
mkEnv :: Handle -> IO (Env Debuggee String)
mkEnv Handle
hdl = do
IORef (HashMap CommandId Int)
requestMap <- HashMap CommandId Int -> IO (IORef (HashMap CommandId Int))
forall a. a -> IO (IORef a)
newIORef HashMap CommandId Int
forall k v. HashMap k v
HM.empty
IORef BlockCache
bc <- BlockCache -> IO (IORef BlockCache)
forall a. a -> IO (IORef a)
newIORef BlockCache
emptyBlockCache
MVar Handle
mhdl <- Handle -> IO (MVar Handle)
forall a. a -> IO (MVar a)
newMVar Handle
hdl
let ss :: StateStore
ss = State BlockCacheRequest -> StateStore -> StateStore
forall (f :: * -> *).
StateKey f =>
State f -> StateStore -> StateStore
stateSet (IORef BlockCache -> MVar Handle -> State BlockCacheRequest
BCRequestState IORef BlockCache
bc MVar Handle
mhdl) (State Request -> StateStore -> StateStore
forall (f :: * -> *).
StateKey f =>
State f -> StateStore -> StateStore
stateSet (MVar Handle -> State Request
RequestState MVar Handle
mhdl) StateStore
stateEmpty)
Env Debuggee String
new_env <- StateStore -> Debuggee -> IO (Env Debuggee String)
forall u w. StateStore -> u -> IO (Env u w)
initEnv StateStore
ss (IORef (HashMap CommandId Int) -> BatchMode -> Debuggee
Debuggee IORef (HashMap CommandId Int)
requestMap BatchMode
Batch)
let new_flags :: Flags
new_flags = Flags
defaultFlags { report :: Int
report = Int
0 }
Env Debuggee String -> IO (Env Debuggee String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env Debuggee String -> IO (Env Debuggee String))
-> Env Debuggee String -> IO (Env Debuggee String)
forall a b. (a -> b) -> a -> b
$ Env Debuggee String
new_env { flags :: Flags
Haxl.Core.flags = Flags
new_flags }
traceRequestLog :: Env u w -> IO ()
traceRequestLog :: forall u w. Env u w -> IO ()
traceRequestLog Env u w
d = do
Stats
s <- IORef Stats -> IO Stats
forall a. IORef a -> IO a
readIORef (Env u w -> IORef Stats
forall u w. Env u w -> IORef Stats
statsRef Env u w
d)
String -> IO ()
putStrLn (Stats -> String
ppStats Stats
s)
_traceProfile :: Env u w -> IO ()
_traceProfile :: forall u w. Env u w -> IO ()
_traceProfile Env u w
e = do
Profile
p <- IORef Profile -> IO Profile
forall a. IORef a -> IO a
readIORef (Env u w -> IORef Profile
forall u w. Env u w -> IORef Profile
profRef Env u w
e)
HashMap ProfileKey ProfileData -> IO ()
forall a. Show a => a -> IO ()
print (Profile -> HashMap ProfileKey ProfileData
profile Profile
p)