Soulomoon/refactor session

exe/Wrapper.hs

@@ -1,4 +1,4 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -269,7 +269,8 @@
 -- to shut down the LSP.
 launchErrorLSP :: Recorder (WithPriority (Doc ())) -> T.Text -> IO ()
 launchErrorLSP recorder errorMsg = do
-  let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) (IdePlugins [])
+  cwd <- getCurrentDirectory
+  let defaultArguments = Main.defaultArguments (cmapWithPrio pretty recorder) cwd (IdePlugins [])
 
   inH <- Main.argsHandleIn defaultArguments
 

ghcide/exe/Main.hs

@@ -112,11 +112,11 @@ main = withTelemetryRecorder $ \telemetryRecorder -> do
 
     let arguments =
           if argsTesting
-          then IDEMain.testing (cmapWithPrio LogIDEMain recorder) hlsPlugins
-          else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) hlsPlugins
+          then IDEMain.testing (cmapWithPrio LogIDEMain recorder) argsCwd hlsPlugins
+          else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) argsCwd hlsPlugins
 
     IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments
-        { IDEMain.argsProjectRoot = Just argsCwd
+        { IDEMain.argsProjectRoot = argsCwd
         , IDEMain.argCommand = argsCommand
         , IDEMain.argsHlsPlugins = IDEMain.argsHlsPlugins arguments <> pluginDescToIdePlugins [lspRecorderPlugin]
 

ghcide/src/Development/IDE.hs

@@ -31,7 +31,7 @@ import           Development.IDE.Core.Shake            as X (FastResult (..),
                                                              defineNoDiagnostics,
                                                              getClientConfig,
                                                              getPluginConfigAction,
-                                                             ideLogger,
+                                                             ideLogger, rootDir,
                                                              runIdeAction,
                                                              shakeExtras, use,
                                                              useNoFile,

ghcide/src/Development/IDE/Core/RuleTypes.hs

@@ -492,14 +492,27 @@ data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Typeable, Generic)
 instance Hashable AddWatchedFile
 instance NFData   AddWatchedFile
 
+data CradleLoc = CradleLoc deriving (Eq, Show, Typeable, Generic)
+instance Hashable CradleLoc
+instance NFData   CradleLoc
+type instance RuleResult CradleLoc = Maybe FilePath
+
+data HieYaml = HieYaml deriving (Eq, Show, Typeable, Generic)
+instance Hashable HieYaml
+instance NFData   HieYaml
+
+data SessionCacheVersion = SessionCacheVersion deriving (Eq, Show, Typeable, Generic)
+instance Hashable SessionCacheVersion
+instance NFData   SessionCacheVersion
+type instance RuleResult SessionCacheVersion = Int
 
 -- A local rule type to get caching. We want to use newCache, but it has
 -- thread killed exception issues, so we lift it to a full rule.
 -- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547
 type instance RuleResult GhcSessionIO = IdeGhcSession
 
 data IdeGhcSession = IdeGhcSession
-  { loadSessionFun :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
+  { loadSessionFun :: NormalizedFilePath -> Action (IdeResult HscEnvEq, [FilePath])
   -- ^ Returns the Ghc session and the cradle dependencies
   , sessionVersion :: !Int
   -- ^ Used as Shake key, versions must be unique and not reused

ghcide/src/Development/IDE/Core/Rules.hs

@@ -164,8 +164,7 @@ import           Language.LSP.Server                          (LspT)
 import qualified Language.LSP.Server                          as LSP
 import           Language.LSP.VFS
 import           Prelude                                      hiding (mod)
-import           System.Directory                             (doesFileExist,
-                                                               makeAbsolute)
+import           System.Directory                             (doesFileExist)
 import           System.Info.Extra                            (isWindows)
 
 
@@ -179,6 +178,8 @@ import           GHC                                          (mgModSummaries)
 
 #if MIN_VERSION_ghc(9,3,0)
 import qualified Data.IntMap                                  as IM
+import HIE.Bios (findCradle)
+import System.FilePath (normalise)
 #endif
 
 
@@ -192,6 +193,7 @@ data Log
   | LogTypecheckedFOI !NormalizedFilePath
   deriving Show
 
+
 instance Pretty Log where
   pretty = \case
     LogShake msg -> pretty msg
@@ -719,13 +721,13 @@ loadGhcSession recorder ghcSessionDepsConfig = do
 
     defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do
         IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO
-        (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file
+        -- loading is always returning a absolute path now
+        (val,deps) <- loadSessionFun file
 
         -- add the deps to the Shake graph
         let addDependency fp = do
                 -- VSCode uses absolute paths in its filewatch notifications
-                afp <- liftIO $ makeAbsolute fp
-                let nfp = toNormalizedFilePath' afp
+                let nfp = toNormalizedFilePath' fp
                 itExists <- getFileExists nfp
                 when itExists $ void $ do
                   use_ GetModificationTime nfp
@@ -853,7 +855,7 @@ getModIfaceFromDiskAndIndexRule recorder =
       hie_loc = Compat.ml_hie_file $ ms_location ms
   fileHash <- liftIO $ Util.getFileHash hie_loc
   mrow <- liftIO $ withHieDb (\hieDb -> HieDb.lookupHieFileFromSource hieDb (fromNormalizedFilePath f))
-  hie_loc' <- liftIO $ traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow
+  let hie_loc' = HieDb.hieModuleHieFile <$> mrow
   case mrow of
     Just row
       | fileHash == HieDb.modInfoHash (HieDb.hieModInfo row)

ghcide/src/Development/IDE/Core/Service.hs

@@ -67,8 +67,9 @@ initialise :: Recorder (WithPriority Log)
            -> WithHieDb
            -> IndexQueue
            -> Monitoring
+           -> FilePath
            -> IO IdeState
-initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics = do
+initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics rootDir = do
     shakeProfiling <- do
         let fromConf = optShakeProfiling options
         fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING"
@@ -86,11 +87,12 @@ initialise recorder defaultConfig plugins mainRule lspEnv debouncer options with
         hiedbChan
         (optShakeOptions options)
         metrics
-          $ do
+        (do
             addIdeGlobal $ GlobalIdeOptions options
             ofInterestRules (cmapWithPrio LogOfInterest recorder)
             fileExistsRules (cmapWithPrio LogFileExists recorder) lspEnv
-            mainRule
+            mainRule)
+        rootDir
 
 -- | Shutdown the Compiler Service.
 shutdown :: IdeState -> IO ()

ghcide/src/Development/IDE/Core/Shake.hs

@@ -22,7 +22,7 @@
 --   always stored as real Haskell values, whereas Shake serialises all 'A' values
 --   between runs. To deserialise a Shake value, we just consult Values.
 module Development.IDE.Core.Shake(
-    IdeState, shakeSessionInit, shakeExtras, shakeDb,
+    IdeState, shakeSessionInit, shakeExtras, shakeDb, rootDir,
     ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
     KnownTargets, Target(..), toKnownFiles,
     IdeRule, IdeResult,
@@ -535,6 +535,7 @@ data IdeState = IdeState
     ,shakeExtras          :: ShakeExtras
     ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath)
     ,stopMonitoring       :: IO ()
+    ,rootDir              :: FilePath
     }
 
 
@@ -623,11 +624,12 @@ shakeOpen :: Recorder (WithPriority Log)
           -> ShakeOptions
           -> Monitoring
           -> Rules ()
+          -> FilePath
           -> IO IdeState
 shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
   shakeProfileDir (IdeReportProgress reportProgress)
   ideTesting@(IdeTesting testing)
-  withHieDb indexQueue opts monitoring rules = mdo
+  withHieDb indexQueue opts monitoring rules rootDir = mdo
 
 #if MIN_VERSION_ghc(9,3,0)
     ideNc <- initNameCache 'r' knownKeyNames

ghcide/src/Development/IDE/LSP/LanguageServer.hs

@@ -127,14 +127,15 @@ runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigCh
 setupLSP ::
      forall config err.
      Recorder (WithPriority Log)
+  -> FilePath -- ^ root directory
   -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project
   -> LSP.Handlers (ServerM config)
-  -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
+  -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
   -> MVar ()
   -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)),
          LSP.Handlers (ServerM config),
          (LanguageContextEnv config, IdeState) -> ServerM config <~> IO)
-setupLSP  recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do
+setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar = do
   -- Send everything over a channel, since you need to wait until after initialise before
   -- LspFuncs is available
   clientMsgChan :: Chan ReactorMessage <- newChan
@@ -177,7 +178,7 @@ setupLSP  recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do
         -- Cancel requests are special since they need to be handled
         -- out of order to be useful. Existing handlers are run afterwards.
 
-  let doInitialize = handleInit recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan
+  let doInitialize = handleInit recorder defaultRoot getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan
 
   let interpretHandler (env,  st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO
 
@@ -186,19 +187,22 @@ setupLSP  recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do
 
 handleInit
     :: Recorder (WithPriority Log)
+    -> FilePath
     -> (FilePath -> IO FilePath)
-    -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
+    -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState)
     -> MVar ()
     -> IO ()
     -> (SomeLspId -> IO ())
     -> (SomeLspId -> IO ())
     -> Chan ReactorMessage
     -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))
-handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do
+handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do
     traceWithSpan sp params
-    let root = LSP.resRootPath env
-    dir <- maybe getCurrentDirectory return root
-    dbLoc <- getHieDbLoc dir
+    -- only shift if lsp root is different from the rootDir
+    root <- case LSP.resRootPath env of
+        Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot
+        _ -> pure defaultRoot
+    dbLoc <- getHieDbLoc root
     let initConfig = parseConfiguration params
     logWith recorder Info $ LogRegisteringIdeConfig initConfig
     dbMVar <- newEmptyMVar

ghcide/src/Development/IDE/Main.hs

@@ -208,7 +208,7 @@ commandP plugins =
 
 
 data Arguments = Arguments
-    { argsProjectRoot           :: Maybe FilePath
+    { argsProjectRoot           :: FilePath
     , argCommand                :: Command
     , argsRules                 :: Rules ()
     , argsHlsPlugins            :: IdePlugins IdeState
@@ -226,9 +226,9 @@ data Arguments = Arguments
     , argsDisableKick           :: Bool -- ^ flag to disable kick used for testing
     }
 
-defaultArguments :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments
-defaultArguments recorder plugins = Arguments
-        { argsProjectRoot = Nothing
+defaultArguments :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments
+defaultArguments recorder fp plugins = Arguments
+        { argsProjectRoot = fp
         , argCommand = LSP
         , argsRules = mainRule (cmapWithPrio LogRules recorder) def
         , argsGhcidePlugin = mempty
@@ -271,11 +271,11 @@ defaultArguments recorder plugins = Arguments
         }
 
 
-testing :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments
-testing recorder plugins =
+testing :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments
+testing recorder fp plugins =
   let
-    arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } =
-        defaultArguments recorder plugins
+    arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions  } =
+        defaultArguments recorder fp plugins
     hlsPlugins = pluginDescToIdePlugins $
       idePluginsToPluginDesc argsHlsPlugins
       ++ [Test.blockCommandDescriptor "block-command", Test.plugin]
