Soulomoon/relax test runs

cabal.project

@@ -19,7 +19,7 @@ write-ghc-environment-files: never
 -- Many of our tests only work single-threaded, and the only way to
 -- ensure tasty runs everything purely single-threaded is to pass
 -- this at the top-level
-test-options: -j1
+-- test-options: -j1
 
 -- Make sure dependencies are build with haddock so we get
 -- haddock shown on hover

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 cwd (cmapWithPrio pretty recorder) (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 argsCwd (cmapWithPrio LogIDEMain recorder) hlsPlugins
+          else IDEMain.defaultArguments argsCwd (cmapWithPrio LogIDEMain recorder) 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/session-loader/Development/IDE/Session.hs

@@ -437,8 +437,13 @@
 loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSession)
 loadSession recorder = loadSessionWithOptions recorder def
 
+toAbsolute :: FilePath -> FilePath -> FilePath
+toAbsolute dir file
+    | isAbsolute file = file
+    | otherwise = dir </> file
 loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession)
-loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
+loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do
+  let toAbsolutePath = toAbsolute rootDir
   cradle_files <- newIORef []
   -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
   hscEnvs <- newVar Map.empty :: IO (Var HieMap)
@@ -459,7 +464,7 @@
       -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path
       -- try and normalise that
       -- e.g. see https://github.com/haskell/ghcide/issues/126
-      res' <- traverse makeAbsolute res
+      let res' = toAbsolutePath <$> res
       return $ normalise <$> res'
 
   dummyAs <- async $ return (error "Uninitialised")
@@ -521,7 +526,7 @@
         packageSetup (hieYaml, cfp, opts, libDir) = do
           -- Parse DynFlags for the newly discovered component
           hscEnv <- emptyHscEnv ideNc libDir
-          newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv)
+          newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv) rootDir
           let deps = componentDependencies opts ++ maybeToList hieYaml
           dep_info <- getDependencyInfo deps
           -- Now lookup to see whether we are combining with an existing HscEnv
@@ -588,7 +593,7 @@
           -- HscEnv but set the active component accordingly
           hscEnv <- emptyHscEnv ideNc _libDir
           let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv
-          all_target_details <- new_cache old_deps new_deps
+          all_target_details <- new_cache old_deps new_deps rootDir
 
           this_dep_info <- getDependencyInfo $ maybeToList hieYaml
           let (all_targets, this_flags_map, this_options)
@@ -632,15 +637,15 @@
 
     let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
         consultCradle hieYaml cfp = do
-           lfpLog <- flip makeRelative cfp <$> getCurrentDirectory
+           let lfpLog = makeRelative rootDir cfp
            logWith recorder Info $ LogCradlePath lfpLog
 
            when (isNothing hieYaml) $
              logWith recorder Warning $ LogCradleNotFound lfpLog
 
-           cradle <- loadCradle recorder hieYaml dir
+           cradle <- loadCradle recorder hieYaml rootDir
            -- TODO: Why are we repeating the same command we have on line 646?
-           lfp <- flip makeRelative cfp <$> getCurrentDirectory
+           let lfp = makeRelative rootDir cfp
 
            when optTesting $ mRunLspT lspEnv $
             sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp)
@@ -668,7 +673,7 @@
                  InstallationMismatch{..} ->
                      return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])
                  InstallationChecked _compileTime _ghcLibCheck -> do
                    atomicModifyIORef' cradle_files (\xs -> (cfp:xs,()))
                    session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)
              -- Failure case, either a cradle error or the none cradle
              Left err -> do
@@ -713,7 +718,7 @@
             modifyVar_ hscEnvs (const (return Map.empty))
 
           v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags
