{-# LANGUAGE ScopedTypeVariables, CPP #-}
-- | Implementation of the server that controls the long-running GHC instance.
-- This interacts with the ide-backend library through serialized data only.
module Server (ghcServer) where
import Prelude hiding (mod, span)
import Control.Concurrent (throwTo, forkIO, myThreadId, threadDelay)
import Control.Monad (void, unless, when)
import Control.Monad.State (StateT, runStateT)
import Control.Monad.Trans.Class (lift)
import Data.Accessor (accessor, (.>))
import Data.Accessor.Monad.MTL.State (set)
import Data.Function (on)
import System.Environment (getEnvironment)
import System.IO.Temp (withSystemTempDirectory)
import qualified Control.Exception as Ex
import qualified Data.List as List
import qualified Data.Text as Text
import IdeSession.GHC.API
import IdeSession.RPC.Server
import IdeSession.Strict.Container
import IdeSession.Strict.IORef
import IdeSession.Types.Private
import IdeSession.Types.Progress
import IdeSession.Util
import qualified IdeSession.Strict.List as StrictList
import qualified IdeSession.Strict.Map as StrictMap
import qualified IdeSession.Types.Public as Public
import qualified GHC
import qualified ObjLink
import qualified Linker
import Hooks
import Run
import HsWalk
import GhcShim
import RTS
import Auxiliary
import RequestRunning
--------------------------------------------------------------------------------
-- Server-side operations --
--------------------------------------------------------------------------------
-- | Start the RPC server. Used from within the server executable.
ghcServer :: [String] -> IO ()
ghcServer args =
withSystemTempDirectory "ghc-server." $ \tmpDir -> do
-- Prepare the rts support module
rtsInfo <- deployRts tmpDir
-- Launch the server
rpcServer (ghcServerEngine rtsInfo) args
-- | The GHC server engine proper.
--
-- This function runs in end endless loop inside the @Ghc@ monad, making
-- incremental compilation possible.
ghcServerEngine :: RtsInfo -> FilePath -> RpcConversation -> IO ()
ghcServerEngine rtsInfo errorLog conv@RpcConversation{..} = do
-- The initial handshake with the client
(configGenerateModInfo, initOpts, sourceDir, sessionDir, distDir) <- handleInit conv
-- Submit static opts and get back leftover dynamic opts.
dOpts <- submitStaticOpts initOpts
-- Set up references for the current session of Ghc monad computations.
pluginRef <- newIORef StrictMap.empty
importsRef <- newIORef StrictMap.empty
stRef <- newIORef initExtractIdsSuspendedState
errsRef <- liftIO $ newIORef StrictList.nil
-- Get environment on server startup so that we can restore it
initEnv <- getEnvironment
-- Start handling requests. From this point on we don't leave the GHC monad.
runFromGhc $ do
-- Register startup options and perhaps our plugin in dynamic flags.
initSession distDir configGenerateModInfo dOpts rtsInfo errsRef stRef pluginRef progressCallback
-- We store the DynFlags _after_ setting the "static" options, so that
-- we restore to this state before every call to updateDynamicOpts
-- Note that this happens _after_ we have called setSessionDynFlags
-- and hence after the package DB has been initialized.
storeDynFlags
-- Make sure that the dynamic linker has been initialized. This is done
-- implicitly deep in the bowels of GhcMake.load, but if we attempt to load
-- C object files before calling GhcMake.load (i.e., before attempting to
-- compile any Haskell code) then loading the object files will fail if
-- they rely on linker flags such as @-lz@ (#214).
do dflags <- getSessionDynFlags
liftIO $ Linker.initDynLinker dflags
-- Start handling RPC calls
let go args = do
req <- liftIO get
args' <- case req of
ReqCompile genCode targets -> do
ghcHandleCompile
conv pluginRef importsRef errsRef sourceDir
genCode targets configGenerateModInfo
return args
ReqRun runCmd -> runCommand conv args sessionDir runCmd
ReqSetEnv env -> do
ghcHandleSetEnv conv initEnv env
return args
ReqSetArgs args' -> do
liftIO $ put ()
return args'
ReqBreakpoint mod span value -> do
ghcHandleBreak conv mod span value
return args
ReqPrint vars bind' forceEval -> do
ghcHandlePrint conv vars bind' forceEval
return args
ReqLoad objects -> do
ghcHandleLoad errorLog conv objects
return args
ReqUnload objects -> do
ghcHandleUnload conv objects
return args
ReqSetGhcOpts opts -> do
ghcHandleSetOpts conv opts
return args
ReqCrash delay -> do
ghcHandleCrash delay
return args
go args'
go []
where
progressCallback :: String -> IO ()
progressCallback ghcMsg = do
let ghcMsg' = Text.pack ghcMsg
case parseProgressMessage ghcMsg' of
Right (step, numSteps, msg) ->
put $ GhcCompileProgress Progress {
progressStep = step
, progressNumSteps = numSteps
, progressParsedMsg = Just msg
, progressOrigMsg = Just ghcMsg'
}
_ ->
-- Ignore messages we cannot parse
return ()
-- Register startup options and perhaps our plugin in dynamic flags.
--
-- This is the only place where the @packageDbArgs@ options are used
-- and indeed, as the first invocation of @setSessionDynFlags@,
-- this is the only place they could take any effect.
-- This also implies that any options specifying package DBs
-- passed via @updateGhcOptions@ won't have any effect in GHC API
initSession :: FilePath
-> Bool
-> DynamicOpts
-> RtsInfo
-> StrictIORef (Strict [] SourceError)
-> StrictIORef ExtractIdsSuspendedState
-> StrictIORef (Strict (Map ModuleName) PluginResult)
-> (String -> IO ())
-> Ghc ()
initSession distDir modInfo dOpts rtsInfo errsRef stRef pluginRef callback = do
flags <- getSessionDynFlags
(flags', _, _) <- parseDynamicFlags flags $ dOpts ++ dynOpts
let flags'' = (if modInfo then installHooks else id)
. installErrorLoggers
$ flags'
void $ setSessionDynFlags flags''
where
dynOpts :: DynamicOpts
dynOpts = optsToDynFlags [
"-package-db " ++ rtsPackageDb rtsInfo
, "-package " ++ rtsPackage rtsInfo
-- Include cabal_macros.h
, "-optP-include"
, "-optP" ++ cabalMacrosLocation distDir
]
installHooks :: DynFlags -> DynFlags
installHooks dflags = dflags {
hooks = (hooks dflags) {
hscFrontendHook = Just $ runHscPlugin pluginRef stRef
, runQuasiQuoteHook = Just $ runHscQQ stRef
, runRnSpliceHook = Just $ runRnSplice stRef
}
}
installErrorLoggers :: DynFlags -> DynFlags
installErrorLoggers dflags = dflags {
#if __GLASGOW_HASKELL__ >= 706
GHC.log_action = collectSrcError errsRef callback (\_ -> return ()) -- TODO: log?
#else
GHC.log_action = collectSrcError errsRef callback (\_ -> return ()) dflags
#endif
}
-- | We cache our own "module summaries" in between compile requests
data ModSummary = ModSummary {
-- | We cache the import lists so that we can check if the import
-- list for this module has changed, and hence whether we need to recompute
-- autocompletion info
modImports :: !(Strict [] Import)
-- | We cache the file stamp to see if the file has changed at all, and
-- hence whether we need to recompute the import list
, modTimestamp :: !GhcTime
-- | We cache whether this module was reported as "loaded" before so that
-- we can see which modules got unloaded
, modIsLoaded :: !Bool
}
-- | Client handshake
handleInit :: RpcConversation -> IO (Bool, [String], FilePath, FilePath, FilePath)
handleInit RpcConversation{..} = do
GhcInitRequest{..} <- get
-- Check API versions
unless (ghcInitClientApiVersion == ideBackendApiVersion) $
Ex.throwIO . userError $ "API version mismatch between ide-backend "
++ "(" ++ show ghcInitClientApiVersion ++ ") "
++ "and ide-backend-server "
++ "(" ++ show ideBackendApiVersion ++ ")"
-- Return initialization result to the client
put GhcInitResponse {
ghcInitVersion = ghcGetVersion
}
-- Setup parameters for the server
return ( ghcInitGenerateModInfo
, ghcInitOpts ++
packageDBFlags ghcInitUserPackageDB ghcInitSpecificPackageDBs
, ghcInitSourceDir
, ghcInitSessionDir
, ghcInitDistDir
)
-- | Handle a compile or type check request
ghcHandleCompile
:: RpcConversation
-> StrictIORef (Strict (Map ModuleName) PluginResult)
-- ^ ref where the ExtractIdsT plugin stores its data
-- (We clear this at the end of each call)
-> StrictIORef (Strict (Map ModuleName) ModSummary)
-- ^ see doc for 'ModSummary'
-> StrictIORef (Strict [] SourceError)
-- ^ the IORef where GHC stores errors
-> FilePath -- ^ source directory
-> Bool -- ^ should we generate code
-> Public.Targets -- ^ targets
-> Bool -- ^ should we generate per-module info
-> Ghc ()
ghcHandleCompile RpcConversation{..}
pluginRef modsRef errsRef configSourcesDir
ideGenerateCode targets configGenerateModInfo = do
-- | Half of a workaround for
-- http://hackage.haskell.org/trac/ghc/ticket/7456. We suppress stdout
-- during compilation to avoid stray messages, e.g. from the linker.
--
-- TODO: Should we log the suppressed messages?
(_suppressed, (errs, loadedModules, fileMap)) <-
captureGhcOutput $ compileInGhc configSourcesDir
ideGenerateCode
targets
errsRef
let initialResponse = GhcCompileResult {
ghcCompileErrors = errs
, ghcCompileLoaded = force loadedModules
, ghcCompileFileMap = fileMap
, ghcCompileCache = error "ghcCompileCache set last"
-- We construct the diffs incrementally
, ghcCompileImports = StrictMap.empty
, ghcCompileAuto = StrictMap.empty
, ghcCompilePkgDeps = StrictMap.empty
, ghcCompileSpanInfo = StrictMap.empty
, ghcCompileExpTypes = StrictMap.empty
, ghcCompileUseSites = StrictMap.empty
}
response <- if not configGenerateModInfo
then return initialResponse
else do
pluginIdMaps <- liftIO $ do
idMaps <- readIORef pluginRef
writeIORef pluginRef StrictMap.empty
return idMaps
let recompiledModules :: [ModuleName]
recompiledModules = StrictMap.keys pluginIdMaps
-- Strictly speaking, this check is not entirely accurate, because
-- we ignore the package of the imported module. However, I don't
-- think this can lead to actual problems, because if modules
-- between packages overlap this will cause trouble elsewhere.
gotRecompiled :: Import -> Bool
gotRecompiled imp =
moduleName (importModule imp) `elem` recompiledModules
removeOldModule :: ModuleName -> StateT GhcCompileResult Ghc ()
removeOldModule m = do
set (importsFor m) Remove
set (autoFor m) Remove
set (spanInfoFor m) Remove
set (expTypesFor m) Remove
set (useSitesFor m) Remove
set (pkgDepsFor m) Remove
addNewModule :: (ModuleName, GHC.ModSummary)
-> StateT GhcCompileResult Ghc (ModuleName, ModSummary)
addNewModule (m, ghcSummary) = do
imports <- lift $ importList ghcSummary
auto <- lift $ autocompletion ghcSummary
set (importsFor m) (Insert imports)
set (autoFor m) (Insert auto)
-- Information computed by the plugin set separately
let newSummary = ModSummary {
modTimestamp = ms_hs_date ghcSummary
, modImports = imports
, modIsLoaded = m `elem` loadedModules
}
return (m, newSummary)
updateSourceFile :: ModuleName -> ModSummary -> GHC.ModSummary
-> StateT GhcCompileResult Ghc (ModuleName, ModSummary)
updateSourceFile m oldSummary ghcSummary = do
(imports, importsChanged) <-
-- We recompute imports when the file changed, rather than when
-- it got (successfully) recompiled because we provide the
-- imports even for modules with type errors
if modTimestamp oldSummary == ms_hs_date ghcSummary
then return (modImports oldSummary, False)
else do imports <- lift $ importList ghcSummary
set (importsFor m) (Insert imports)
return (imports, imports /= modImports oldSummary)
-- We recompute autocompletion info if the imported modules have
-- been recompiled. TODO: We might be able to optimize this by
-- checking one of ghc's various hashes to avoid recomputing
-- autocompletion info even if an imported module got recompiled,
-- but it's interface did not change (`mi_iface_hash` perhaps?)
-- TODO: We might also be able to make this check more fine
-- grained and recompute autocompletion info for some imports,
-- but not for others.
when (importsChanged || StrictList.any gotRecompiled imports) $ do
auto <- lift $ autocompletion ghcSummary
set (autoFor m) (Insert auto)
let newSummary = ModSummary {
modTimestamp = ms_hs_date ghcSummary
, modImports = imports
, modIsLoaded = m `elem` loadedModules
}
when (not (modIsLoaded newSummary)) $ do
set (spanInfoFor m) Remove
set (pkgDepsFor m) Remove
set (expTypesFor m) Remove
set (useSitesFor m) Remove
return (m, newSummary)
let go :: [(ModuleName, ModSummary)]
-> [(ModuleName, GHC.ModSummary)]
-> StateT GhcCompileResult Ghc [(ModuleName, ModSummary)]
go ((m, oldSummary) : old) ((m', ghcSummary) : new) = do
case compare m m' of
LT -> do removeOldModule m
go old ((m', ghcSummary) : new)
GT -> do newSummary <- addNewModule (m', ghcSummary)
newSummaries <- go ((m, oldSummary) : old) new
return $ newSummary : newSummaries
EQ -> do newSummary <- updateSourceFile m oldSummary ghcSummary
newSummaries <- go old new
return $ newSummary : newSummaries
go old new = do
mapM_ removeOldModule (map fst old)
mapM addNewModule new
let sendPluginResult :: [(ModuleName, PluginResult)]
-> StateT GhcCompileResult Ghc ()
sendPluginResult = mapM_ $ \(m, PluginResult{..}) -> do
set (spanInfoFor m) (Insert pluginIdList)
set (pkgDepsFor m) (Insert pluginPkgDeps)
set (expTypesFor m) (Insert pluginExpTypes)
set (useSitesFor m) (Insert pluginUseSites)
(newSummaries, finalResponse) <- flip runStateT initialResponse $ do
sendPluginResult (StrictMap.toList pluginIdMaps)
graph <- lift getModuleGraph
let name s = Text.pack (moduleNameString (ms_mod_name s))
namedGraph = map (\s -> (name s, s)) graph
sortedGraph = List.sortBy (compare `on` fst) namedGraph
oldSummaries <- lift . liftIO $ readIORef modsRef
go (StrictMap.toList oldSummaries) sortedGraph
liftIO $ writeIORef modsRef (StrictMap.fromList newSummaries)
return finalResponse
cache <- liftIO constructExplicitSharingCache
let fullResponse = response { ghcCompileCache = cache }
-- TODO: Should we clear the link env caches here?
liftIO $ put (GhcCompileDone fullResponse)
where
-- Various accessors
allImports = accessor ghcCompileImports (\is st -> st { ghcCompileImports = is })
allAuto = accessor ghcCompileAuto (\as st -> st { ghcCompileAuto = as })
allSpanInfo = accessor ghcCompileSpanInfo (\ss st -> st { ghcCompileSpanInfo = ss })
allPkgDeps = accessor ghcCompilePkgDeps (\ds st -> st { ghcCompilePkgDeps = ds })
allExpTypes = accessor ghcCompileExpTypes (\ts st -> st { ghcCompileExpTypes = ts })
allUseSites = accessor ghcCompileUseSites (\us st -> st { ghcCompileUseSites = us })
importsFor m = allImports .> StrictMap.accessorDefault Keep m
autoFor m = allAuto .> StrictMap.accessorDefault Keep m
spanInfoFor m = allSpanInfo .> StrictMap.accessorDefault Keep m
pkgDepsFor m = allPkgDeps .> StrictMap.accessorDefault Keep m
expTypesFor m = allExpTypes .> StrictMap.accessorDefault Keep m
useSitesFor m = allUseSites .> StrictMap.accessorDefault Keep m
-- | Handle a break request
ghcHandleBreak :: RpcConversation -> ModuleName -> Public.SourceSpan -> Bool -> Ghc ()
ghcHandleBreak RpcConversation{..} modName span value = do
oldValue <- breakFromSpan modName span value
liftIO $ put oldValue
-- | Handle a print request
ghcHandlePrint :: RpcConversation -> Public.Name -> Bool -> Bool -> Ghc ()
ghcHandlePrint RpcConversation{..} var bind' forceEval = do
vals <- printVars (Text.unpack var) bind' forceEval
liftIO $ put vals
-- | Handle a load object request
ghcHandleLoad :: FilePath -> RpcConversation -> [FilePath] -> Ghc ()
ghcHandleLoad errorLog RpcConversation{..} objects =
liftIO $ do
-- If loadObj fails, it fails with a hard crash (not an exception) and
-- hence we cannot capture the output. Instead, we redirect it to the
-- error log so that if the crash does happen, the RPC infastructure
-- will read this log file and use its constents to report an error.
redirectStderr errorLog $ mapM_ ObjLink.loadObj objects
-- Although resolveObjs does _not_ fail quite so spectacularly, it still
-- writes its error messages to stdout.
(suppressed, success) <- captureOutput ObjLink.resolveObjs
let response :: Maybe String
response =
case success of
GHC.Failed -> Just suppressed
GHC.Succeeded -> Nothing
put response
-- | Handle an unload object request
ghcHandleUnload :: RpcConversation -> [FilePath] -> Ghc ()
ghcHandleUnload RpcConversation{..} objects = liftIO $ do
mapM_ ObjLink.unloadObj objects
put ()
-- | Handle a set-environment request
ghcHandleSetEnv :: RpcConversation -> [(String, String)] -> [(String, Maybe String)] -> Ghc ()
ghcHandleSetEnv RpcConversation{put} initEnv overrides = liftIO $ do
setupEnv initEnv overrides
put ()
-- | Set ghc options
ghcHandleSetOpts :: RpcConversation -> [String] -> Ghc ()
ghcHandleSetOpts RpcConversation{put} opts = do
(leftover, warnings) <- setGhcOptions opts
liftIO $ put (leftover, warnings)
-- | Handle a crash request (debugging)
ghcHandleCrash :: Maybe Int -> Ghc ()
ghcHandleCrash delay = liftIO $ do
case delay of
Nothing -> Ex.throwIO crash
Just i -> do tid <- myThreadId
void . forkIO $ threadDelay i >> throwTo tid crash
where
crash = userError "Intentional crash"