module IdeSession.GHC.Client (
InProcess
, GhcServer(..)
, forkGhcServer
, shutdownGhcServer
, forceShutdownGhcServer
, getGhcExitCode
, RunActions(..)
, runWaitAll
, rpcCompile
, rpcRun
, rpcCrash
, rpcSetEnv
, rpcSetArgs
, rpcBreakpoint
, rpcPrint
, rpcLoad
, rpcUnload
, rpcSetGhcOpts
) where
import Control.Applicative ((<$>))
import Control.Concurrent (killThread)
import Control.Concurrent.Async (async, cancel, withAsync)
import Control.Concurrent.Chan (Chan, newChan, writeChan)
import Control.Concurrent.MVar (newMVar)
import Control.Monad (when, forever)
import Data.Typeable (Typeable)
import Data.Binary (Binary)
import System.Directory (removeFile)
import System.Exit (ExitCode)
import System.Posix (ProcessID, sigKILL, signalProcess)
import qualified Control.Exception as Ex
import qualified Data.ByteString.Char8 as BSS
import qualified Data.ByteString.Lazy.Char8 as BSL
import IdeSession.Config
import IdeSession.GHC.API
import IdeSession.RPC.Client
import IdeSession.State
import IdeSession.Types.Private (RunResult(..))
import IdeSession.Types.Progress
import IdeSession.Util
import IdeSession.Util.BlockingOps
import qualified IdeSession.Types.Public as Public
import Distribution.Verbosity (normal)
import Distribution.Simple (PackageDB(..), PackageDBStack)
import Distribution.Simple.Program.Find (
ProgramSearchPath
, findProgramOnSearchPath
, ProgramSearchPathEntry(..)
)
forkGhcServer :: [String]
-> [FilePath]
-> [String]
-> IdeStaticInfo
-> IO (Either ExternalException (GhcServer, GhcVersion))
forkGhcServer ghcOpts relIncls rtsOpts IdeStaticInfo{ideConfig, ideSessionDir} = do
when configInProcess $
fail "In-process ghc server not currently supported"
mLoc <- findProgramOnSearchPath normal searchPath "ide-backend-server"
case mLoc of
Nothing ->
fail $ "Could not find ide-backend-server"
Just prog -> do
env <- envWithPathOverride configExtraPathDirs
server <- OutProcess <$> forkRpcServer
prog
(["+RTS"] ++ rtsOpts ++ ["-RTS"])
(Just (ideSessionDataDir ideSessionDir))
env
version <- Ex.try $ do
GhcInitResponse{..} <- rpcInit server GhcInitRequest {
ghcInitClientApiVersion = ideBackendApiVersion
, ghcInitGenerateModInfo = configGenerateModInfo
, ghcInitOpts = opts
, ghcInitUserPackageDB = userDB
, ghcInitSpecificPackageDBs = specificDBs
, ghcInitSessionDir = ideSessionDir
}
return ghcInitVersion
return ((server,) <$> version)
where
(userDB, specificDBs) = splitPackageDBStack configPackageDBStack
opts :: [String]
opts = "-XHaskell2010"
: ghcOpts
++ relInclToOpts (ideSessionSourceDir ideSessionDir) relIncls
searchPath :: ProgramSearchPath
searchPath = map ProgramSearchPathDir configExtraPathDirs
++ [ProgramSearchPathDefault]
SessionConfig{..} = ideConfig
splitPackageDBStack :: PackageDBStack -> (Bool, [String])
splitPackageDBStack dbstack = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs) -> (True, map specific dbs)
(GlobalPackageDB:dbs) -> (False, map specific dbs)
_ -> ierror
where
specific (SpecificPackageDB db) = db
specific _ = ierror
ierror :: a
ierror = error $ "internal error: unexpected package db stack: "
++ show dbstack
shutdownGhcServer :: GhcServer -> IO ()
shutdownGhcServer (OutProcess server) = shutdown server
shutdownGhcServer (InProcess _ tid) = killThread tid
forceShutdownGhcServer :: GhcServer -> IO ()
forceShutdownGhcServer (OutProcess server) = forceShutdown server
forceShutdownGhcServer (InProcess _ tid) = killThread tid
getGhcExitCode :: GhcServer -> IO (Maybe ExitCode)
getGhcExitCode (OutProcess server) =
getRpcExitCode server
getGhcExitCode (InProcess _ _) =
fail "getGhcExitCode not supported for in-process server"
runWaitAll :: forall a. RunActions a -> IO (BSL.ByteString, a)
runWaitAll RunActions{runWait} = go []
where
go :: [BSS.ByteString] -> IO (BSL.ByteString, a)
go acc = do
resp <- runWait
case resp of
Left bs -> go (bs : acc)
Right runResult -> return (BSL.fromChunks (reverse acc), runResult)
rpcSetEnv :: GhcServer -> [(String, Maybe String)] -> IO ()
rpcSetEnv (OutProcess server) env =
rpc server (ReqSetEnv env)
rpcSetEnv (InProcess _ _) _ =
error "rpcSetEnv not supported for in-process server"
rpcSetArgs :: GhcServer -> [String] -> IO ()
rpcSetArgs (OutProcess server) args =
rpc server (ReqSetArgs args)
rpcSetArgs (InProcess _ _) _ =
error "rpcSetArgs not supported for in-process server"
rpcSetGhcOpts :: GhcServer -> [String] -> IO ([String], [String])
rpcSetGhcOpts (OutProcess server) opts =
rpc server (ReqSetGhcOpts opts)
rpcSetGhcOpts (InProcess _ _) _ =
error "rpcSetGhcOpts not supported for in-process server"
rpcCompile :: GhcServer
-> Bool
-> Public.Targets
-> (Progress -> IO ())
-> IO GhcCompileResult
rpcCompile server genCode targets callback =
ghcConversation server $ \RpcConversation{..} -> do
put (ReqCompile genCode targets)
let go = do response <- get
case response of
GhcCompileProgress pcounter -> callback pcounter >> go
GhcCompileDone result -> return result
go
rpcBreakpoint :: GhcServer
-> Public.ModuleName -> Public.SourceSpan
-> Bool
-> IO (Maybe Bool)
rpcBreakpoint server reqBreakpointModule reqBreakpointSpan reqBreakpointValue =
ghcRpc server ReqBreakpoint{..}
data SnippetAction =
SnippetOutput BSS.ByteString
| SnippetTerminated RunResult
| SnippetForceTerminated
rpcRun :: forall a.
GhcServer
-> RunCmd
-> (Maybe RunResult -> IO a)
-> IO (RunActions a)
rpcRun server cmd translateResult =
Ex.mask_ $ do
(pid, stdin, stdout, errorLog) <- Ex.uninterruptibleMask_ $ ghcRpc server (ReqRun cmd)
interruptible (aux pid stdin stdout errorLog) `Ex.onException` signalProcess sigKILL pid
where
aux :: ProcessID -> FilePath -> FilePath -> FilePath -> IO (RunActions a)
aux pid stdin stdout errorLog = do
runWaitChan <- newChan :: IO (Chan SnippetAction)
reqChan <- newChan :: IO (Chan GhcRunRequest)
respThread <- async . Ex.handle (handleExternalException runWaitChan) $ do
connectToRpcServer stdin stdout errorLog $ \server' ->
ghcConversation (OutProcess server') $ \RpcConversation{..} -> do
withAsync (sendRequests put reqChan) $ \_reqThread -> do
let go = do resp <- get
case resp of
GhcRunDone result -> do
ignoreIOExceptions $ removeFile errorLog
writeChan runWaitChan (SnippetTerminated result)
GhcRunOutp bs -> do
writeChan runWaitChan (SnippetOutput bs)
go
go
runActionsState <- newMVar Nothing
return RunActions {
runWait =
$modifyMVar runActionsState $ \st ->
case st of
Just outcome ->
return (Just outcome, Right outcome)
Nothing -> do
outcome <- $readChan runWaitChan
case outcome of
SnippetOutput bs ->
return (Nothing, Left bs)
SnippetForceTerminated -> do
res <- translateResult Nothing
return (Just res, Right res)
SnippetTerminated res' -> do
res <- translateResult (Just res')
return (Just res, Right res)
, interrupt = writeChan reqChan GhcRunInterrupt
, supplyStdin = writeChan reqChan . GhcRunInput
, forceCancel = do
cancel respThread
ignoreIOExceptions $ signalProcess sigKILL pid
ignoreIOExceptions $ removeFile errorLog
writeChan runWaitChan SnippetForceTerminated
}
sendRequests :: (GhcRunRequest -> IO ()) -> Chan GhcRunRequest -> IO ()
sendRequests put reqChan = forever $ put =<< $readChan reqChan
handleExternalException :: Chan SnippetAction
-> ExternalException
-> IO ()
handleExternalException ch =
writeChan ch . SnippetTerminated . RunGhcException . show
rpcPrint :: GhcServer -> Public.Name -> Bool -> Bool -> IO Public.VariableEnv
rpcPrint server var bind forceEval = ghcRpc server (ReqPrint var bind forceEval)
rpcLoad :: GhcServer -> [FilePath] -> IO (Maybe String)
rpcLoad server objects = ghcRpc server (ReqLoad objects)
rpcUnload :: GhcServer -> [FilePath] -> IO ()
rpcUnload server objects = ghcRpc server (ReqUnload objects)
rpcCrash :: GhcServer -> Maybe Int -> IO ()
rpcCrash server delay = ghcConversation server $ \RpcConversation{..} ->
put (ReqCrash delay)
rpcInit :: GhcServer -> GhcInitRequest -> IO GhcInitResponse
rpcInit = ghcRpc
ghcConversation :: GhcServer -> (RpcConversation -> IO a) -> IO a
ghcConversation (OutProcess server) = rpcConversation server
ghcConversation (InProcess conv _) = ($ conv)
ghcRpc :: (Typeable req, Typeable resp, Binary req, Binary resp)
=> GhcServer -> req -> IO resp
ghcRpc (OutProcess server) = rpc server
ghcRpc (InProcess _ _) = error "ghcRpc not implemented for in-process server"
ignoreIOExceptions :: IO () -> IO ()
ignoreIOExceptions = let handler :: Ex.IOException -> IO ()
handler _ = return ()
in Ex.handle handler