{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
module GHC.Debug.Client.Monad
( DebugMonad(..)
, run
, DebugM
, Debuggee
, traceWrite
, runTrace
, withDebuggeeRun
, withDebuggeeConnect
, withDebuggeeConnectTCP
, debuggeeRun
, debuggeeConnect
, debuggeeConnectTCP
, debuggeeConnectWithTracer
, debuggeeConnectWithTracerTCP
, debuggeeClose
, snapshotInit
, snapshotInitWithTracer
, snapshotRun
, outputRequestLog
) where
import Control.Exception (finally)
import Data.Word (Word16)
import Network.Socket
import System.Process
import System.Environment
import GHC.Debug.Client.Monad.Class
import GHC.Debug.Types (Request(..))
import qualified GHC.Debug.Client.Monad.Simple as S
import System.IO
import Control.Tracer
type DebugM = S.DebugM
newtype Debuggee = Debuggee { Debuggee -> DebugEnv DebugM
debuggeeEnv :: DebugEnv DebugM }
runTrace :: Debuggee -> DebugM a -> IO a
runTrace :: forall a. Debuggee -> DebugM a -> IO a
runTrace (Debuggee DebugEnv DebugM
e) DebugM a
act = do
(a
r, [String]
ws) <- DebugEnv DebugM -> DebugM a -> IO (a, [String])
forall a. DebugEnv DebugM -> DebugM a -> IO (a, [String])
forall (m :: * -> *) a.
DebugMonad m =>
DebugEnv m -> m a -> IO (a, [String])
runDebugTrace DebugEnv DebugM
e DebugM a
act
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
ws
return a
r
traceWrite :: DebugMonad m => Show a => a -> m ()
traceWrite :: forall (m :: * -> *) a. (DebugMonad m, Show a) => a -> m ()
traceWrite = String -> m ()
forall (m :: * -> *). DebugMonad m => String -> m ()
traceMsg (String -> m ()) -> (a -> String) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
run :: Debuggee -> DebugM a -> IO a
run :: forall a. Debuggee -> DebugM a -> IO a
run (Debuggee DebugEnv DebugM
d) = 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
d
withDebuggeeRun :: FilePath
-> FilePath
-> (Debuggee -> IO a)
-> IO a
withDebuggeeRun :: forall a. String -> String -> (Debuggee -> IO a) -> IO a
withDebuggeeRun String
exeName String
socketName Debuggee -> IO a
action = do
CreateProcess
cp <- String -> String -> IO CreateProcess
debuggeeProcess String
exeName String
socketName
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
cp ((Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a)
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
_ -> do
String -> (Debuggee -> IO a) -> IO a
forall a. String -> (Debuggee -> IO a) -> IO a
withDebuggeeConnect String
socketName Debuggee -> IO a
action
withDebuggeeConnect :: FilePath
-> (Debuggee -> IO a)
-> IO a
withDebuggeeConnect :: forall a. String -> (Debuggee -> IO a) -> IO a
withDebuggeeConnect String
socketName Debuggee -> IO a
action = do
Debuggee
new_env <- String -> IO Debuggee
debuggeeConnect String
socketName
Debuggee -> IO a
action Debuggee
new_env
IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally`
Debuggee -> IO ()
debuggeeClose Debuggee
new_env
withDebuggeeConnectTCP
:: String
-> Word16
-> (Debuggee -> IO a)
-> IO a
withDebuggeeConnectTCP :: forall a. String -> Word16 -> (Debuggee -> IO a) -> IO a
withDebuggeeConnectTCP String
host Word16
port Debuggee -> IO a
action = do
Debuggee
new_env <- String -> Word16 -> IO Debuggee
debuggeeConnectTCP String
host Word16
port
Debuggee -> IO a
action Debuggee
new_env
IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally`
Debuggee -> IO ()
debuggeeClose Debuggee
new_env
debuggeeRun :: FilePath
-> FilePath
-> IO Debuggee
debuggeeRun :: String -> String -> IO Debuggee
debuggeeRun String
exeName String
socketName = do
(Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
_ <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> IO CreateProcess
debuggeeProcess String
exeName String
socketName
String -> IO Debuggee
debuggeeConnect String
socketName
debuggeeConnect :: FilePath -> IO Debuggee
debuggeeConnect :: String -> IO Debuggee
debuggeeConnect = Tracer IO String -> String -> IO Debuggee
debuggeeConnectWithTracer Tracer IO String
forall (m :: * -> *). Applicative m => Tracer m String
debugTracer
debuggeeConnectTCP :: String -> Word16 -> IO Debuggee
debuggeeConnectTCP :: String -> Word16 -> IO Debuggee
debuggeeConnectTCP = Tracer IO String -> String -> Word16 -> IO Debuggee
debuggeeConnectWithTracerTCP Tracer IO String
forall (m :: * -> *). Applicative m => Tracer m String
debugTracer
debuggeeConnectWithTracer
:: Tracer IO String
-> FilePath
-> IO Debuggee
debuggeeConnectWithTracer :: Tracer IO String -> String -> IO Debuggee
debuggeeConnectWithTracer Tracer IO String
tracer String
socketName = do
Socket
s <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_UNIX SocketType
Stream ProtocolNumber
defaultProtocol
Socket -> SockAddr -> IO ()
connect Socket
s (String -> SockAddr
SockAddrUnix String
socketName)
Handle
hdl <- Socket -> IOMode -> IO Handle
socketToHandle Socket
s IOMode
ReadWriteMode
Debuggee
new_env <- forall (m :: * -> *).
DebugMonad m =>
Tracer IO String -> Mode -> IO (DebugEnv m)
newEnv @DebugM Tracer IO String
tracer (Handle -> Mode
SocketMode Handle
hdl)
return (DebugEnv DebugM -> Debuggee
Debuggee DebugEnv DebugM
Debuggee
new_env)
debuggeeConnectWithTracerTCP
:: Tracer IO String
-> String
-> Word16
-> IO Debuggee
debuggeeConnectWithTracerTCP :: Tracer IO String -> String -> Word16 -> IO Debuggee
debuggeeConnectWithTracerTCP Tracer IO String
tracer String
host Word16
port = do
AddrInfo
addr:[AddrInfo]
_ <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
defaultHints) (String -> Maybe String
forall a. a -> Maybe a
Just String
host) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Word16 -> String
forall a. Show a => a -> String
show Word16
port)
Socket
s <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr)
Socket -> SockAddr -> IO ()
connect Socket
s (AddrInfo -> SockAddr
addrAddress AddrInfo
addr)
Handle
hdl <- Socket -> IOMode -> IO Handle
socketToHandle Socket
s IOMode
ReadWriteMode
Debuggee
new_env <- forall (m :: * -> *).
DebugMonad m =>
Tracer IO String -> Mode -> IO (DebugEnv m)
newEnv @DebugM Tracer IO String
tracer (Handle -> Mode
SocketMode Handle
hdl)
return (DebugEnv DebugM -> Debuggee
Debuggee DebugEnv DebugM
Debuggee
new_env)
snapshotInit :: FilePath -> IO Debuggee
snapshotInit :: String -> IO Debuggee
snapshotInit = Tracer IO String -> String -> IO Debuggee
snapshotInitWithTracer Tracer IO String
forall (m :: * -> *). Applicative m => Tracer m String
debugTracer
snapshotInitWithTracer :: Tracer IO String -> FilePath -> IO Debuggee
snapshotInitWithTracer :: Tracer IO String -> String -> IO Debuggee
snapshotInitWithTracer Tracer IO String
tracer String
fp =
DebugEnv DebugM -> Debuggee
Debuggee -> Debuggee
Debuggee (Debuggee -> Debuggee) -> IO Debuggee -> IO Debuggee
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
DebugMonad m =>
Tracer IO String -> Mode -> IO (DebugEnv m)
newEnv @DebugM Tracer IO String
tracer (String -> Mode
SnapshotMode String
fp)
snapshotRun :: FilePath -> (Debuggee -> IO a) -> IO a
snapshotRun :: forall a. String -> (Debuggee -> IO a) -> IO a
snapshotRun String
fp Debuggee -> IO a
k = do
Debuggee
denv <- String -> IO Debuggee
snapshotInit String
fp
Debuggee -> IO a
k Debuggee
denv
debuggeeClose :: Debuggee -> IO ()
debuggeeClose :: Debuggee -> IO ()
debuggeeClose Debuggee
d = Debuggee -> DebugM () -> IO ()
forall a. Debuggee -> DebugM a -> IO a
run Debuggee
d (DebugM () -> IO ()) -> DebugM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Request () -> DebugM ()
forall resp.
(Show resp, Typeable resp) =>
Request resp -> DebugM resp
forall (m :: * -> *) resp.
(DebugMonad m, Show resp, Typeable resp) =>
Request resp -> m resp
request Request ()
RequestResume
debuggeeProcess :: FilePath -> FilePath -> IO CreateProcess
debuggeeProcess :: String -> String -> IO CreateProcess
debuggeeProcess String
exe String
sockName = do
[(String, String)]
e <- IO [(String, String)]
getEnvironment
return $
(String -> [String] -> CreateProcess
proc String
exe []) { env = Just (("GHC_DEBUG_SOCKET", sockName) : e) }
outputRequestLog :: Debuggee -> IO ()
outputRequestLog :: Debuggee -> IO ()
outputRequestLog = forall (m :: * -> *). DebugMonad m => DebugEnv m -> IO ()
printRequestLog @DebugM (Debuggee -> IO ()) -> (Debuggee -> Debuggee) -> Debuggee -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Debuggee -> DebugEnv DebugM
Debuggee -> Debuggee
debuggeeEnv