diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 6de88abcc0..d4b7f8f9fb 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 (cmapWithPrio pretty recorder) cwd (IdePlugins []) inH <- Main.argsHandleIn defaultArguments diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index b3b63fbaf5..80913da190 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 (cmapWithPrio LogIDEMain recorder) argsCwd hlsPlugins + else IDEMain.defaultArguments (cmapWithPrio LogIDEMain recorder) argsCwd hlsPlugins IDEMain.defaultMain (cmapWithPrio LogIDEMain recorder) arguments - { IDEMain.argsProjectRoot = Just argsCwd + { IDEMain.argsProjectRoot = argsCwd , IDEMain.argCommand = argsCommand , IDEMain.argsHlsPlugins = IDEMain.argsHlsPlugins arguments <> pluginDescToIdePlugins [lspRecorderPlugin] diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 71688afd1d..775e82a418 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -111,6 +111,7 @@ import Development.IDE.Types.Shake (WithHieDb, toNoFileKey) import HieDb.Create import HieDb.Types import HieDb.Utils +import Ide.PluginUtils (toAbsolute) import qualified System.Random as Random import System.Random (RandomGen) @@ -438,7 +439,8 @@ loadSession :: Recorder (WithPriority Log) -> FilePath -> IO (Action IdeGhcSessi loadSession recorder = loadSessionWithOptions recorder def loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) -loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do +loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir = do + let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory] cradle_files <- newIORef [] -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file hscEnvs <- newVar Map.empty :: IO (Var HieMap) @@ -459,7 +461,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 +523,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 +590,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,25 +634,20 @@ 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 - -- TODO: Why are we repeating the same command we have on line 646? - lfp <- flip makeRelative cfp <$> getCurrentDirectory - + cradle <- loadCradle recorder hieYaml rootDir when optTesting $ mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) -- Display a user friendly progress message here: They probably don't know what a cradle is let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle)) - <> " (for " <> T.pack lfp <> ")" + <> " (for " <> T.pack lfpLog <> ")" eopts <- mRunLspTCallback lspEnv (\act -> withIndefiniteProgress progMsg Nothing NotCancellable (const act)) $ withTrace "Load cradle" $ \addTag -> do - addTag "file" lfp + addTag "file" lfpLog old_files <- readIORef cradle_files res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp old_files addTag "result" (show res) @@ -713,7 +710,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 +732,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 -> @@ -814,19 +811,20 @@ fromTargetId :: [FilePath] -- ^ import paths -> TargetId -> IdeResult HscEnvEq -> DependencyInfo + -> FilePath -- ^ root dir, see Note [Root Directory] -> 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 +913,9 @@ newComponentCache -> HscEnv -- ^ An empty HscEnv -> [ComponentInfo] -- ^ New components to be loaded -> [ComponentInfo] -- ^ old, already existing components + -> FilePath -- ^ root dir, see Note [Root Directory] -> 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 +960,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 +985,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 +1170,13 @@ 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 -- ^ root dir, see Note [Root Directory] + -> m (NonEmpty (DynFlags, [GHC.Target])) +setOptions cfp (ComponentOptions theOpts compRoot _) dflags rootDir = do ((theOpts',_errs,_warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts) case NE.nonEmpty units of Just us -> initMulti us @@ -1195,7 +1199,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 rootDir (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 5b975ef058..c38a1cae3a 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -164,8 +164,7 @@ import Language.LSP.Server (LspT) import qualified Language.LSP.Server as LSP import Language.LSP.VFS import Prelude hiding (mod) -import System.Directory (doesFileExist, - makeAbsolute) +import System.Directory (doesFileExist) import System.Info.Extra (isWindows) @@ -719,13 +718,13 @@ loadGhcSession recorder ghcSessionDepsConfig = do defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO + -- loading is always returning a absolute path now (val,deps) <- liftIO $ loadSessionFun $ fromNormalizedFilePath file -- add the deps to the Shake graph let addDependency fp = do -- VSCode uses absolute paths in its filewatch notifications - afp <- liftIO $ makeAbsolute fp - let nfp = toNormalizedFilePath' afp + let nfp = toNormalizedFilePath' fp itExists <- getFileExists nfp when itExists $ void $ do use_ GetModificationTime nfp @@ -853,7 +852,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..1ad02b4db4 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 -- ^ Root directory see Note [Root Directory] -> 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 2b95df4ed0..f759fabf63 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, @@ -527,6 +527,33 @@ newtype ShakeSession = ShakeSession -- ^ Closes the Shake session } +-- Note [Root Directory] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- We keep track of the root directory explicitly, which is the directory of the project root. +-- We might be setting it via these options with decreasing priority: +-- +-- 1. from LSP workspace root, `resRootPath` in `LanguageContextEnv`. +-- 2. command line (--cwd) +-- 3. default to the current directory. +-- +-- Using `getCurrentDirectory` makes it more difficult to run the tests, as we spawn one thread of HLS per test case. +-- If we modify the global Variable CWD, via `setCurrentDirectory`, all other test threads are suddenly affected, +-- forcing us to run all integration tests sequentially. +-- +-- Also, there might be a race condition if we depend on the current directory, as some plugin might change it. +-- e.g. stylish's `loadConfig`. https://github.com/haskell/haskell-language-server/issues/4234 +-- +-- But according to https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_workspaceFolders +-- The root dir is deprecated, that means we should cleanup dependency on the project root(Or $CWD) thing gradually, +-- so multi-workspaces can actually be supported when we use absolute path everywhere(might also need some high level design). +-- That might not be possible unless we have everything adapted to it, like 'hlint' and 'evaluation of template haskell'. +-- But we should still be working towards the goal. +-- +-- We can drop it in the future once: +-- 1. We can get rid all the usages of root directory in the codebase. +-- 2. LSP version we support actually removes the root directory from the protocol. +-- + -- | A Shake database plus persistent store. Can be thought of as storing -- mappings from @(FilePath, k)@ to @RuleResult k@. data IdeState = IdeState @@ -535,6 +562,8 @@ data IdeState = IdeState ,shakeExtras :: ShakeExtras ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath) ,stopMonitoring :: IO () + -- | See Note [Root Directory] + ,rootDir :: FilePath } @@ -623,11 +652,14 @@ shakeOpen :: Recorder (WithPriority Log) -> ShakeOptions -> Monitoring -> Rules () + -> FilePath + -- ^ Root directory, this one might be picking up from `LanguageContextEnv`'s `resRootPath` + -- , see Note [Root Directory] -> 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 2a4994f5b9..58c1f49d0b 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -127,14 +127,15 @@ runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigCh setupLSP :: forall config err. Recorder (WithPriority Log) + -> FilePath -- ^ root directory, see Note [Root Directory] -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> LSP.Handlers (ServerM config) - -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState) -> MVar () -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), LSP.Handlers (ServerM config), (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) -setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do +setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar = do -- Send everything over a channel, since you need to wait until after initialise before -- LspFuncs is available clientMsgChan :: Chan ReactorMessage <- newChan @@ -177,7 +178,7 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. - let doInitialize = handleInit recorder getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan + let doInitialize = handleInit recorder defaultRoot getHieDbLoc getIdeState reactorLifetime exit clearReqId waitForCancel clientMsgChan let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO @@ -186,19 +187,23 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do handleInit :: Recorder (WithPriority Log) + -> FilePath -- ^ root directory, see Note [Root Directory] -> (FilePath -> IO FilePath) - -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState) -> MVar () -> IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) -handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do +handleInit recorder defaultRoot getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params - let root = LSP.resRootPath env - dir <- maybe getCurrentDirectory return root - dbLoc <- getHieDbLoc dir + -- only shift if lsp root is different from the rootDir + -- see Note [Root Directory] + root <- case LSP.resRootPath env of + Just lspRoot | lspRoot /= defaultRoot -> setCurrentDirectory lspRoot >> return lspRoot + _ -> pure defaultRoot + dbLoc <- getHieDbLoc root let initConfig = parseConfiguration params logWith recorder Info $ LogRegisteringIdeConfig initConfig dbMVar <- newEmptyMVar diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 2c365475d0..0c1c740596 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 :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments +defaultArguments recorder projectRoot plugins = Arguments + { argsProjectRoot = projectRoot -- ^ see Note [Root Directory] , argCommand = LSP , argsRules = mainRule (cmapWithPrio LogRules recorder) def , argsGhcidePlugin = mempty @@ -271,11 +271,11 @@ defaultArguments recorder plugins = Arguments } -testing :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments -testing recorder plugins = +testing :: Recorder (WithPriority Log) -> FilePath -> IdePlugins IdeState -> Arguments +testing recorder projectRoot plugins = let arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } = - defaultArguments recorder plugins + defaultArguments recorder projectRoot plugins hlsPlugins = pluginDescToIdePlugins $ idePluginsToPluginDesc argsHlsPlugins ++ [Test.blockCommandDescriptor "block-command", Test.plugin] @@ -326,22 +326,18 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) ideStateVar <- newEmptyMVar - let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState + let getIdeState :: LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> IndexQueue -> IO IdeState getIdeState env rootPath withHieDb hieChan = do - traverse_ IO.setCurrentDirectory rootPath t <- ioT logWith recorder Info $ LogLspStartDuration t - - dir <- maybe IO.getCurrentDirectory return rootPath - -- We want to set the global DynFlags right now, so that we can use -- `unsafeGlobalDynFlags` even before the project is configured _mlibdir <- - setInitialDynFlags (cmapWithPrio LogSession recorder) dir argsSessionLoadingOptions + setInitialDynFlags (cmapWithPrio LogSession recorder) rootPath argsSessionLoadingOptions -- TODO: should probably catch/log/rethrow at top level instead `catchAny` (\e -> logWith recorder Error (LogSetInitialDynFlagsException e) >> pure Nothing) - sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions dir + sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath config <- LSP.runLspT env LSP.getConfig let def_options = argsIdeOptions config sessionLoader @@ -367,10 +363,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 (cmapWithPrio LogLanguageServer recorder) argsProjectRoot argsGetHieDbLoc (pluginHandlers plugins) getIdeState -- See Note [Client configuration in Rules] onConfigChange cfg = do -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint @@ -388,7 +385,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup dumpSTMStats Check argFiles -> do - dir <- maybe IO.getCurrentDirectory return argsProjectRoot + let dir = argsProjectRoot dbLoc <- getHieDbLoc dir runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error @@ -418,7 +415,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) @@ -436,7 +433,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re unless (null failed) (exitWith $ ExitFailure (length failed)) Db opts cmd -> do - root <- maybe IO.getCurrentDirectory return argsProjectRoot + let root = argsProjectRoot dbLoc <- getHieDbLoc root hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc mlibdir <- setInitialDynFlags (cmapWithPrio LogSession recorder) root def @@ -446,7 +443,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 "." @@ -456,7 +453,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..dc2999dee6 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -28,8 +28,8 @@ import Development.IDE.GHC.Error (catchSrcErrors) import Development.IDE.GHC.Util (lookupPackageConfig) import Development.IDE.Graph.Classes import Development.IDE.Types.Exports (ExportsMap, createExportsMap) +import Ide.PluginUtils (toAbsolute) import OpenTelemetry.Eventlog (withSpan) -import System.Directory (makeAbsolute) import System.FilePath -- | An 'HscEnv' with equality. Two values are considered equal @@ -59,14 +59,13 @@ updateHscEnvEq oldHscEnvEq newHscEnv = do update <$> Unique.newUnique -- | 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) + let importPathsCanon = 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/CPPTests.hs b/ghcide/test/exe/CPPTests.hs index da9f564fe4..91a59adc76 100644 --- a/ghcide/test/exe/CPPTests.hs +++ b/ghcide/test/exe/CPPTests.hs @@ -9,14 +9,14 @@ import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), SemanticTokensEdit (..), mkRange) import Language.LSP.Test -- import Test.QuickCheck.Instances () +import Config import Test.Tasty import Test.Tasty.HUnit -import TestUtils tests :: TestTree tests = testGroup "cpp" - [ ignoreInWindowsBecause "Throw a lsp session time out in windows for ghc-8.8 and is broken for other versions" $ testCase "cpp-error" $ do + [ testCase "cpp-error" $ do let content = T.unlines [ "{-# LANGUAGE CPP #-}", @@ -32,7 +32,7 @@ tests = let _ = e :: HUnitFailure run $ expectError content (2, 1) ) - , testSessionWait "cpp-ghcide" $ do + , testWithDummyPluginEmpty "cpp-ghcide" $ do _ <- createDoc "A.hs" "haskell" $ T.unlines ["{-# LANGUAGE CPP #-}" ,"main =" diff --git a/ghcide/test/exe/ClientSettingsTests.hs b/ghcide/test/exe/ClientSettingsTests.hs index 6d964d3542..698e0af165 100644 --- a/ghcide/test/exe/ClientSettingsTests.hs +++ b/ghcide/test/exe/ClientSettingsTests.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GADTs #-} module ClientSettingsTests (tests) where +import Config (lspTestCaps, testWithConfig) import Control.Applicative.Combinators import Control.Monad import Data.Aeson (toJSON) @@ -14,13 +15,14 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test -import Test.Hls (waitForProgressDone) +import Test.Hls (testConfigCaps, + waitForProgressDone) import Test.Tasty import TestUtils tests :: TestTree tests = testGroup "client settings handling" - [ testSession "ghcide restarts shake session on config changes" $ do + [ testWithConfig "ghcide restarts shake session on config changes" def {testConfigCaps = lspTestCaps} $ do setIgnoringLogNotifications False void $ createDoc "A.hs" "haskell" "module A where" waitForProgressDone diff --git a/ghcide/test/exe/CodeLensTests.hs b/ghcide/test/exe/CodeLensTests.hs index 6bebeda002..c5f320f5c7 100644 --- a/ghcide/test/exe/CodeLensTests.hs +++ b/ghcide/test/exe/CodeLensTests.hs @@ -2,6 +2,7 @@ module CodeLensTests (tests) where +import Config import Control.Applicative.Combinators import Control.Lens ((^.)) import Control.Monad (void) @@ -18,10 +19,9 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test -import Test.Hls (waitForProgressDone) +import Test.Hls (mkRange, waitForProgressDone) import Test.Tasty import Test.Tasty.HUnit -import TestUtils tests :: TestTree tests = testGroup "code lenses" @@ -46,7 +46,7 @@ addSigLensesTests = after' enableGHCWarnings exported (def, sig) others = T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others createConfig mode = A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]] - sigSession testName enableGHCWarnings waitForDiags mode exported def others = testSession testName $ do + sigSession testName enableGHCWarnings waitForDiags mode exported def others = testWithDummyPluginEmpty testName $ do let originalCode = before enableGHCWarnings exported def others let expectedCode = after' enableGHCWarnings exported def others setConfigSection "haskell" (createConfig mode) @@ -100,7 +100,7 @@ addSigLensesTests = [ sigSession "with GHC warnings" True True "diagnostics" "" (second Just $ head cases) [] , sigSession "without GHC warnings" False False "diagnostics" "" (second (const Nothing) $ head cases) [] ] - , testSession "keep stale lens" $ do + , testWithDummyPluginEmpty "keep stale lens" $ do let content = T.unlines [ "module Stale where" , "f = _" diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 0a7751fc4b..84b3664def 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -11,33 +11,37 @@ module Config( , testWithDummyPluginEmpty , testWithDummyPlugin' , testWithDummyPluginEmpty' - , testWithDummyPluginAndCap' + , testWithConfig + , testWithExtraFiles , runWithExtraFiles , runInDir - , testWithExtraFiles + , run - -- * utilities for testing definition and hover + -- * utilities for testing , Expect(..) , pattern R , mkR , checkDefs , mkL + , withLongTimeout , lspTestCaps , lspTestCapsNoFileWatches ) where +import Control.Exception (bracket_) import Control.Lens.Setter ((.~)) import Data.Foldable (traverse_) import Data.Function ((&)) import qualified Data.Text as T +import Development.IDE (Pretty) import Development.IDE.Test (canonicalizeUri) import Ide.Types (defaultPluginDescriptor) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types (Null (..)) +import System.Environment.Blank (setEnv, unsetEnv) import System.FilePath (()) import Test.Hls import qualified Test.Hls.FileSystem as FS -import Test.Hls.FileSystem (FileSystem, fsRoot) testDataDir :: FilePath testDataDir = "ghcide" "test" "data" @@ -52,37 +56,53 @@ 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' = runSessionWithServerInTmpDirCont' def dummyPlugin +testWithConfig :: String -> TestConfig () -> Session () -> TestTree +testWithConfig name conf s = testCase name $ runSessionWithTestConfig conf $ const s -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 +runWithDummyPlugin' :: FS.VirtualFileTree -> (FilePath -> Session a) -> IO a +runWithDummyPlugin' fs = runSessionWithTestConfig def + { testPluginDescriptor = dummyPlugin + , testDirLocation = Right fs + , testConfigCaps = lspTestCaps + , testShiftRoot = True + } 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 + +testSession' :: TestName -> (FilePath -> Session ()) -> TestTree +testSession' name = testCase name . run' + +run :: Session a -> IO a +run = runSessionWithTestConfig def + { testDirLocation = Right (mkIdeTestFs []) + , testPluginDescriptor = dummyPlugin } + . const + +run' :: (FilePath -> Session a) -> IO a +run' = runSessionWithTestConfig def + { testDirLocation = Right (mkIdeTestFs []) + , testPluginDescriptor = dummyPlugin } pattern R :: UInt -> UInt -> UInt -> UInt -> Range pattern R x y x' y' = Range (Position x y) (Position x' y') @@ -146,3 +166,6 @@ lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) N lspTestCapsNoFileWatches :: ClientCapabilities lspTestCapsNoFileWatches = lspTestCaps & L.workspace . traverse . L.didChangeWatchedFiles .~ Nothing + +withLongTimeout :: IO a -> IO a +withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") diff --git a/ghcide/test/exe/CradleTests.hs b/ghcide/test/exe/CradleTests.hs index 196bea95e6..ca922d53cc 100644 --- a/ghcide/test/exe/CradleTests.hs +++ b/ghcide/test/exe/CradleTests.hs @@ -25,13 +25,14 @@ import Language.LSP.Test import System.FilePath import System.IO.Extra hiding (withTempDir) -- import Test.QuickCheck.Instances () +import Config import Config (checkDefs, mkL) import Control.Lens ((^.)) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) import GHC.TypeLits (symbolVal) +import Test.Hls (ignoreForGhcVersions) import Test.Tasty import Test.Tasty.HUnit -import TestUtils tests :: TestTree @@ -40,17 +41,17 @@ tests = testGroup "cradle" ,testGroup "ignore-fatal" [ignoreFatalWarning] ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] ,testGroup "multi" (multiTests "multi") - ,ignoreFor (BrokenForGHC [GHC92]) "multiple units not supported on 9.2" + ,ignoreForGhcVersions [GHC92] "multiple units not supported on 9.2" $ testGroup "multi-unit" (multiTests "multi-unit") ,testGroup "sub-directory" [simpleSubDirectoryTest] - ,ignoreFor (BrokenForGHC [GHC92]) "multiple units not supported on 9.2" + ,ignoreForGhcVersions [GHC92] "multiple units not supported on 9.2" $ testGroup "multi-unit-rexport" [multiRexportTest] ] loadCradleOnlyonce :: TestTree loadCradleOnlyonce = testGroup "load cradle only once" - [ testSession' "implicit" implicit - , testSession' "direct" direct + [ testWithDummyPluginEmpty' "implicit" implicit + , testWithDummyPluginEmpty' "direct" direct ] where direct dir = do @@ -70,7 +71,7 @@ loadCradleOnlyonce = testGroup "load cradle only once" liftIO $ length msgs @?= 0 retryFailedCradle :: TestTree -retryFailedCradle = testSession' "retry failed" $ \dir -> do +retryFailedCradle = testWithDummyPluginEmpty' "retry failed" $ \dir -> do -- The false cradle always fails let hieContents = "cradle: {bios: {shell: \"false\"}}" hiePath = dir "hie.yaml" @@ -124,7 +125,7 @@ multiTestName :: FilePath -> String -> String multiTestName dir name = "simple-" ++ dir ++ "-" ++ name simpleMultiTest :: FilePath -> TestTree -simpleMultiTest variant = testCase (multiTestName variant "test") $ withLongTimeout $ runWithExtraFiles variant $ \dir -> do +simpleMultiTest variant = testCase (multiTestName variant "test") $ runWithExtraFiles variant $ \dir -> do let aPath = dir "a/A.hs" bPath = dir "b/B.hs" adoc <- openDoc aPath "haskell" @@ -201,7 +202,7 @@ multiRexportTest = expectNoMoreDiagnostics 0.5 sessionDepsArePickedUp :: TestTree -sessionDepsArePickedUp = testSession' +sessionDepsArePickedUp = testWithDummyPluginEmpty' "session-deps-are-picked-up" $ \dir -> do liftIO $ diff --git a/ghcide/test/exe/DependentFileTest.hs b/ghcide/test/exe/DependentFileTest.hs index dc55ff80d3..d2d19cf88d 100644 --- a/ghcide/test/exe/DependentFileTest.hs +++ b/ghcide/test/exe/DependentFileTest.hs @@ -4,7 +4,6 @@ module DependentFileTest (tests) where import Config -import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T import Development.IDE.Test (expectDiagnostics) import Development.IDE.Types.Location @@ -15,19 +14,23 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test -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 def + { testShiftRoot = True + , testDirLocation = Right (mkIdeTestFs []) + , testPluginDescriptor = dummyPlugin + } test] ] where - test :: FileSystem -> Session () - test dir = do + test :: FilePath -> Session () + test _ = 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 +38,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 +50,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..660dcb3241 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -36,10 +36,10 @@ 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, testDirLocation, testDisableKick, testPluginDescriptor), + runSessionWithTestConfig, waitForProgressBegin) -import Test.Hls.FileSystem (directCradle, file, text, - toAbsFp) +import Test.Hls.FileSystem (directCradle, file, text) import Test.Tasty import Test.Tasty.HUnit @@ -169,7 +169,13 @@ 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 + , testDirLocation = Right (mkIdeTestFs []) + } + $ \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 +184,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 +458,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 @@ -574,8 +580,13 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r expectNoMoreDiagnostics 0.5 where - -- similar to run except it disables kick - runTestNoKick s = runSessionWithServerInTmpDirCont True dummyPlugin def def def (mkIdeTestFs []) (const s) + runTestNoKick s = + runSessionWithTestConfig def + { testPluginDescriptor = dummyPlugin + , testDirLocation = Right (mkIdeTestFs []) + , testDisableKick = True + } $ const s + typeCheck doc = do WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ assertBool "The file should typecheck" ideResultSuccess diff --git a/ghcide/test/exe/ExceptionTests.hs b/ghcide/test/exe/ExceptionTests.hs index 6d19891978..6c08f7ecba 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,28 +28,32 @@ import Language.LSP.Protocol.Types hiding mkRange) import Language.LSP.Test import LogType (Log (..)) -import Test.Hls (waitForProgressDone) +import Test.Hls (TestConfig (testDisableDefaultPlugin, testPluginDescriptor), + runSessionWithTestConfig, + testCheckProject, + testConfigSession, + 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 r = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginHandlers = mconcat [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do _ <- liftIO $ throwIO DivideByZero pure (InL []) ] - }] - testIde recorder (testingLite recorder plugins) $ do + }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False + } $ const $ do doc <- createDoc "A.hs" "haskell" "module A where" - waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) case lens of Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) -> @@ -63,15 +64,16 @@ tests recorder = do , testCase "Commands" $ do let pluginId = "command-exception" commandId = CommandId "exception" - plugins = pluginDescToIdePlugins $ + plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins r = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginCommands = [ PluginCommand commandId "Causes an exception" $ \_ _ (_::Int) -> do _ <- liftIO $ throwIO DivideByZero pure (InR Null) ] - }] - testIde recorder (testingLite recorder plugins) $ do + }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ do _ <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone let cmd = mkLspCommand (coerce pluginId) commandId "" (Just [A.toJSON (1::Int)]) @@ -85,7 +87,8 @@ tests recorder = do , testCase "Notification Handlers" $ do let pluginId = "notification-exception" - plugins = pluginDescToIdePlugins $ + plugins :: Recorder (WithPriority Log) -> IdePlugins IdeState + plugins r = pluginDescToIdePlugins $ [ (defaultPluginDescriptor pluginId "") { pluginNotificationHandlers = mconcat [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> @@ -95,8 +98,8 @@ tests recorder = do [ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do pure (InL []) ] - }] - testIde recorder (testingLite recorder plugins) $ do + }] ++ [Notifications.descriptor (cmapWithPrio LogNotifications r) "ghcide-core"] + runSessionWithTestConfig def {testPluginDescriptor = plugins, testDisableDefaultPlugin=True, testCheckProject=False} $ const $ do doc <- createDoc "A.hs" "haskell" "module A where" waitForProgressDone (view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) @@ -108,37 +111,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 +130,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, testCheckProject=False} $ 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/GarbageCollectionTests.hs b/ghcide/test/exe/GarbageCollectionTests.hs index 31b705c0f3..8c0c428c1a 100644 --- a/ghcide/test/exe/GarbageCollectionTests.hs +++ b/ghcide/test/exe/GarbageCollectionTests.hs @@ -1,5 +1,6 @@ module GarbageCollectionTests (tests) where +import Config (testWithDummyPluginEmpty') import Control.Monad.IO.Class (liftIO) import qualified Data.Set as Set import qualified Data.Text as T @@ -13,20 +14,19 @@ import Language.LSP.Test import System.FilePath import Test.Tasty import Test.Tasty.HUnit -import TestUtils import Text.Printf (printf) tests :: TestTree tests = testGroup "garbage collection" [ testGroup "dirty keys" - [ testSession' "are collected" $ \dir -> do + [ testWithDummyPluginEmpty' "are collected" $ \dir -> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" doc <- generateGarbage "A" dir closeDoc doc garbage <- waitForGC liftIO $ assertBool "no garbage was found" $ not $ null garbage - , testSession' "are deleted from the state" $ \dir -> do + , testWithDummyPluginEmpty' "are deleted from the state" $ \dir -> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" docA <- generateGarbage "A" dir keys0 <- getStoredKeys @@ -36,7 +36,7 @@ tests = testGroup "garbage collection" keys1 <- getStoredKeys liftIO $ assertBool "keys were not deleted from the state" (length keys1 < length keys0) - , testSession' "are not regenerated unless needed" $ \dir -> do + , testWithDummyPluginEmpty' "are not regenerated unless needed" $ \dir -> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A.hs, B.hs]}}" docA <- generateGarbage "A" dir _docB <- generateGarbage "B" dir @@ -57,7 +57,7 @@ tests = testGroup "garbage collection" Set.intersection (Set.fromList garbage) (Set.fromList keysB) liftIO $ regeneratedKeys @?= mempty - , testSession' "regenerate successfully" $ \dir -> do + , testWithDummyPluginEmpty' "regenerate successfully" $ \dir -> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [A]}}" docA <- generateGarbage "A" dir closeDoc docA 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/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs index 16e4e4b6f4..6192a8aeed 100644 --- a/ghcide/test/exe/InitializeResponseTests.hs +++ b/ghcide/test/exe/InitializeResponseTests.hs @@ -87,7 +87,7 @@ tests = withResource acquire release tests where innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error" acquire :: IO (TResponseMessage Method_Initialize) - acquire = runWithDummyPlugin (mkIdeTestFs []) initializeResponse + acquire = run initializeResponse release :: TResponseMessage Method_Initialize -> IO () release = mempty 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..f15606ac9c 100644 --- a/ghcide/test/exe/ReferenceTests.hs +++ b/ghcide/test/exe/ReferenceTests.hs @@ -26,7 +26,10 @@ import qualified Data.Aeson as A import Data.Default (def) import Data.Tuple.Extra import GHC.TypeLits (symbolVal) +import Ide.PluginUtils (toAbsolute) import Ide.Types +import System.FilePath (addTrailingPathSeparator, + ()) import Test.Hls (FromServerMessage' (..), SMethod (..), TCustomMessage (..), @@ -167,13 +170,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 = addTrailingPathSeparator 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 +191,23 @@ 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 +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 +215,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/THTests.hs b/ghcide/test/exe/THTests.hs index dd27a966de..61c2ef49f3 100644 --- a/ghcide/test/exe/THTests.hs +++ b/ghcide/test/exe/THTests.hs @@ -1,6 +1,7 @@ module THTests (tests) where +import Config import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T import Development.IDE.GHC.Util @@ -16,14 +17,13 @@ import Test.Hls (waitForAllProgressDone, waitForProgressBegin) import Test.Tasty import Test.Tasty.HUnit -import TestUtils tests :: TestTree tests = testGroup "TemplateHaskell" [ -- Test for https://github.com/haskell/ghcide/pull/212 - testSessionWait "load" $ do + testWithDummyPluginEmpty "load" $ do let sourceA = T.unlines [ "{-# LANGUAGE PackageImports #-}", @@ -46,7 +46,7 @@ tests = _ <- createDoc "A.hs" "haskell" sourceA _ <- createDoc "B.hs" "haskell" sourceB expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Error, (6, 29), "Variable not in scope: n")] ) ] - , testSessionWait "newtype-closure" $ do + , testWithDummyPluginEmpty "newtype-closure" $ do let sourceA = T.unlines [ "{-# LANGUAGE DeriveDataTypeable #-}" @@ -70,11 +70,11 @@ tests = , thReloadingTest False , thLoadingTest , thCoreTest - , ignoreInWindowsBecause "Broken in windows" $ thReloadingTest True + , thReloadingTest True -- Regression test for https://github.com/haskell/haskell-language-server/issues/891 , thLinkingTest False - , ignoreInWindowsBecause "Broken in windows" $ thLinkingTest True - , testSessionWait "findsTHIdentifiers" $ do + , thLinkingTest True + , testWithDummyPluginEmpty "findsTHIdentifiers" $ do let sourceA = T.unlines [ "{-# LANGUAGE TemplateHaskell #-}" diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index 0b9ce03eb2..87c129ba2f 100644 --- a/ghcide/test/exe/TestUtils.hs +++ b/ghcide/test/exe/TestUtils.hs @@ -195,18 +195,3 @@ copyTestDataFiles dir prefix = do withLongTimeout :: IO a -> IO a withLongTimeout = bracket_ (setEnv "LSP_TIMEOUT" "120" True) (unsetEnv "LSP_TIMEOUT") -testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () -testIde recorder arguments session = do - config <- getConfigFromEnv - cwd <- getCurrentDirectory - (hInRead, hInWrite) <- createPipe - (hOutRead, hOutWrite) <- createPipe - - let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments - { IDE.argsHandleIn = pure hInRead - , IDE.argsHandleOut = pure hOutWrite - } - - withTempDir $ \dir -> do - flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ -> - runSessionWithHandles hInWrite hOutRead config lspTestCaps dir session diff --git a/ghcide/test/exe/UnitTests.hs b/ghcide/test/exe/UnitTests.hs index 4900b7cae4..1e8ac4214a 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,10 @@ 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 + 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 92bcc694ab..8d58d70a81 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-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index a5f8d7ba54..c5609065c3 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -32,6 +32,8 @@ module Ide.PluginUtils usePropertyLsp, -- * Escape unescape, + -- * toAbsolute + toAbsolute ) where @@ -50,6 +52,7 @@ import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types import Language.LSP.Server +import System.FilePath (()) import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P import qualified Text.Megaparsec.Char.Lexer as P @@ -316,3 +319,12 @@ escapedTextParser = concat <$> P.many (outsideStringLiteral P.<|> stringLiteral) inside' = concatMap f inside pure $ "\"" <> inside' <> "\"" + +-- --------------------------------------------------------------------- + +-- | toAbsolute +-- use `toAbsolute` to state our intention that we are actually make a path absolute +-- the first argument should be the root directory +-- the second argument should be the relative path +toAbsolute :: FilePath -> FilePath -> FilePath +toAbsolute = () diff --git a/hls-test-utils/hls-test-utils.cabal b/hls-test-utils/hls-test-utils.cabal index cebf06629b..f284f8088d 100644 --- a/hls-test-utils/hls-test-utils.cabal +++ b/hls-test-utils/hls-test-utils.cabal @@ -46,6 +46,7 @@ library , ghcide == 2.8.0.0 , hls-plugin-api == 2.8.0.0 , lens + , lsp , lsp-test ^>=0.17 , lsp-types ^>=2.2 , safe-exceptions diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 92bd49ac13..cb566078b5 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -4,6 +4,9 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty, @@ -25,19 +28,12 @@ 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 +59,7 @@ module Test.Hls WithPriority(..), Recorder, Priority(..), + TestConfig(..), ) where @@ -79,7 +76,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)) @@ -87,7 +84,10 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Development.IDE (IdeState, - LoggingColumn (ThreadIdColumn)) + LoggingColumn (ThreadIdColumn), + defaultLayoutOptions, + layoutPretty, renderStrict) +import qualified Development.IDE.LSP.Notifications as Notifications import Development.IDE.Main hiding (Log) import qualified Development.IDE.Main as IDEMain import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), @@ -104,16 +104,23 @@ import Ide.Logger (Pretty (pretty), logWith, makeDefaultStderrRecorder, (<+>)) +import qualified Ide.Logger as Logger +import Ide.Plugin.Properties ((&)) +import Ide.PluginUtils (idePluginsToPluginDesc, + pluginDescToIdePlugins) import Ide.Types import Language.LSP.Protocol.Capabilities import Language.LSP.Protocol.Message +import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types hiding (Null) +import qualified Language.LSP.Server as LSP import Language.LSP.Test import Prelude hiding (log) import System.Directory (canonicalizePath, createDirectoryIfMissing, getCurrentDirectory, getTemporaryDirectory, + makeAbsolute, setCurrentDirectory) import System.Environment (lookupEnv, setEnv) import System.FilePath @@ -201,7 +208,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 { + testDirLocation = Left 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" @@ -223,7 +257,13 @@ goldenWithHaskellAndCapsInTmpDir -> TestTree goldenWithHaskellAndCapsInTmpDir config clientCaps plugin title tree path desc ext act = goldenGitDiff title (vftOriginalRoot tree path <.> desc <.> ext) - $ runSessionWithServerAndCapsInTmpDir config plugin clientCaps tree + $ + runSessionWithTestConfig def { + testDirLocation = Right tree, + testConfigCaps = clientCaps, + testLspConfig = config, + testPluginDescriptor = plugin + } $ const $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "haskell" @@ -375,6 +415,7 @@ hlsPluginTestRecorder = initializeTestRecorder ["HLS_TEST_PLUGIN_LOG_STDERR", "H initializeTestRecorder :: Pretty a => [String] -> IO (Recorder (WithPriority a)) initializeTestRecorder envVars = do docWithPriorityRecorder <- makeDefaultStderrRecorder (Just $ ThreadIdColumn : defaultLoggingColumns) + -- lspClientLogRecorder -- There are potentially multiple environment variables that enable this logger definedEnvVars <- forM envVars (fmap (fromMaybe "0") . lookupEnv) let logStdErr = any (/= "0") definedEnvVars @@ -389,70 +430,15 @@ initializeTestRecorder envVars = do -- Run an HLS server testing a specific plugin -- ------------------------------------------------------------ runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a -runSessionWithServerInTmpDir config plugin tree act = runSessionWithServerInTmpDirCont' config plugin tree (const act) - -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' 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 config plugin caps tree act = do - runSessionWithServerInTmpDirCont False plugin config def caps tree act - -runSessionWithServerInTmpDir' :: - Pretty b => - -- | Plugins to load on the server. - PluginTestDescriptor b -> - -- | lsp config for the server - Config -> - -- | config for the test session - SessionConfig -> - ClientCapabilities -> - VirtualFileTree -> - Session a -> IO a -runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = runSessionWithServerInTmpDirCont False plugins conf sessConf caps tree (const act) +runSessionWithServerInTmpDir config plugin tree act = + runSessionWithTestConfig def + {testLspConfig=config, testPluginDescriptor = plugin, testDirLocation=Right tree} + (const act) --- | Host a server, and run a test session on it. --- --- Creates a temporary directory, and materializes the VirtualFileTree --- in the temporary directory. --- --- To debug test cases and verify the file system is correctly set up, --- you should set the environment variable 'HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1'. --- Further, we log the temporary directory location on startup. To view --- the logs, set the environment variable 'HLS_TEST_HARNESS_STDERR=1'. --- --- Example invocation to debug test cases: --- --- @ --- HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 HLS_TEST_HARNESS_STDERR=1 cabal test --- @ --- --- Don't forget to use 'TASTY_PATTERN' to debug only a subset of tests. --- --- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'. --- --- Note: cwd will be shifted into a temporary directory in @Session a@ -runSessionWithServerInTmpDirCont :: - Pretty b => - -- | whether we disable the kick action or not - Bool -> - -- | Plugins to load on the server. - PluginTestDescriptor b -> - -- | lsp config for the server - Config -> - -- | config for the test session - SessionConfig -> - ClientCapabilities -> - VirtualFileTree -> - (FileSystem -> Session a) -> IO a -runSessionWithServerInTmpDirCont disableKick plugins conf sessConf caps tree act = withLock lockForTempDirs $ do +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" @@ -468,23 +454,35 @@ runSessionWithServerInTmpDirCont disableKick plugins conf sessConf caps tree act 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) + act fs 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 - -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 - +runSessionWithServer config plugin fp act = + runSessionWithTestConfig def { + testLspConfig=config + , testPluginDescriptor=plugin + , testDirLocation = Left fp + } (const act) + + +instance Default (TestConfig b) where + def = TestConfig { + testDirLocation = Right $ VirtualFileTree [] "", + testShiftRoot = False, + testDisableKick = False, + testDisableDefaultPlugin = False, + testPluginDescriptor = mempty, + testLspConfig = def, + testConfigSession = def, + testConfigCaps = fullCaps, + testCheckProject = False + } -- | Setup the test environment for isolated tests. -- @@ -617,60 +615,81 @@ 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 + { + testDirLocation :: Either FilePath VirtualFileTree + -- ^ The file tree to use for the test, either a directory or a virtual file tree + -- if using a virtual file tree, + -- Creates a temporary directory, and materializes the VirtualFileTree + -- in the temporary directory. + -- + -- To debug test cases and verify the file system is correctly set up, + -- you should set the environment variable 'HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1'. + -- Further, we log the temporary directory location on startup. To view + -- the logs, set the environment variable 'HLS_TEST_HARNESS_STDERR=1'. + -- Example invocation to debug test cases: + -- + -- @ + -- HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 HLS_TEST_HARNESS_STDERR=1 cabal test + -- @ + -- + -- Don't forget to use 'TASTY_PATTERN' to debug only a subset of tests. + -- + -- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'. + , testShiftRoot :: Bool + -- ^ Whether to shift the current directory to the root of the project + , testDisableKick :: Bool + -- ^ Whether to disable the kick action + , testDisableDefaultPlugin :: Bool + -- ^ Whether to disable the default plugin comes with ghcide + , testCheckProject :: Bool + -- ^ Whether to typecheck check the project after the session is loaded + , 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 + } + + +wrapClientLogger :: Pretty a => Recorder (WithPriority a) -> + IO (Recorder (WithPriority a), LSP.LanguageContextEnv Config -> IO ()) +wrapClientLogger logger = do + (lspLogRecorder', cb1) <- Logger.withBacklog Logger.lspClientLogRecorder + let lspLogRecorder = cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions. pretty) lspLogRecorder' + return (lspLogRecorder <> logger, cb1) + +-- | Host a server, and run a test session on it. +-- For setting custom timeout, set the environment variable 'LSP_TIMEOUT' +-- * LSP_TIMEOUT=10 cabal test +-- For more detail of the test configuration, see 'TestConfig' +runSessionWithTestConfig :: Pretty b => TestConfig b -> (FilePath -> Session a) -> IO a +runSessionWithTestConfig TestConfig{..} session = + runSessionInVFS testDirLocation $ \root -> shiftRoot root $ do (inR, inW) <- createPipe (outR, outW) <- createPipe - recorder <- hlsPluginTestRecorder - let plugins = pluginsDp 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 - } - + (recorder, cb1) <- wrapClientLogger =<< hlsPluginTestRecorder + (recorderIde, cb2) <- wrapClientLogger =<< hlsHelperTestRecorder + -- This plugin just installs a handler for the `initialized` notification, which then + -- picks up the LSP environment and feeds it to our recorders + let lspRecorderPlugin = pluginDescToIdePlugins [(defaultPluginDescriptor "LSPRecorderCallback" "Internal plugin") + { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SMethod_Initialized $ \_ _ _ _ -> do + env <- LSP.getLspEnv + liftIO $ (cb1 <> cb2) env + }] + + let plugins = testPluginDescriptor recorder <> lspRecorderPlugin + timeoutOverride <- fmap read <$> lookupEnv "LSP_TIMEOUT" + let sconf' = testConfigSession { lspConfig = hlsConfigToClientConfig testLspConfig, messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride} + arguments = testingArgs root 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 +697,38 @@ 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 (Left testConfigRoot) act = do + root <- makeAbsolute testConfigRoot + act root + runSessionInVFS (Right vfs) act = runWithLockInTempDir vfs $ \fs -> act (fsRoot fs) + testingArgs prjRoot recorderIde plugins = + let + arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } = defaultArguments (cmapWithPrio LogIDEMain recorderIde) prjRoot 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 testCheckProject + } + in + arguments + { argsHlsPlugins = hlsPlugins + , argsIdeOptions = ideOptions + , argsLspOptions = argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 } + , argsDefaultHlsConfig = testLspConfig + , argsProjectRoot = prjRoot + , argsDisableKick = testDisableKick + } -- | Wait for the next progress begin step waitForProgressBegin :: Session () diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index 90ec2f07f9..92bada04f7 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -29,14 +29,12 @@ module Test.Hls.Util , dontExpectCodeAction , expectDiagnostic , expectNoMoreDiagnostics - , expectSameLocations , failIfSessionTimeout , getCompletionByLabel , noLiteralCaps , inspectCodeAction , inspectCommand , inspectDiagnostic - , SymbolLocation , waitForDiagnosticsFrom , waitForDiagnosticsFromSource , waitForDiagnosticsFromSourceWithTimeout @@ -314,23 +312,6 @@ failIfSessionTimeout action = action `catch` errorHandler errorHandler e@(Test.Timeout _) = assertFailure $ show e errorHandler e = throwIO e --- | To locate a symbol, we provide a path to the file from the HLS root --- directory, the line number, and the column number. (0 indexed.) -type SymbolLocation = (FilePath, UInt, UInt) - -expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion -actual `expectSameLocations` expected = do - let actual' = - Set.map (\location -> (location ^. L.uri - , location ^. L.range . L.start . L.line - , location ^. L.range . L.start . L.character)) - $ Set.fromList actual - expected' <- Set.fromList <$> - (forM expected $ \(file, l, c) -> do - fp <- canonicalizePath file - return (filePathToUri fp, l, c)) - actual' @?= expected' - -- --------------------------------------------------------------------- getCompletionByLabel :: MonadIO m => T.Text -> [CompletionItem] -> m CompletionItem getCompletionByLabel desiredLabel compls = diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 2cbc339dfa..17f83e291a 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 + , testDirLocation = Left testDir + , testPluginDescriptor = hlintPlugin + , testShiftRoot = True} $ const $ do doc <- openDoc "Base.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "hlint" @@ -338,7 +343,14 @@ 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 def + { testConfigCaps = codeActionNoResolveCaps + , testShiftRoot = True + , testDirLocation = Left (testDir subdir) + , testPluginDescriptor = hlintPlugin + } + . const noHlintDiagnostics :: [Diagnostic] -> Assertion noHlintDiagnostics diags = @@ -416,9 +428,17 @@ 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 def + { testConfigCaps = codeActionNoResolveCaps + , testShiftRoot = True + , testPluginDescriptor = hlintPlugin + , testDirLocation = Left testDir + } + testName testDir path "expected" "hs" + ignoreHintGoldenResolveTest :: TestName -> FilePath -> Point -> T.Text -> TestTree ignoreHintGoldenResolveTest testCaseName goldenFilename point hintName = @@ -439,4 +459,10 @@ goldenResolveTest testCaseName goldenFilename point hintText = setupGoldenHlintResolveTest :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree setupGoldenHlintResolveTest testName path = - goldenWithHaskellAndCaps def codeActionResolveCaps hlintPlugin testName testDir path "expected" "hs" + goldenWithTestConfig def + { testConfigCaps = codeActionResolveCaps + , testShiftRoot = True + , testPluginDescriptor = hlintPlugin + , testDirLocation = Left testDir + } + 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..b185240ade 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), @@ -53,16 +53,17 @@ import Development.IDE.GHC.Compat (GenLocated (L), pm_parsed_source, unLoc) import Ide.Logger (Pretty (..)) import Ide.Plugin.Error +import Ide.PluginUtils (toAbsolute) import Ide.Types 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 @@ -150,7 +151,10 @@ pathModuleNames recorder state normFilePath filePath let paths = map (normalise . (<> pure pathSeparator)) srcPaths logWith recorder Debug (NormalisedPaths paths) - mdlPath <- liftIO $ makeAbsolute filePath + -- TODO, this can be avoid if the filePath is already absolute, + -- we can avoid the toAbsolute call in the future. + -- see Note [Root Directory] + 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 61d5b79c2a..f87cf98a98 100644 --- a/plugins/hls-notes-plugin/test/NotesTest.hs +++ b/plugins/hls-notes-plugin/test/NotesTest.hs @@ -1,7 +1,6 @@ module Main (main) where import Ide.Plugin.Notes (Log, descriptor) -import System.Directory (canonicalizePath) import System.FilePath (()) import Test.Hls @@ -14,43 +13,48 @@ main = defaultTestRunner $ [ gotoNoteTests ] +runSessionWithServer' :: FilePath -> (FilePath -> Session a) -> IO a +runSessionWithServer' fp act = + runSessionWithTestConfig def + { testLspConfig = def + , testPluginDescriptor = plugin + , testDirLocation = Left fp + } act + gotoNoteTests :: TestTree gotoNoteTests = testGroup "Goto Note Definition" - [ testCase "single_file" $ runSessionWithServer def plugin testDataDir $ do + [ + testCase "single_file" $ runSessionWithServer' testDataDir $ \dir -> do doc <- openDoc "NoteDef.hs" "haskell" waitForKickDone defs <- getDefinitions doc (Position 3 41) - liftIO $ do - fp <- canonicalizePath "NoteDef.hs" - defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 8 9) (Position 8 9))])) - , testCase "liberal_format" $ runSessionWithServer def plugin testDataDir $ do + let fp = dir "NoteDef.hs" + liftIO $ defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 8 9) (Position 8 9))])) + , testCase "liberal_format" $ runSessionWithServer' testDataDir $ \dir -> do doc <- openDoc "NoteDef.hs" "haskell" waitForKickDone defs <- getDefinitions doc (Position 5 64) - liftIO $ do - fp <- canonicalizePath "NoteDef.hs" - defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 18 11) (Position 18 11))])) + let fp = dir "NoteDef.hs" + liftIO $ defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 18 11) (Position 18 11))])) - , testCase "invalid_note" $ runSessionWithServer def plugin testDataDir $ do + , testCase "invalid_note" $ runSessionWithServer' testDataDir $ const $ do doc <- openDoc "NoteDef.hs" "haskell" waitForKickDone defs <- getDefinitions doc (Position 6 54) - liftIO $ do - defs @?= InL (Definition (InR [])) + liftIO $ defs @?= InL (Definition (InR [])) - , testCase "no_note" $ runSessionWithServer def plugin testDataDir $ do + , testCase "no_note" $ runSessionWithServer' testDataDir $ const $ do doc <- openDoc "NoteDef.hs" "haskell" waitForKickDone defs <- getDefinitions doc (Position 1 0) liftIO $ defs @?= InL (Definition (InR [])) - , testCase "unopened_file" $ runSessionWithServer def plugin testDataDir $ do + , testCase "unopened_file" $ runSessionWithServer' testDataDir $ \dir -> do doc <- openDoc "Other.hs" "haskell" waitForKickDone defs <- getDefinitions doc (Position 5 20) - liftIO $ do - fp <- canonicalizePath "NoteDef.hs" - defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 12 6) (Position 12 6))])) + let fp = dir "NoteDef.hs" + liftIO $ defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 12 6) (Position 12 6))])) ] testDataDir :: FilePath diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 3670a3b398..7777eb5eec 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -3751,7 +3751,12 @@ 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 + { testDirLocation = Left 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..e35d7c5b06 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 + { testDirLocation = Left $ 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..34fec3a4a4 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -129,7 +129,6 @@ import Retrie.SYB (everything, extQ, listify, mkQ) import Retrie.Types import Retrie.Universe (Universe) -import System.Directory (makeAbsolute) #if MIN_VERSION_ghc(9,3,0) import GHC.Types.PkgQual @@ -762,7 +761,8 @@ reuseParsedModule state f = do getCPPmodule :: Recorder (WithPriority Log) -> IdeState -> HscEnv -> FilePath -> IO (FixityEnv, CPP AnnotatedModule) getCPPmodule recorder state session t = do - nt <- toNormalizedFilePath' <$> makeAbsolute t + -- TODO: is it safe to drop this makeAbsolute? + 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-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index 906319ed2a..5308b6fd71 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -3,7 +3,6 @@ {-# LANGUAGE OverloadedStrings #-} import Control.Lens ((^.), (^?)) -import Control.Monad.IO.Class (liftIO) import Data.Aeson (KeyValue (..), Object) import qualified Data.Aeson.KeyMap as KV import Data.Default @@ -15,35 +14,17 @@ import Data.Text hiding (length, map, import qualified Data.Text as Text import qualified Data.Text.Utf16.Rope.Mixed as Rope import Development.IDE (Pretty) -import Development.IDE.GHC.Compat (GhcVersion (..), - ghcVersion) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) -import Development.IDE.Test (waitForBuildQueue) import Ide.Plugin.SemanticTokens import Ide.Plugin.SemanticTokens.Mappings import Ide.Plugin.SemanticTokens.Types import Ide.Types import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Types -import Language.LSP.Test (Session, - SessionConfig (ignoreConfigurationRequests), - openDoc, request) import qualified Language.LSP.Test as Test import Language.LSP.VFS (VirtualFile (..)) import System.FilePath -import Test.Hls (HasCallStack, - PluginTestDescriptor, - SMethod (SMethod_TextDocumentSemanticTokensFullDelta), - TestName, TestTree, - changeDoc, - defaultTestRunner, - documentContents, fullCaps, - goldenGitDiff, - mkPluginTestDescriptor, - runSessionWithServerInTmpDir, - runSessionWithServerInTmpDir', - testCase, testGroup, - waitForAction, (@?=)) +import Test.Hls import qualified Test.Hls.FileSystem as FS import Test.Hls.FileSystem (file, text) @@ -155,20 +136,22 @@ semanticTokensConfigTest = let funcVar = KV.fromList ["functionToken" .= var] var :: String var = "variable" - do - Test.Hls.runSessionWithServerInTmpDir' - semanticTokensPlugin - (mkSemanticConfig funcVar) - def {ignoreConfigurationRequests = False} - fullCaps - fs - $ do - -- modifySemantic funcVar - void waitForBuildQueue - doc <- openDoc "Hello.hs" "haskell" - void waitForBuildQueue - result1 <- docLspSemanticTokensString doc - liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n" + Test.Hls.runSessionWithTestConfig def + { testPluginDescriptor = semanticTokensPlugin + , testConfigSession = def + { ignoreConfigurationRequests = False + } + , testConfigCaps = fullCaps + , testDirLocation = Right fs + , testLspConfig = mkSemanticConfig funcVar + } + $ const $ do + -- modifySemantic funcVar + void waitForBuildQueue + doc <- openDoc "Hello.hs" "haskell" + void waitForBuildQueue + result1 <- docLspSemanticTokensString doc + liftIO $ unlines (map show result1) @?= "2:1-3 SemanticTokenTypes_Variable \"go\"\n" ] semanticTokensFullDeltaTests :: TestTree diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index 20baa2f633..38cbd4d5da 100644 --- a/plugins/hls-splice-plugin/test/Main.hs +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -90,7 +90,7 @@ goldenTestWithEdit fp expect tc line col = void waitForDiagnostics void waitForBuildQueue - 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..231707d142 100644 --- a/plugins/hls-stan-plugin/test/Main.hs +++ b/plugins/hls-stan-plugin/test/Main.hs @@ -75,4 +75,11 @@ stanPlugin = mkPluginTestDescriptor enabledStanDescriptor "stan" runStanSession :: FilePath -> Session a -> IO a runStanSession subdir = - failIfSessionTimeout . runSessionWithServer def stanPlugin (testDir subdir) + failIfSessionTimeout + . runSessionWithTestConfig def{ + testConfigCaps=codeActionNoResolveCaps + , testShiftRoot=True + , testPluginDescriptor=stanPlugin + , testDirLocation=Left (testDir subdir) + } + . const diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 457e0dc4ec..cbe3f33bb3 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -131,7 +131,7 @@ runLspMode recorder ghcideArgs@GhcideArguments{..} idePlugins = withTelemetryRec log Info $ LogLspStart ghcideArgs (map pluginId $ ipMap idePlugins) let args = (if argsTesting then IDEMain.testing else IDEMain.defaultArguments) - (cmapWithPrio LogIDEMain recorder) idePlugins + (cmapWithPrio LogIDEMain recorder) dir idePlugins let telemetryRecorder = telemetryRecorder' & cmapWithPrio pretty diff --git a/test/functional/Config.hs b/test/functional/Config.hs index 1dbf12c64c..9d11cff3a5 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -68,7 +68,11 @@ 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 def + { testConfigSession=def {ignoreConfigurationRequests=False}, testShiftRoot=True + , testPluginDescriptor=plugin, testDirLocation=Left ("test/testdata" subdir) } + (const session) testPluginId = "testplugin" -- A disabled-by-default plugin that creates diagnostics