-          cfp <- makeAbsolute file
+          let cfp = toAbsolutePath file
           case HM.lookup (toNormalizedFilePath' cfp) v of
             Just (opts, old_di) -> do
               deps_ok <- checkDependencyInfo old_di
@@ -735,7 +740,7 @@
     -- before attempting to do so.
     let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
         getOptions file = do
-            ncfp <- toNormalizedFilePath' <$> makeAbsolute file
+            let ncfp = toNormalizedFilePath' (toAbsolutePath file)
             cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap
             hieYaml <- cradleLoc file
             sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e ->
@@ -747,7 +752,7 @@
         void $ wait as
         asyncRes <- async $ getOptions file
         return (asyncRes, wait asyncRes)
-      pure opts
+      pure $ (fmap . fmap) toAbsolutePath opts
 
 -- | Run the specific cradle on a specific FilePath via hie-bios.
 -- This then builds dependencies or whatever based on the cradle, gets the
@@ -814,19 +819,20 @@
              -> TargetId
              -> IdeResult HscEnvEq
              -> DependencyInfo
+             -> FilePath
              -> IO [TargetDetails]
 -- For a target module we consider all the import paths
-fromTargetId is exts (GHC.TargetModule modName) env dep = do
+fromTargetId is exts (GHC.TargetModule modName) env dep dir = do
     let fps = [i </> moduleNameSlashes modName -<.> ext <> boot
               | ext <- exts
               , i <- is
               , boot <- ["", "-boot"]
               ]
-    locs <- mapM (fmap toNormalizedFilePath' . makeAbsolute) fps
+    let locs = fmap (toNormalizedFilePath' . toAbsolute dir) fps
     return [TargetDetails (TargetModule modName) env dep locs]
 -- For a 'TargetFile' we consider all the possible module names
-fromTargetId _ _ (GHC.TargetFile f _) env deps = do
-    nf <- toNormalizedFilePath' <$> makeAbsolute f
+fromTargetId _ _ (GHC.TargetFile f _) env deps dir = do
+    let nf = toNormalizedFilePath' $ toAbsolute dir f
     let other
           | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf)
           | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot")
@@ -915,8 +921,9 @@
          -> HscEnv             -- ^ An empty HscEnv
          -> [ComponentInfo]    -- ^ New components to be loaded
          -> [ComponentInfo]    -- ^ old, already existing components
+         -> FilePath           -- ^ root dir
          -> IO [ [TargetDetails] ]
-newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do
+newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis dir = do
     let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis)
         -- When we have multiple components with the same uid,
         -- prefer the new one over the old.
@@ -961,7 +968,7 @@
 
     forM (Map.elems cis) $ \ci -> do
       let df = componentDynFlags ci
-      let createHscEnvEq = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath
+      let createHscEnvEq = maybe newHscEnvEqPreserveImportPaths (newHscEnvEq dir) cradlePath
       thisEnv <- do
 #if MIN_VERSION_ghc(9,3,0)
             -- In GHC 9.4 we have multi component support, and we have initialised all the units
@@ -986,7 +993,7 @@
       logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends)
       evaluate $ liftRnf rwhnf $ componentTargets ci
 
-      let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends
+      let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends dir
       ctargets <- concatMapM mk (componentTargets ci)
 
       return (L.nubOrdOn targetTarget ctargets)
@@ -1171,8 +1178,8 @@
   putCmdLineState (unit_str : units)
 
 -- | Throws if package flags are unsatisfiable
-setOptions :: GhcMonad m => NormalizedFilePath -> ComponentOptions -> DynFlags -> m (NonEmpty (DynFlags, [GHC.Target]))
-setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do
+setOptions :: GhcMonad m => NormalizedFilePath -> ComponentOptions -> DynFlags -> FilePath -> m (NonEmpty (DynFlags, [GHC.Target]))
+setOptions cfp (ComponentOptions theOpts compRoot _) dflags dir = do
     ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts)
     case NE.nonEmpty units of
       Just us -> initMulti us
@@ -1195,7 +1202,7 @@
         --
         -- If we don't end up with a target for the current file in the end, then
         -- we will report it as an error for that file
-        abs_fp <- liftIO $ makeAbsolute (fromNormalizedFilePath cfp)
+        let abs_fp = toAbsolute dir (fromNormalizedFilePath cfp)
         let special_target = Compat.mkSimpleTarget df abs_fp
         pure $ (df, special_target : targets) :| []
     where

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/Rules.hs

@@ -159,8 +159,7 @@
 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)
 
 
@@ -719,8 +718,7 @@
         -- 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
@@ -818,7 +816,7 @@
             { source_version = ver
             , old_value = m_old
             , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}
             , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs
             , regenerate = regenerateHiFile session f ms
             }
       r <- loadInterface (hscEnv session) ms linkableType recompInfo
@@ -848,7 +846,7 @@
       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)
@@ -1090,7 +1088,7 @@
             -- thus bump its modification time, forcing this rule to be rerun every time.
             exists <- liftIO $ doesFileExist obj_file
             mobj_time <- liftIO $
               if exists
               then Just <$> getModTime obj_file
               else pure Nothing
             case mobj_time of

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,
@@ -123,7 +123,7 @@
 import           Development.IDE.Core.ProgressReporting
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Tracing
 import           Development.IDE.GHC.Compat             (NameCache,
                                                          initNameCache,
                                                          knownKeyNames)
 import           Development.IDE.GHC.Orphans            ()
@@ -535,6 +535,7 @@
     ,shakeExtras          :: ShakeExtras
     ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath)
     ,stopMonitoring       :: IO ()
+    ,rootDir              :: FilePath
     }
 
 
@@ -623,11 +624,12 @@
           -> 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

@@ -125,15 +125,16 @@ runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigCh
 
 setupLSP ::
      forall config err.
-     Recorder (WithPriority Log)
+     FilePath -- ^ root directory
+  -> Recorder (WithPriority Log)
   -> (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 root recorder 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
@@ -176,28 +177,29 @@ 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 root recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan
 
   let interpretHandler (env,  st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO
 
   pure (doInitialize, asyncHandlers, interpretHandler)
 
 
 handleInit
-    :: Recorder (WithPriority Log)
+    :: FilePath
+    -> Recorder (WithPriority Log)
     -> (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 rootDir recorder 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
+    let rootMaybe = LSP.resRootPath env
+    let root = fromMaybe rootDir rootMaybe
+    dbLoc <- getHieDbLoc root
     let initConfig = parseConfiguration params
     logWith recorder Info $ LogRegisteringIdeConfig initConfig
     dbMVar <- newEmptyMVar