{-# 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
    -- * Running/Connecting to a debuggee
  , withDebuggeeRun
  , withDebuggeeConnect
  , debuggeeRun
  , debuggeeConnect
  , debuggeeClose
  -- * Snapshot run
  , snapshotInit
  , snapshotRun
    -- * Logging
  , outputRequestLog
  ) where

import Control.Exception (finally)
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

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) <- forall (m :: * -> *) a.
DebugMonad m =>
DebugEnv m -> m a -> IO (a, [String])
runDebugTrace DebugEnv DebugM
e DebugM a
act
  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 = forall (m :: * -> *). DebugMonad m => String -> m ()
traceMsg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

-- | Run a @DebugM a@ in the given environment.
run :: Debuggee -> DebugM a -> IO a
run :: forall a. Debuggee -> DebugM a -> IO a
run (Debuggee DebugEnv DebugM
d) = forall (m :: * -> *) a. DebugMonad m => DebugEnv m -> m a -> IO a
runDebug DebugEnv DebugM
d

-- | Bracketed version of @debuggeeRun@. Runs a debuggee, connects to it, runs
-- the action, kills the process, then closes the debuggee.
withDebuggeeRun :: FilePath  -- ^ path to executable to run as the debuggee
                -> FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)
                -> (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
    -- Start the process we want to debug
    CreateProcess
cp <- String -> String -> IO CreateProcess
debuggeeProcess String
exeName String
socketName
    forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
cp forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
_ -> do
    -- Now connect to the socket the debuggeeProcess just started
      forall a. String -> (Debuggee -> IO a) -> IO a
withDebuggeeConnect String
socketName Debuggee -> IO a
action

-- | Bracketed version of @debuggeeConnect@. Connects to a debuggee, runs the
-- action, then closes the debuggee.
withDebuggeeConnect :: FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)
                    -> (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
      forall a b. IO a -> IO b -> IO a
`finally`
      Debuggee -> IO ()
debuggeeClose Debuggee
new_env

-- | Run a debuggee and connect to it. Use @debuggeeClose@ when you're done.
debuggeeRun :: FilePath  -- ^ path to executable to run as the debuggee
            -> FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)
            -> IO Debuggee
debuggeeRun :: String -> String -> IO Debuggee
debuggeeRun String
exeName String
socketName = do
    -- Start the process we want to debug
    (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
_ <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> IO CreateProcess
debuggeeProcess String
exeName String
socketName
    -- Now connect to the socket the debuggeeProcess just started
    String -> IO Debuggee
debuggeeConnect String
socketName

-- | Connect to a debuggee on the given socket. Use @debuggeeClose@ when you're done.
debuggeeConnect :: FilePath  -- ^ filename of socket (e.g. @"\/tmp\/ghc-debug"@)
                -> IO Debuggee
debuggeeConnect :: String -> IO Debuggee
debuggeeConnect 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 => Mode -> IO (DebugEnv m)
newEnv @DebugM (Handle -> Mode
SocketMode Handle
hdl)
    return (DebugEnv DebugM -> Debuggee
Debuggee Debuggee
new_env)

-- | Create a debuggee by loading a snapshot created by 'snapshot'.
snapshotInit :: FilePath -> IO Debuggee
snapshotInit :: String -> IO Debuggee
snapshotInit String
fp = DebugEnv DebugM -> Debuggee
Debuggee forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). DebugMonad m => Mode -> IO (DebugEnv m)
newEnv @DebugM (String -> Mode
SnapshotMode String
fp)

-- | Start an analysis session using a snapshot. This will not connect to a
-- debuggee. The snapshot is created by 'snapshot'.
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

-- | Close the connection to the debuggee.
debuggeeClose :: Debuggee -> IO ()
debuggeeClose :: Debuggee -> IO ()
debuggeeClose Debuggee
d = forall a. Debuggee -> DebugM a -> IO a
run Debuggee
d forall a b. (a -> b) -> a -> b
$ 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 :: Maybe [(String, String)]
env = forall a. a -> Maybe a
Just ((String
"GHC_DEBUG_SOCKET", String
sockName) forall a. a -> [a] -> [a]
: [(String, String)]
e) }

outputRequestLog :: Debuggee -> IO ()
outputRequestLog :: Debuggee -> IO ()
outputRequestLog = forall (m :: * -> *). DebugMonad m => DebugEnv m -> IO ()
printRequestLog @DebugM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Debuggee -> DebugEnv DebugM
debuggeeEnv