@@ -326,22 +326,18 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
             logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins)
 
             ideStateVar <- newEmptyMVar
-            let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState
+            let getIdeState :: LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState
                 getIdeState env rootPath withHieDb hieChan = do
-                  traverse_ IO.setCurrentDirectory rootPath
                   t <- ioT
                   logWith recorder Info $ LogLspStartDuration t
-
-                  dir <- maybe IO.getCurrentDirectory return rootPath
-
                   -- We want to set the global DynFlags right now, so that we can use
                   -- `unsafeGlobalDynFlags` even before the project is configured
                   _mlibdir <-
-                      setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions
+                      setInitialDynFlags (cmapWithPrio LogSession recorder) rootPath argsSessionLoadingOptions
                           -- TODO: should probably catch/log/rethrow at top level instead
                           `catchAny` (\e -> logWith recorder Error (LogSetInitialDynFlagsException e) >> pure Nothing)
 
-                  sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir
+                  (sessionLoaderRule, sessionLoader) <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath
                   config <- LSP.runLspT env LSP.getConfig
                   let def_options = argsIdeOptions config sessionLoader
 
@@ -360,17 +356,18 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
                       (cmapWithPrio LogService recorder)
                       argsDefaultHlsConfig
                       argsHlsPlugins
-                      rules
+                      (rules <> sessionLoaderRule)
                       (Just env)
                       debouncer
                       ideOptions
                       withHieDb
                       hieChan
                       monitoring
+                      rootPath
                   putMVar ideStateVar ide
                   pure ide
 
-            let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState
+            let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsProjectRoot argsGetHieDbLoc (pluginHandlers plugins) getIdeState
                 -- See Note [Client configuration in Rules]
                 onConfigChange cfg = do
                   -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint
@@ -388,7 +385,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
             runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup
             dumpSTMStats
         Check argFiles -> do
-          dir <- maybe IO.getCurrentDirectory return argsProjectRoot
+          let dir = argsProjectRoot
           dbLoc <- getHieDbLoc dir
           runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do
             -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
@@ -411,14 +408,14 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
             putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]
             when (n > 0) $ putStrLn $ "  (" ++ intercalate ", " (catMaybes ucradles) ++ ")"
             putStrLn "\nStep 3/4: Initializing the IDE"
-            sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir
+            (sessionLoaderRule, sessionLoader) <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir
             let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader
                 ideOptions = def_options
                         { optCheckParents = pure NeverCheck
                         , optCheckProject = pure False
                         , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
                         }
-            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty
+            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins (rules <> sessionLoaderRule) Nothing debouncer ideOptions hiedb hieChan mempty dir
             shakeSessionInit (cmapWithPrio LogShake recorder) ide
             registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
 
@@ -436,7 +433,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
 
             unless (null failed) (exitWith $ ExitFailure (length failed))
         Db opts cmd -> do
-            root <-  maybe IO.getCurrentDirectory return argsProjectRoot
+            let root = argsProjectRoot
             dbLoc <- getHieDbLoc root
             hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc
             mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) root def
@@ -446,17 +443,17 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
                 Just libdir -> retryOnSqliteBusy (cmapWithPrio LogSession recorder) rng (HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd)
 
         Custom (IdeCommand c) -> do
-          root <-  maybe IO.getCurrentDirectory return argsProjectRoot
+          let root = argsProjectRoot
           dbLoc <- getHieDbLoc root
           runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do
-            sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "."
+            (sessionLoaderRule, sessionLoader) <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "."
             let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader
                 ideOptions = def_options
                     { optCheckParents = pure NeverCheck
                     , optCheckProject = pure False
                     , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins
                     }
-            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty
+            ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins (rules <> sessionLoaderRule) Nothing debouncer ideOptions hiedb hieChan mempty root
             shakeSessionInit (cmapWithPrio LogShake recorder) ide
             registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing)
             c ide