content: {-# 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"
  