diff --git a/cabal.project b/cabal.project index d7339b4d80..9d7363e1cb 100644 --- a/cabal.project +++ b/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 diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 6de88abcc0..0309840c97 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -269,7 +269,8 @@ newtype ErrorLSPM c a = ErrorLSPM { unErrorLSPM :: (LspM c) a } -- 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 diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index b3b63fbaf5..959cd8c9d2 100644 --- a/ghcide/exe/Main.hs +++ b/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] diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 71688afd1d..79334e72d3 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -437,8 +437,13 @@ getHieDbLoc dir = do 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 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- 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 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do 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 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- 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 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do 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) @@ -713,7 +718,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do 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 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- 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 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do 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 @@ fromTargetId :: [FilePath] -- ^ import paths -> 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 @@ newComponentCache -> 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 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do 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 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do 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 @@ addUnit unit_str = liftEwM $ do 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 @@ setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do -- -- 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 diff --git a/ghcide/src/Development/IDE.hs b/ghcide/src/Development/IDE.hs index 15cee28f04..547ac9a115 100644 --- a/ghcide/src/Development/IDE.hs +++ b/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, diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 609736fc72..55094bca47 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -159,8 +159,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) @@ -719,8 +718,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do -- 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 @@ -848,7 +846,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) diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index cdb5ba72cb..f59d0b4afa 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/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 () diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 5325b14e7e..aaa2294852 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 76893c38a0..1ea8dd6a1a 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/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,7 +177,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 root recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO @@ -184,20 +185,21 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do 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 diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index b4aa72f5fa..a41d9199e0 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/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 :: FilePath -> Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments +defaultArguments fp recorder plugins = Arguments + { argsProjectRoot = fp , argCommand = LSP , argsRules = mainRule (cmapWithPrio LogRules recorder) def , argsGhcidePlugin = mempty @@ -263,11 +263,11 @@ defaultArguments recorder plugins = Arguments } -testing :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments -testing recorder plugins = +testing :: FilePath -> Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments +testing fp recorder plugins = let arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = - defaultArguments recorder plugins + defaultArguments fp recorder plugins hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins ++ [Test.blockCommandDescriptor "block-command", Test.plugin] @@ -316,22 +316,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 + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath config <- LSP.runLspT env LSP.getConfig let def_options = argsIdeOptions config sessionLoader @@ -357,10 +353,11 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re withHieDb hieChan monitoring + rootPath putMVar ideStateVar ide pure ide - let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsGetHieDbLoc (pluginHandlers plugins) getIdeState + let setup = setupLSP argsProjectRoot (cmapWithPrio LogLanguageServer recorder) 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 @@ -378,7 +375,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 @@ -408,7 +405,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , 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 Nothing debouncer ideOptions hiedb hieChan mempty dir shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -426,7 +423,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 @@ -436,7 +433,7 @@ 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 "." @@ -446,7 +443,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , 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 Nothing debouncer ideOptions hiedb hieChan mempty root shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index 502c265077..d6760071f4 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -29,7 +29,6 @@ import Development.IDE.GHC.Util (lookupPackageConfig) import Development.IDE.Graph.Classes import Development.IDE.Types.Exports (ExportsMap, createExportsMap) import OpenTelemetry.Eventlog (withSpan) -import System.Directory (makeAbsolute) import System.FilePath -- | An 'HscEnv' with equality. Two values are considered equal @@ -58,15 +57,19 @@ updateHscEnvEq oldHscEnvEq newHscEnv = do let update newUnique = oldHscEnvEq { envUnique = newUnique, hscEnv = newHscEnv } update <$> Unique.newUnique +toAbsolute :: FilePath -> FilePath -> FilePath +toAbsolute root path + | isAbsolute path = path + | otherwise = root path -- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq -newHscEnvEq cradlePath hscEnv0 deps = do +newHscEnvEq :: FilePath -> FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEq root cradlePath hscEnv0 deps = do let relativeToCradle = (takeDirectory cradlePath ) hscEnv = removeImportPaths hscEnv0 -- Make Absolute since targets are also absolute importPathsCanon <- - mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) + mapM (return . toAbsolute root) $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0) newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps diff --git a/ghcide/test/exe/BootTests.hs b/ghcide/test/exe/BootTests.hs index 0d92dbe136..078281d391 100644 --- a/ghcide/test/exe/BootTests.hs +++ b/ghcide/test/exe/BootTests.hs @@ -16,6 +16,7 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test +import System.FilePath (()) import Test.Hls.FileSystem (toAbsFp) import Test.Tasty import Test.Tasty.HUnit @@ -24,7 +25,7 @@ import Test.Tasty.HUnit tests :: TestTree tests = testGroup "boot" [ testCase "boot-def-test" $ runWithExtraFiles "boot" $ \dir -> do - let cPath = dir `toAbsFp` "C.hs" + let cPath = dir "C.hs" cSource <- liftIO $ readFileUtf8 cPath -- Dirty the cache liftIO $ runInDir dir $ do @@ -51,6 +52,6 @@ tests = testGroup "boot" let floc = mkR 9 0 9 1 checkDefs locs (pure [floc]) , testCase "graph with boot modules" $ runWithExtraFiles "boot2" $ \dir -> do - _ <- openDoc (dir `toAbsFp` "A.hs") "haskell" + _ <- openDoc (dir "A.hs") "haskell" expectNoMoreDiagnostics 2 ] diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 0a7751fc4b..75885f7599 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -11,7 +11,6 @@ module Config( , testWithDummyPluginEmpty , testWithDummyPlugin' , testWithDummyPluginEmpty' - , testWithDummyPluginAndCap' , runWithExtraFiles , runInDir , testWithExtraFiles @@ -52,37 +51,31 @@ dummyPlugin = mkPluginTestDescriptor (\_ pid -> defaultPluginDescriptor pid "dum runWithDummyPlugin :: FS.VirtualFileTree -> Session a -> IO a runWithDummyPlugin = runSessionWithServerInTmpDir def dummyPlugin -runWithDummyPlugin' :: FS.VirtualFileTree -> (FileSystem -> Session a) -> IO a +runWithDummyPlugin' :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a runWithDummyPlugin' = runSessionWithServerInTmpDirCont' def dummyPlugin -runWithDummyPluginAndCap' :: ClientCapabilities -> (FileSystem -> Session ()) -> IO () -runWithDummyPluginAndCap' cap = runSessionWithServerAndCapsInTmpDirCont def dummyPlugin cap (mkIdeTestFs []) - -testWithDummyPluginAndCap' :: String -> ClientCapabilities -> (FileSystem -> Session ()) -> TestTree -testWithDummyPluginAndCap' caseName cap = testCase caseName . runWithDummyPluginAndCap' cap - testWithDummyPlugin :: String -> FS.VirtualFileTree -> Session () -> TestTree testWithDummyPlugin caseName vfs = testWithDummyPlugin' caseName vfs . const -testWithDummyPlugin' :: String -> FS.VirtualFileTree -> (FileSystem -> Session ()) -> TestTree +testWithDummyPlugin' :: String -> FS.VirtualFileTree -> (FilePath -> Session ()) -> TestTree testWithDummyPlugin' caseName vfs = testCase caseName . runWithDummyPlugin' vfs testWithDummyPluginEmpty :: String -> Session () -> TestTree testWithDummyPluginEmpty caseName = testWithDummyPlugin caseName $ mkIdeTestFs [] -testWithDummyPluginEmpty' :: String -> (FileSystem -> Session ()) -> TestTree +testWithDummyPluginEmpty' :: String -> (FilePath -> Session ()) -> TestTree testWithDummyPluginEmpty' caseName = testWithDummyPlugin' caseName $ mkIdeTestFs [] -runWithExtraFiles :: String -> (FileSystem -> Session a) -> IO a +runWithExtraFiles :: String -> (FilePath -> Session a) -> IO a runWithExtraFiles dirName action = do let vfs = mkIdeTestFs [FS.copyDir dirName] runWithDummyPlugin' vfs action -testWithExtraFiles :: String -> String -> (FileSystem -> Session ()) -> TestTree +testWithExtraFiles :: String -> String -> (FilePath -> Session ()) -> TestTree testWithExtraFiles testName dirName action = testCase testName $ runWithExtraFiles dirName action -runInDir :: FileSystem -> Session a -> IO a -runInDir fs = runSessionWithServerNoRootLock False dummyPlugin def def def (fsRoot fs) +runInDir :: FilePath -> Session a -> IO a +runInDir fs = runSessionWithServer def dummyPlugin fs pattern R :: UInt -> UInt -> UInt -> UInt -> Range pattern R x y x' y' = Range (Position x y) (Position x' y') diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs index dc55ff80d3..8d9cc6772b 100644 --- a/ghcide/test/exe/DependentFileTest.hs +++ b/ghcide/test/exe/DependentFileTest.hs @@ -15,19 +15,23 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test +import System.Directory (setCurrentDirectory) +import System.FilePath (()) import Test.Hls.FileSystem (FileSystem, toAbsFp) import Test.Tasty +import Test.Hls + tests :: TestTree tests = testGroup "addDependentFile" - [testGroup "file-changed" [testWithDummyPluginEmpty' "test" test] + [testGroup "file-changed" [testCase "test" $ runSessionWithTestConfig (mkTestConfig "" dummyPlugin) {testShiftRoot=True, testFileTree=Just (mkIdeTestFs [])} test] ] where - test :: FileSystem -> Session () + test :: FilePath -> Session () test dir = do -- If the file contains B then no type error -- otherwise type error - let depFilePath = toAbsFp dir "dep-file.txt" + let depFilePath = "dep-file.txt" liftIO $ writeFile depFilePath "A" let fooContent = T.unlines [ "{-# LANGUAGE TemplateHaskell #-}" @@ -35,8 +39,8 @@ tests = testGroup "addDependentFile" , "import Language.Haskell.TH.Syntax" , "foo :: Int" , "foo = 1 + $(do" - , " qAddDependentFile \"dep-file.txt\"" - , " f <- qRunIO (readFile \"dep-file.txt\")" + , " qAddDependentFile \"" <> T.pack depFilePath <> "\"" + , " f <- qRunIO (readFile \"" <> T.pack depFilePath <> "\")" , " if f == \"B\" then [| 1 |] else lift f)" ] let bazContent = T.unlines ["module Baz where", "import Foo ()"] @@ -47,7 +51,7 @@ tests = testGroup "addDependentFile" -- Now modify the dependent file liftIO $ writeFile depFilePath "B" sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams - [FileEvent (filePathToUri "dep-file.txt") FileChangeType_Changed ] + [FileEvent (filePathToUri depFilePath) FileChangeType_Changed ] -- Modifying Baz will now trigger Foo to be rebuilt as well let change = TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index 1c5adff70d..172c9f6742 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -36,7 +36,9 @@ import Control.Monad.Extra (whenJust) import Data.Default (def) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) import System.Time.Extra -import Test.Hls (runSessionWithServerInTmpDirCont, +import Test.Hls (TestConfig (testConfigCaps, testLspConfig, testPluginDescriptor), + runSessionWithServerInTmpDirCont, + runSessionWithTestConfig, waitForProgressBegin) import Test.Hls.FileSystem (directCradle, file, text, toAbsFp) @@ -169,7 +171,12 @@ tests = testGroup "diagnostics" let contentA = T.unlines [ "module ModuleA where" ] _ <- createDoc "ModuleA.hs" "haskell" contentA expectDiagnostics [("ModuleB.hs", [])] - , testWithDummyPluginAndCap' "add missing module (non workspace)" lspTestCapsNoFileWatches $ \tmpDir -> do + , testCase "add missing module (non workspace)" $ + runSessionWithTestConfig def { + testPluginDescriptor = dummyPlugin + , testConfigCaps = lspTestCapsNoFileWatches + } + $ \tmpDir -> do -- By default lsp-test sends FileWatched notifications for all files, which we don't want -- as non workspace modules will not be watched by the LSP server. -- To work around this, we tell lsp-test that our client doesn't have the @@ -178,11 +185,11 @@ tests = testGroup "diagnostics" [ "module ModuleB where" , "import ModuleA ()" ] - _ <- createDoc (tmpDir `toAbsFp` "ModuleB.hs") "haskell" contentB - expectDiagnostics [(tmpDir `toAbsFp` "ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] + _ <- createDoc (tmpDir "ModuleB.hs") "haskell" contentB + expectDiagnostics [(tmpDir "ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] let contentA = T.unlines [ "module ModuleA where" ] - _ <- createDoc (tmpDir `toAbsFp` "ModuleA.hs") "haskell" contentA - expectDiagnostics [(tmpDir `toAbsFp` "ModuleB.hs", [])] + _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA + expectDiagnostics [(tmpDir "ModuleB.hs", [])] , testWithDummyPluginEmpty "cyclic module dependency" $ do let contentA = T.unlines [ "module ModuleA where" @@ -452,9 +459,9 @@ tests = testGroup "diagnostics" ) ] , testCase "typecheck-all-parents-of-interest" $ runWithExtraFiles "recomp" $ \dir -> do - let bPath = dir `toAbsFp` "B.hs" - pPath = dir `toAbsFp` "P.hs" - aPath = dir `toAbsFp` "A.hs" + let bPath = dir "B.hs" + pPath = dir "P.hs" + aPath = dir "A.hs" bSource <- liftIO $ readFileUtf8 bPath -- y :: Int pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs index 6d19891978..a734e0529c 100644 --- a/ghcide/test/exe/ExceptionTests.hs +++ b/ghcide/test/exe/ExceptionTests.hs @@ -7,20 +7,17 @@ import Control.Lens import Control.Monad.Error.Class (MonadError (throwError)) import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as A +import Data.Default (Default (..)) import Data.Text as T import Development.IDE.Core.Shake (IdeState (..)) import qualified Development.IDE.LSP.Notifications as Notifications -import qualified Development.IDE.Main as IDE import Development.IDE.Plugin.HLS (toResponseError) -import Development.IDE.Plugin.Test as Test -import Development.IDE.Types.Options import GHC.Base (coerce) import Ide.Logger (Recorder, WithPriority, cmapWithPrio) import Ide.Plugin.Error import Ide.Plugin.HandleRequestTypes (RejectionReason (DisabledGlobally)) -import Ide.PluginUtils (idePluginsToPluginDesc, - pluginDescToIdePlugins) +import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -31,18 +28,21 @@ import Language.LSP.Protocol.Types hiding mkRange) import Language.LSP.Test import LogType (Log (..)) -import Test.Hls (waitForProgressDone) +import Test.Hls (TestConfig (testDisableDefaultPlugin, testPluginDescriptor), + hlsPluginTestRecorder, + runSessionWithTestConfig, + waitForProgressDone) import Test.Tasty import Test.Tasty.HUnit -import TestUtils -tests :: Recorder (WithPriority Log) -> TestTree -tests recorder = do +tests :: TestTree +tests = do testGroup "Exceptions and PluginError" [ testGroup "Testing that IO Exceptions are caught in..." [ testCase "PluginHandlers" $ do let pluginId = "plugin-handler-exception" - plugins = pluginDescToIdePlugins $ + plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins _ = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginHandlers = mconcat [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do @@ -50,7 +50,7 @@ tests recorder = do pure (InL []) ] }] - testIde recorder (testingLite recorder plugins) $ do + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True} $ const $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) @@ -63,7 +63,8 @@ tests recorder = do , testCase "Commands" $ do let pluginId = "command-exception" commandId = CommandId "exception" - plugins = pluginDescToIdePlugins $ + plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins _ = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginCommands = [ PluginCommand commandId "Causes an exception" $ \_ _ (_::Int) -> do @@ -71,7 +72,7 @@ tests recorder = do pure (InR Null) ] }] - testIde recorder (testingLite recorder plugins) $ do + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True} $ const $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)]) @@ -85,7 +86,8 @@ tests recorder = do , testCase "Notification Handlers" $ do let pluginId = "notification-exception" - plugins = pluginDescToIdePlugins $ + plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins _ = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginNotificationHandlers = mconcat [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> @@ -96,7 +98,7 @@ tests recorder = do pure (InL []) ] }] - testIde recorder (testingLite recorder plugins) $ do + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True} $ const $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) @@ -108,37 +110,18 @@ tests recorder = do _ -> liftIO $ assertFailure $ "We should have had an empty list" <> show lens] , testGroup "Testing PluginError order..." - [ pluginOrderTestCase recorder "InternalError over InvalidParams" (PluginInternalError "error test") (PluginInvalidParams "error test") - , pluginOrderTestCase recorder "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test") - , pluginOrderTestCase recorder "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally) + [ pluginOrderTestCase "InternalError over InvalidParams" (PluginInternalError "error test") (PluginInvalidParams "error test") + , pluginOrderTestCase "InvalidParams over InvalidUserState" (PluginInvalidParams "error test") (PluginInvalidUserState "error test") + , pluginOrderTestCase "InvalidUserState over RequestRefused" (PluginInvalidUserState "error test") (PluginRequestRefused DisabledGlobally) ] ] -testingLite :: Recorder (WithPriority Log) -> IdePlugins IdeState -> IDE.Arguments -testingLite recorder plugins = - let - arguments@IDE.Arguments{ argsIdeOptions } = - IDE.defaultArguments (cmapWithPrio LogIDEMain recorder) plugins - hlsPlugins = pluginDescToIdePlugins $ - idePluginsToPluginDesc plugins - ++ [Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"] - ++ [Test.blockCommandDescriptor "block-command", Test.plugin] - ideOptions config sessionLoader = - let - defOptions = argsIdeOptions config sessionLoader - in - defOptions{ optTesting = IdeTesting True } - in - arguments - { IDE.argsHlsPlugins = hlsPlugins - , IDE.argsIdeOptions = ideOptions - } - -pluginOrderTestCase :: Recorder (WithPriority Log) -> TestName -> PluginError -> PluginError -> TestTree -pluginOrderTestCase recorder msg err1 err2 = +pluginOrderTestCase :: TestName -> PluginError -> PluginError -> TestTree +pluginOrderTestCase msg err1 err2 = testCase msg $ do let pluginId = "error-order-test" - plugins = pluginDescToIdePlugins $ + plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins r = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginHandlers = mconcat [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do @@ -146,8 +129,8 @@ pluginOrderTestCase recorder msg err1 err2 = ,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do throwError err2 ] - }] - testIde recorder (testingLite recorder plugins) $ do + }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True} $ const $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) diff --git a/ghcide/test/exe/IfaceTests.hs b/ghcide/test/exe/IfaceTests.hs index 24d5115f3a..90d27c445b 100644 --- a/ghcide/test/exe/IfaceTests.hs +++ b/ghcide/test/exe/IfaceTests.hs @@ -35,9 +35,9 @@ tests = testGroup "Interface loading tests" -- | test that TH reevaluates across interfaces ifaceTHTest :: TestTree ifaceTHTest = testWithExtraFiles "iface-th-test" "TH" $ \dir -> do - let aPath = dir `toAbsFp` "THA.hs" - bPath = dir `toAbsFp` "THB.hs" - cPath = dir `toAbsFp` "THC.hs" + let aPath = dir "THA.hs" + bPath = dir "THB.hs" + cPath = dir "THC.hs" aSource <- liftIO $ readFileUtf8 aPath -- [TH] a :: () _bSource <- liftIO $ readFileUtf8 bPath -- a :: () @@ -58,8 +58,8 @@ ifaceTHTest = testWithExtraFiles "iface-th-test" "TH" $ \dir -> do ifaceErrorTest :: TestTree ifaceErrorTest = testWithExtraFiles "iface-error-test-1" "recomp" $ \dir -> do configureCheckProject True - let bPath = dir `toAbsFp` "B.hs" - pPath = dir `toAbsFp` "P.hs" + let bPath = dir "B.hs" + pPath = dir "P.hs" bSource <- liftIO $ readFileUtf8 bPath -- y :: Int pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int @@ -106,8 +106,8 @@ ifaceErrorTest = testWithExtraFiles "iface-error-test-1" "recomp" $ \dir -> do ifaceErrorTest2 :: TestTree ifaceErrorTest2 = testWithExtraFiles "iface-error-test-2" "recomp" $ \dir -> do - let bPath = dir `toAbsFp` "B.hs" - pPath = dir `toAbsFp` "P.hs" + let bPath = dir "B.hs" + pPath = dir "P.hs" bSource <- liftIO $ readFileUtf8 bPath -- y :: Int pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int @@ -140,8 +140,8 @@ ifaceErrorTest2 = testWithExtraFiles "iface-error-test-2" "recomp" $ \dir -> do ifaceErrorTest3 :: TestTree ifaceErrorTest3 = testWithExtraFiles "iface-error-test-3" "recomp" $ \dir -> do - let bPath = dir `toAbsFp` "B.hs" - pPath = dir `toAbsFp` "P.hs" + let bPath = dir "B.hs" + pPath = dir "P.hs" bSource <- liftIO $ readFileUtf8 bPath -- y :: Int pSource <- liftIO $ readFileUtf8 pPath -- bar = x :: Int diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 8c6f876f39..558115fc24 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -114,5 +114,5 @@ main = do , ReferenceTests.tests , GarbageCollectionTests.tests , HieDbRetry.tests - , ExceptionTests.tests recorder + , ExceptionTests.tests ] diff --git a/ghcide/test/exe/ReferenceTests.hs b/ghcide/test/exe/ReferenceTests.hs index 3bafb0b20d..729e919541 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/ghcide/test/exe/ReferenceTests.hs @@ -27,6 +27,7 @@ import Data.Default (def) import Data.Tuple.Extra import GHC.TypeLits (symbolVal) import Ide.Types +import System.FilePath (isAbsolute, ()) import Test.Hls (FromServerMessage' (..), SMethod (..), TCustomMessage (..), @@ -167,13 +168,14 @@ getReferences' (file, l, c) includeDeclaration = do -referenceTestSession :: String -> FilePath -> [FilePath] -> Session () -> TestTree +referenceTestSession :: String -> FilePath -> [FilePath] -> (FilePath -> Session ()) -> TestTree referenceTestSession name thisDoc docs' f = do testWithDummyPlugin' name (mkIdeTestFs [copyDir "references"]) $ \fs -> do + let rootDir = fs "" -- needed to build whole project indexing configureCheckProject True -- need to get the real paths through links - docs <- mapM (liftIO . canonicalizePath . toAbsFp fs) $ delete thisDoc $ nubOrd docs' + docs <- mapM (liftIO . canonicalizePath . (fs )) $ delete thisDoc $ nubOrd docs' -- Initial Index docid <- openDoc thisDoc "haskell" @@ -187,23 +189,28 @@ referenceTestSession name thisDoc docs' f = do doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) loop (delete doc docs) loop docs - f + f rootDir closeDoc docid -- | Given a location, lookup the symbol and all references to it. Make sure -- they are the ones we expect. referenceTest :: (HasCallStack) => String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree referenceTest name loc includeDeclaration expected = - referenceTestSession name (fst3 loc) docs $ do + referenceTestSession name (fst3 loc) docs $ \rootDir -> do actual <- getReferences' loc includeDeclaration - liftIO $ actual `expectSameLocations` expected + liftIO $ expectSameLocations rootDir actual expected where docs = map fst3 expected type SymbolLocation = (FilePath, UInt, UInt) -expectSameLocations :: (HasCallStack) => [Location] -> [SymbolLocation] -> Assertion -expectSameLocations actual expected = do +toAbsolute :: FilePath -> FilePath -> FilePath +toAbsolute root path + | isAbsolute path = path + | otherwise = root path + +expectSameLocations :: (HasCallStack) => FilePath -> [Location] -> [SymbolLocation] -> Assertion +expectSameLocations rootDir actual expected = do let actual' = Set.map (\location -> (location ^. L.uri , location ^. L.range . L.start . L.line . Lens.to fromIntegral @@ -211,7 +218,7 @@ expectSameLocations actual expected = do $ Set.fromList actual expected' <- Set.fromList <$> (forM expected $ \(file, l, c) -> do - fp <- canonicalizePath file + fp <- canonicalizePath $ toAbsolute rootDir file return (filePathToUri fp, l, c)) actual' @?= expected' diff --git a/ghcide/test/exe/UnitTests.hs b/ghcide/test/exe/UnitTests.hs index 4900b7cae4..a6ba0abd01 100644 --- a/ghcide/test/exe/UnitTests.hs +++ b/ghcide/test/exe/UnitTests.hs @@ -1,6 +1,7 @@ module UnitTests (tests) where +import Config (mkIdeTestFs) import Control.Concurrent import Control.Monad.IO.Class (liftIO) import Data.IORef @@ -30,7 +31,9 @@ import Network.URI import qualified Progress import System.IO.Extra hiding (withTempDir) import System.Mem (performGC) -import Test.Hls (waitForProgressDone) +import Test.Hls (IdeState, def, + runSessionWithServerInTmpDir, + waitForProgressDone) import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit @@ -72,7 +75,9 @@ tests recorder = do expected `isInfixOf` shown , testCase "notification handlers run in priority order" $ do orderRef <- newIORef [] - let plugins = pluginDescToIdePlugins $ + let + plugins ::Recorder (WithPriority Ghcide.Log) -> IdePlugins IdeState + plugins recorder = pluginDescToIdePlugins $ [ (priorityPluginDescriptor i) { pluginNotificationHandlers = mconcat [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> @@ -80,10 +85,11 @@ tests recorder = do ] } | i <- [1..20] - ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder) + ] ++ Ghcide.descriptors recorder priorityPluginDescriptor i = (defaultPluginDescriptor (fromString $ show i) ""){pluginPriority = i} - testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) plugins) $ do + -- testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) plugins) $ do + runSessionWithServerInTmpDir def plugins (mkIdeTestFs []) $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone actualOrder <- liftIO $ reverse <$> readIORef orderRef diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 5f673caafe..67ec32bc97 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -654,6 +654,7 @@ library hls-retrie-plugin , text , transformers , unordered-containers + , filepath default-extensions: DataKinds diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 92bd49ac13..1277e195ec 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -4,6 +4,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty, @@ -25,19 +26,18 @@ module Test.Hls goldenWithHaskellDocFormatterInTmpDir, goldenWithCabalDocFormatter, goldenWithCabalDocFormatterInTmpDir, + goldenWithTestConfig, def, -- * Running HLS for integration tests runSessionWithServer, - runSessionWithServerAndCaps, runSessionWithServerInTmpDir, runSessionWithServerAndCapsInTmpDir, - runSessionWithServerNoRootLock, - runSessionWithServer', runSessionWithServerInTmpDir', -- continuation version that take a FileSystem runSessionWithServerInTmpDirCont, runSessionWithServerInTmpDirCont', runSessionWithServerAndCapsInTmpDirCont, + runSessionWithTestConfig, -- * Helpful re-exports PluginDescriptor, IdeState, @@ -63,6 +63,8 @@ module Test.Hls WithPriority(..), Recorder, Priority(..), + TestConfig(..), + mkTestConfig, ) where @@ -71,7 +73,7 @@ import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Extra import Control.Exception.Safe import Control.Lens.Extras (is) -import Control.Monad (guard, unless, void) +import Control.Monad (guard, unless, void, when) import Control.Monad.Extra (forM) import Control.Monad.IO.Class import Data.Aeson (Result (Success), @@ -79,7 +81,7 @@ import Data.Aeson (Result (Success), toJSON) import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) -import Data.Default (def) +import Data.Default (Default, def) import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (Proxy)) @@ -104,6 +106,8 @@ import Ide.Logger (Pretty (pretty), logWith, makeDefaultStderrRecorder, (<+>)) +import Ide.PluginUtils (idePluginsToPluginDesc, + pluginDescToIdePlugins) import Ide.Types import Language.LSP.Protocol.Capabilities import Language.LSP.Protocol.Message @@ -114,6 +118,7 @@ import System.Directory (canonicalizePath, createDirectoryIfMissing, getCurrentDirectory, getTemporaryDirectory, + makeAbsolute, setCurrentDirectory) import System.Environment (lookupEnv, setEnv) import System.FilePath @@ -201,7 +206,34 @@ goldenWithHaskellAndCaps -> TestTree goldenWithHaskellAndCaps config clientCaps plugin title testDataDir path desc ext act = goldenGitDiff title (testDataDir path <.> desc <.> ext) - $ runSessionWithServerAndCaps config plugin clientCaps testDataDir + $ runSessionWithTestConfig def { + testConfigRoot = testDataDir, + testConfigCaps = clientCaps, + testLspConfig = config, + testPluginDescriptor = plugin + } + $ const +-- runSessionWithServerAndCaps config plugin clientCaps testDataDir + $ TL.encodeUtf8 . TL.fromStrict + <$> do + doc <- openDoc (path <.> ext) "haskell" + void waitForBuildQueue + act doc + documentContents doc + +goldenWithTestConfig + :: Pretty b + => TestConfig b + -> TestName + -> FilePath + -> FilePath + -> FilePath + -> FilePath + -> (TextDocumentIdentifier -> Session ()) + -> TestTree +goldenWithTestConfig config title testDataDir path desc ext act = + goldenGitDiff title (testDataDir path <.> desc <.> ext) + $ runSessionWithTestConfig config $ const $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "haskell" @@ -394,11 +426,11 @@ runSessionWithServerInTmpDir config plugin tree act = runSessionWithServerInTmpD runSessionWithServerAndCapsInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> Session a -> IO a runSessionWithServerAndCapsInTmpDir config plugin caps tree act = runSessionWithServerAndCapsInTmpDirCont config plugin caps tree (const act) -runSessionWithServerInTmpDirCont' :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> (FileSystem -> Session a) -> IO a +runSessionWithServerInTmpDirCont' :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> (FilePath -> Session a) -> IO a runSessionWithServerInTmpDirCont' config plugin tree act = do runSessionWithServerInTmpDirCont False plugin config def fullCaps tree act -runSessionWithServerAndCapsInTmpDirCont :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> (FileSystem -> Session a) -> IO a +runSessionWithServerAndCapsInTmpDirCont :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> (FilePath -> Session a) -> IO a runSessionWithServerAndCapsInTmpDirCont config plugin caps tree act = do runSessionWithServerInTmpDirCont False plugin config def caps tree act @@ -413,7 +445,35 @@ runSessionWithServerInTmpDir' :: ClientCapabilities -> VirtualFileTree -> Session a -> IO a -runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = runSessionWithServerInTmpDirCont False plugins conf sessConf caps tree (const act) +runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = + runSessionWithServerInTmpDirCont False plugins conf sessConf caps tree (const act) + +runWithLockInTempDir :: VirtualFileTree -> (FileSystem -> IO a) -> IO a +runWithLockInTempDir tree act = withLock lockForTempDirs $ do + testRoot <- setupTestEnvironment + helperRecorder <- hlsHelperTestRecorder + -- Do not clean up the temporary directory if this variable is set to anything but '0'. + -- Aids debugging. + cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP" + let runTestInDir action = case cleanupTempDir of + Just val | val /= "0" -> do + (tempDir, _) <- newTempDirWithin testRoot + a <- action tempDir + logWith helperRecorder Debug LogNoCleanup + pure a + + _ -> do + (tempDir, cleanup) <- newTempDirWithin testRoot + a <- action tempDir `finally` cleanup + logWith helperRecorder Debug LogCleanup + pure a + runTestInDir $ \tmpDir' -> do + -- we canonicalize the path, so that we do not need to do + -- cannibalization during the test when we compare two paths + tmpDir <- canonicalizePath tmpDir' + logWith helperRecorder Info $ LogTestDir tmpDir + fs <- FS.materialiseVFT tmpDir tree + act fs -- | Host a server, and run a test session on it. -- @@ -448,42 +508,43 @@ runSessionWithServerInTmpDirCont :: SessionConfig -> ClientCapabilities -> VirtualFileTree -> - (FileSystem -> Session a) -> IO a -runSessionWithServerInTmpDirCont disableKick plugins conf sessConf caps tree act = withLock lockForTempDirs $ do - testRoot <- setupTestEnvironment - helperRecorder <- hlsHelperTestRecorder - - -- Do not clean up the temporary directory if this variable is set to anything but '0'. - -- Aids debugging. - cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP" - let runTestInDir action = case cleanupTempDir of - Just val | val /= "0" -> do - (tempDir, _) <- newTempDirWithin testRoot - a <- action tempDir - logWith helperRecorder Debug LogNoCleanup - pure a - - _ -> do - (tempDir, cleanup) <- newTempDirWithin testRoot - a <- action tempDir `finally` cleanup - logWith helperRecorder Debug LogCleanup - pure a - - runTestInDir $ \tmpDir' -> do - -- we canonicalize the path, so that we do not need to do - -- cannibalization during the test when we compare two paths - tmpDir <- canonicalizePath tmpDir' - logWith helperRecorder Info $ LogTestDir tmpDir - fs <- FS.materialiseVFT tmpDir tree - runSessionWithServer' disableKick plugins conf sessConf caps tmpDir (act fs) + (FilePath -> Session a) -> IO a +runSessionWithServerInTmpDirCont disableKick plugins conf sessConf caps tree act = + runSessionWithTestConfig (mkTestConfig "" plugins) + {testLspConfig=conf, testConfigSession=sessConf, testConfigCaps=caps, testFileTree=Just tree, testDisableKick=disableKick} + act runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a -runSessionWithServer config plugin fp act = do - runSessionWithServer' False plugin config def fullCaps fp act +runSessionWithServer config plugin fp act = + runSessionWithTestConfig (mkTestConfig fp plugin){testLspConfig=config} (const act) + +instance Default (TestConfig b) where + def = TestConfig { + testConfigRoot = "", + testFileTree = Nothing, + testShiftRoot = False, + testDisableKick = False, + testDisableDefaultPlugin = False, + testPluginDescriptor = mempty, + testLspConfig = def, + testConfigSession = def, + testConfigCaps = fullCaps + } + + +mkTestConfig :: FilePath -> PluginTestDescriptor b -> TestConfig b +mkTestConfig fp pd = TestConfig { + testConfigRoot = fp, + testFileTree = Nothing, + testShiftRoot = False, + testDisableKick = False, + testDisableDefaultPlugin = False, + testPluginDescriptor = pd, + testLspConfig = def, + testConfigSession = def, + testConfigCaps = fullCaps +} -runSessionWithServerAndCaps :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> FilePath -> Session a -> IO a -runSessionWithServerAndCaps config plugin caps fp act = do - runSessionWithServer' False plugin config def caps fp act -- | Setup the test environment for isolated tests. @@ -617,60 +678,43 @@ lock = unsafePerformIO newLock lockForTempDirs :: Lock lockForTempDirs = unsafePerformIO newLock --- | Host a server, and run a test session on it --- Note: cwd will be shifted into @root@ in @Session a@ --- notice this function should only be used in tests that --- require to be nested in the same temporary directory --- use 'runSessionWithServerInTmpDir' for other cases -runSessionWithServerNoRootLock :: - (Pretty b) => - -- | whether we disable the kick action or not - Bool -> - -- | Plugin to load on the server. - PluginTestDescriptor b -> - -- | lsp config for the server - Config -> - -- | config for the test session - SessionConfig -> - ClientCapabilities -> - FilePath -> - Session a -> - IO a -runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s = do +data TestConfig b = TestConfig + { + testConfigRoot :: FilePath + -- ^ Root directory of the test project + , testFileTree :: Maybe VirtualFileTree + -- ^ Virtual file tree to be used for the test + , testShiftRoot :: Bool + -- ^ Whether to shift the root directory to the test project root + , testDisableKick :: Bool + -- ^ Whether to disable the kick action + , testDisableDefaultPlugin :: Bool + -- ^ Whether to disable the default plugin comes with ghcide + , testPluginDescriptor :: PluginTestDescriptor b + -- ^ Plugin to load on the server. + , testLspConfig :: Config + -- ^ lsp config for the server + , testConfigSession :: SessionConfig + -- ^ config for the test session + , testConfigCaps :: ClientCapabilities + -- ^ Client capabilities + } + +runSessionWithTestConfig :: Pretty b => TestConfig b -> (FilePath -> Session a) -> IO a +runSessionWithTestConfig TestConfig{..} session = + runSessionInVFS testFileTree $ \root -> shiftRoot root $ do (inR, inW) <- createPipe (outR, outW) <- createPipe recorder <- hlsPluginTestRecorder - let plugins = pluginsDp recorder + let plugins = testPluginDescriptor recorder recorderIde <- hlsHelperTestRecorder - - let - sconf' = sconf { lspConfig = hlsConfigToClientConfig conf } - - hlsPlugins = IdePlugins [Test.blockCommandDescriptor "block-command"] <> plugins - - arguments@Arguments{ argsIdeOptions } = - testing (cmapWithPrio LogIDEMain recorderIde) hlsPlugins - - ideOptions config ghcSession = - let defIdeOptions = argsIdeOptions config ghcSession - in defIdeOptions - { optTesting = IdeTesting True - , optCheckProject = pure False - } - + let sconf' = testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig } + arguments = testingArgs root (cmapWithPrio LogIDEMain recorderIde) plugins server <- async $ IDEMain.defaultMain (cmapWithPrio LogIDEMain recorderIde) - arguments - { argsHandleIn = pure inR - , argsHandleOut = pure outW - , argsDefaultHlsConfig = conf - , argsIdeOptions = ideOptions - , argsProjectRoot = Just root - , argsDisableKick = disableKick - } - - x <- runSessionWithHandles inW outR sconf' caps root s + arguments { argsHandleIn = pure inR , argsHandleOut = pure outW } + result <- runSessionWithHandles inW outR sconf' testConfigCaps root (session root) hClose inW timeout 3 (wait server) >>= \case Just () -> pure () @@ -678,26 +722,36 @@ runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s = d putStrLn "Server does not exit in 3s, canceling the async task..." (t, _) <- duration $ cancel server putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" - pure x - --- | Host a server, and run a test session on it --- Note: cwd will be shifted into @root@ in @Session a@ -runSessionWithServer' :: - (Pretty b) => - -- | whether we disable the kick action or not - Bool -> - -- | Plugin to load on the server. - PluginTestDescriptor b -> - -- | lsp config for the server - Config -> - -- | config for the test session - SessionConfig -> - ClientCapabilities -> - FilePath -> - Session a -> - IO a -runSessionWithServer' disableKick pluginsDp conf sconf caps root s = - withLock lock $ keepCurrentDirectory $ runSessionWithServerNoRootLock disableKick pluginsDp conf sconf caps root s + pure result + + where + shiftRoot shiftTarget f = + if testShiftRoot + then withLock lock $ keepCurrentDirectory $ setCurrentDirectory shiftTarget >> f + else f + runSessionInVFS Nothing act = do + root <- makeAbsolute testConfigRoot + act root + runSessionInVFS (Just vfs) act = runWithLockInTempDir vfs $ \fs -> act (fsRoot fs) + -- testingArgs :: FilePath -> Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments + testingArgs prjRoot recorder plugins = + let + arguments@Arguments{ argsHlsPlugins, argsIdeOptions } = defaultArguments prjRoot recorder plugins + argsHlsPlugins' = if testDisableDefaultPlugin then plugins else argsHlsPlugins + hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins' + ++ [Test.blockCommandDescriptor "block-command", Test.plugin] + ideOptions config sessionLoader = (argsIdeOptions config sessionLoader){ + optTesting = IdeTesting True + , optCheckProject = pure False + } + in + arguments + { argsHlsPlugins = hlsPlugins + , argsIdeOptions = ideOptions + , argsDefaultHlsConfig = testLspConfig + , argsProjectRoot = prjRoot + , argsDisableKick = testDisableKick + } -- | Wait for the next progress begin step waitForProgressBegin :: Session () diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 4cd15f9dac..14f3e6f28f 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -116,7 +116,12 @@ suggestionsTests = contents <- skipManyTill anyMessage $ getDocumentEdit doc liftIO $ contents @?= "main = undefined\nfoo x = x\n" - , testCase "falls back to pre 3.8 code actions" $ runSessionWithServerAndCaps def hlintPlugin noLiteralCaps testDir $ do + , testCase "falls back to pre 3.8 code actions" $ + runSessionWithTestConfig def { + testConfigCaps = noLiteralCaps, + testConfigRoot = testDir, + testPluginDescriptor = hlintPlugin, + testShiftRoot = True} $ const $ do doc <- openDoc "Base.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "hlint" @@ -341,7 +346,9 @@ testDir :: FilePath testDir = "plugins/hls-hlint-plugin/test/testdata" runHlintSession :: FilePath -> Session a -> IO a -runHlintSession subdir = failIfSessionTimeout . runSessionWithServerAndCaps def hlintPlugin codeActionNoResolveCaps (testDir subdir) +runHlintSession subdir = failIfSessionTimeout . + runSessionWithTestConfig (mkTestConfig (testDir subdir) hlintPlugin){testConfigCaps=codeActionNoResolveCaps, testShiftRoot=True} + . const noHlintDiagnostics :: [Diagnostic] -> Assertion noHlintDiagnostics diags = @@ -419,9 +426,12 @@ goldenTest testCaseName goldenFilename point hintText = void $ skipManyTill anyMessage $ getDocumentEdit document _ -> liftIO $ assertFailure $ makeCodeActionNotFoundAtString point + setupGoldenHlintTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintTest testName path = - goldenWithHaskellAndCaps def codeActionNoResolveCaps hlintPlugin testName testDir path "expected" "hs" + goldenWithTestConfig (mkTestConfig testDir hlintPlugin){testConfigCaps=codeActionNoResolveCaps, testShiftRoot=True} + testName testDir path "expected" "hs" + ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName = @@ -442,4 +452,5 @@ goldenResolveTest testCaseName goldenFilename point hintText = setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintResolveTest testName path = - goldenWithHaskellAndCaps def codeActionResolveCaps hlintPlugin testName testDir path "expected" "hs" + goldenWithTestConfig (mkTestConfig testDir hlintPlugin){testConfigCaps=codeActionResolveCaps, testShiftRoot=True} + testName testDir path "expected" "hs" diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs index 1192870b00..f4df5adb9c 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -41,8 +41,8 @@ import Development.IDE (GetParsedModule (GetParse hscEnvWithImportPaths, logWith, realSrcSpanToRange, - runAction, useWithStale, - (<+>)) + rootDir, runAction, + useWithStale, (<+>)) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (toCurrentRange) import Development.IDE.GHC.Compat (GenLocated (L), @@ -58,11 +58,11 @@ import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import Language.LSP.Server import Language.LSP.VFS (virtualFileText) -import System.Directory (makeAbsolute) -import System.FilePath (dropExtension, normalise, +import System.FilePath (dropExtension, + isAbsolute, normalise, pathSeparator, splitDirectories, - takeFileName) + takeFileName, ()) -- |Plugin descriptor descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState @@ -133,6 +133,10 @@ action recorder state uri = do in pure [Replace uri (Range (Position 0 0) (Position 0 0)) code code] _ -> pure [] +toAbsolute :: FilePath -> FilePath -> FilePath +toAbsolute root path + | isAbsolute path = path + | otherwise = root path -- | Possible module names, as derived by the position of the module in the -- source directories. There may be more than one possible name, if the source -- directories are nested inside each other. @@ -150,7 +154,7 @@ pathModuleNames recorder state normFilePath filePath let paths = map (normalise . (<> pure pathSeparator)) srcPaths logWith recorder Debug (NormalisedPaths paths) - mdlPath <- liftIO $ makeAbsolute filePath + let mdlPath = (toAbsolute $ rootDir state) filePath logWith recorder Debug (AbsoluteFilePath mdlPath) let suffixes = mapMaybe (`stripPrefix` mdlPath) paths diff --git a/plugins/hls-notes-plugin/test/NotesTest.hs b/plugins/hls-notes-plugin/test/NotesTest.hs index e42ef407d7..8eae6b011c 100644 --- a/plugins/hls-notes-plugin/test/NotesTest.hs +++ b/plugins/hls-notes-plugin/test/NotesTest.hs @@ -17,13 +17,14 @@ main = defaultTestRunner $ gotoNoteTests :: TestTree gotoNoteTests = testGroup "Goto Note Definition" - [ testCase "single_file" $ runSessionWithServer def plugin testDataDir $ do + [ + testCase "single_file" $ runSessionWithServer def plugin testDataDir $ do doc <- openDoc "NoteDef.hs" "haskell" waitForBuildQueue waitForAllProgressDone defs <- getDefinitions doc (Position 3 41) liftIO $ do - fp <- canonicalizePath "NoteDef.hs" + fp <- canonicalizePath $ testDataDir "NoteDef.hs" defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 8 9) (Position 8 9))])) , testCase "liberal_format" $ runSessionWithServer def plugin testDataDir $ do doc <- openDoc "NoteDef.hs" "haskell" @@ -31,7 +32,7 @@ gotoNoteTests = testGroup "Goto Note Definition" waitForAllProgressDone defs <- getDefinitions doc (Position 5 64) liftIO $ do - fp <- canonicalizePath "NoteDef.hs" + fp <- canonicalizePath $ testDataDir "NoteDef.hs" defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 18 11) (Position 18 11))])) , testCase "invalid_note" $ runSessionWithServer def plugin testDataDir $ do @@ -56,7 +57,7 @@ gotoNoteTests = testGroup "Goto Note Definition" waitForAllProgressDone defs <- getDefinitions doc (Position 5 20) liftIO $ do - fp <- canonicalizePath "NoteDef.hs" + fp <- canonicalizePath $ testDataDir "NoteDef.hs" defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 12 6) (Position 12 6))])) ] diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 3670a3b398..8f5e4836cd 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -3751,7 +3751,10 @@ run' :: (FilePath -> Session a) -> IO a run' s = withTempDir $ \dir -> runInDir dir (s dir) runInDir :: FilePath -> Session a -> IO a -runInDir dir act = runSessionWithServerAndCaps def refactorPlugin lspTestCaps dir act +runInDir dir act = + runSessionWithTestConfig def + {testConfigRoot=dir, testPluginDescriptor=refactorPlugin, testConfigCaps=lspTestCaps} + $ const act lspTestCaps :: ClientCapabilities lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } diff --git a/plugins/hls-rename-plugin/test/Main.hs b/plugins/hls-rename-plugin/test/Main.hs index dc6e99e33e..5ebb748f40 100644 --- a/plugins/hls-rename-plugin/test/Main.hs +++ b/plugins/hls-rename-plugin/test/Main.hs @@ -146,4 +146,8 @@ expectRenameError doc pos newName = do runRenameSession :: FilePath -> Session a -> IO a runRenameSession subdir = failIfSessionTimeout - . runSessionWithServerAndCaps def renamePlugin codeActionNoResolveCaps (testDataDir subdir) + . runSessionWithTestConfig def + {testConfigRoot=testDataDir subdir, + testPluginDescriptor=renamePlugin, + testConfigCaps=codeActionNoResolveCaps} + . const diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 48d2886ff0..e5eff62b15 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -129,7 +129,7 @@ import Retrie.SYB (everything, extQ, listify, mkQ) import Retrie.Types import Retrie.Universe (Universe) -import System.Directory (makeAbsolute) +import System.FilePath (isAbsolute, ()) #if MIN_VERSION_ghc(9,3,0) import GHC.Types.PkgQual @@ -760,9 +760,14 @@ reuseParsedModule state f = do (fixities, pm') <- fixFixities state f (fixAnns pm) return (fixities, pm') +toAbsolute :: FilePath -> FilePath -> FilePath +toAbsolute dir file + | isAbsolute file = file + | otherwise = dir file + getCPPmodule :: Recorder (WithPriority Log) -> IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule) getCPPmodule recorder state session t = do - nt <- toNormalizedFilePath' <$> makeAbsolute t + let nt = toNormalizedFilePath' $ (toAbsolute $ rootDir state) t let getParsedModule f contents = do modSummary <- msrModSummary <$> useOrFail state "Retrie.GetModSummary" (CallRetrieInternalError "file not found") GetModSummary nt diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index 96f73ea4fb..12a4db4dd8 100644 --- a/plugins/hls-splice-plugin/test/Main.hs +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -89,7 +89,7 @@ goldenTestWithEdit fp expect tc line col = } waitForAllProgressDone -- cradle waitForAllProgressDone - alt <- liftIO $ T.readFile (fp <.> "error.hs") + alt <- liftIO $ T.readFile (testDataDir fp <.> "error.hs") void $ applyEdit doc $ TextEdit theRange alt changeDoc doc [TextDocumentContentChangeEvent $ InL TextDocumentContentChangePartial {_range = theRange, _rangeLength = Nothing, _text = alt} diff --git a/plugins/hls-stan-plugin/test/Main.hs b/plugins/hls-stan-plugin/test/Main.hs index 650760c9dc..5f507989d7 100644 --- a/plugins/hls-stan-plugin/test/Main.hs +++ b/plugins/hls-stan-plugin/test/Main.hs @@ -75,4 +75,6 @@ stanPlugin = mkPluginTestDescriptor enabledStanDescriptor "stan" runStanSession :: FilePath -> Session a -> IO a runStanSession subdir = - failIfSessionTimeout . runSessionWithServer def stanPlugin (testDir subdir) + failIfSessionTimeout + . runSessionWithTestConfig (mkTestConfig (testDir subdir) stanPlugin){testConfigCaps=codeActionNoResolveCaps, testShiftRoot=True} + . const diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 457e0dc4ec..30ff1a90a4 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -130,7 +130,7 @@ runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryRec when (isLSP argsCommand) $ do log Info $ LogLspStart ghcideArgs (map pluginId $ ipMap idePlugins) - let args = (if argsTesting then IDEMain.testing else IDEMain.defaultArguments) + let args = (if argsTesting then IDEMain.testing else IDEMain.defaultArguments) dir (cmapWithPrio LogIDEMain recorder) idePlugins let telemetryRecorder = telemetryRecorder' & cmapWithPrio pretty diff --git a/test/functional/Config.hs b/test/functional/Config.hs index 1dbf12c64c..1db1601d1b 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -68,7 +68,9 @@ genericConfigTests = testGroup "generic plugin config" testPluginDiagnostics = [("Foo.hs", [(DiagnosticSeverity_Error, (0,0), "testplugin")])] runConfigSession subdir session = do - failIfSessionTimeout $ runSessionWithServer' @() False plugin def (def {ignoreConfigurationRequests=False}) fullCaps ("test/testdata" subdir) session + failIfSessionTimeout $ + runSessionWithTestConfig (mkTestConfig ("test/testdata" subdir) plugin) + {testConfigSession=def {ignoreConfigurationRequests=False}, testShiftRoot=True} (const session) testPluginId = "testplugin" -- A disabled-by-default plugin that creates diagnostics