haskell/haskell-language-server
1
1
Fork 0
mirror of https://github.com/haskell/haskell-language-server.git synced 2024-08-15 19:40:25 +03:00
Code Issues Projects Releases Wiki Activity

Refactor hls-test-util and reduce getCurrentDirectory after initilization (#4231)

Browse Source 
What's done
* [x] Refactor the `runSession*` family function, properly add `TestConfig`, `runSessionWithTestConfig`, as the most generic `runSession*` function.
* [x] remove raraly used variants of `runSession*` functions and replaced by `runSessionWithTestConfig`. 
* [x] migrate `ExceptionTests ClientSettingsTests CodeLensTests CPPTests CradleTests` to use the `hls-test-utils`
* [x] Only shift to lsp root when current root is different from the lsp root in DefaultMain of ghcide. 
* [x] Remove most usage for `getCurrentDirectory`(After DefaultMain is called), Only remain those in top level of wrapper and exe, implement https://github.com/haskell/haskell-language-server/issues/3736#issuecomment-1924507928
* [x] add Note [Root Directory]

Co-authored-by: fendor <fendor@users.noreply.github.com>
This commit is contained in:
soulomoon 2024-05-27 22:03:43 +08:00 committed by GitHub
parent a6cb43b411
commit 838a51f761
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
43 changed files with 585 additions and 464 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
exe/Wrapper.hs
View File

@ -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

6
ghcide/exe/Main.hs
View File

@ -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]

54
ghcide/session-loader/Development/IDE/Session.hs
View File

@ -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

2
ghcide/src/Development/IDE.hs
View File

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

9
ghcide/src/Development/IDE/Core/Rules.hs
View File

@ -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)

8
ghcide/src/Development/IDE/Core/Service.hs
View File

@ -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 ()

36
ghcide/src/Development/IDE/Core/Shake.hs
View File

@ -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

21
ghcide/src/Development/IDE/LSP/LanguageServer.hs
View File

@ -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

37
ghcide/src/Development/IDE/Main.hs
View File

@ -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

9
ghcide/src/Development/IDE/Types/HscEnvEq.hs
View File

@ -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

5
ghcide/test/exe/BootTests.hs
View File

@ -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
]

6
ghcide/test/exe/CPPTests.hs
View File

@ -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 ="

6
ghcide/test/exe/ClientSettingsTests.hs
View File

@ -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

8
ghcide/test/exe/CodeLensTests.hs
View File

@ -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 = _"

57
ghcide/test/exe/Config.hs
View File

@ -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")

17
ghcide/test/exe/CradleTests.hs
View File

@ -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 $

23
ghcide/test/exe/DependentFileTest.hs
View File

@ -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

37
ghcide/test/exe/DiagnosticTests.hs
View File

@ -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

78
ghcide/test/exe/ExceptionTests.hs
View File

@ -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)

10
ghcide/test/exe/GarbageCollectionTests.hs
View File

@ -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

18
ghcide/test/exe/IfaceTests.hs
View File

@ -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

2
ghcide/test/exe/InitializeResponseTests.hs
View File

@ -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

2
ghcide/test/exe/Main.hs
View File

@ -114,5 +114,5 @@ main = do
, ReferenceTests.tests
, GarbageCollectionTests.tests
, HieDbRetry.tests
, ExceptionTests.tests recorder
, ExceptionTests.tests
]

20
ghcide/test/exe/ReferenceTests.hs
View File

@ -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'

12
ghcide/test/exe/THTests.hs
View File

@ -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 #-}"

15
ghcide/test/exe/TestUtils.hs
View File

@ -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

13
ghcide/test/exe/UnitTests.hs
View File

@ -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

1
haskell-language-server.cabal
View File

@ -654,6 +654,7 @@ library hls-retrie-plugin
, text
, transformers
, unordered-containers
, filepath
default-extensions:
DataKinds

12
hls-plugin-api/src/Ide/PluginUtils.hs
View File

@ -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 = (</>)

1
hls-test-utils/hls-test-utils.cabal
View File

@ -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

327
hls-test-utils/src/Test/Hls.hs
View File

@ -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)
runSessionWithServerInTmpDir config plugin tree act =
runSessionWithTestConfig def
{testLspConfig=config, testPluginDescriptor = plugin, testDirLocation=Right 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)
-- | 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 <plugin-name>
-- @
--
-- 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
runSessionWithServer config plugin fp act =
runSessionWithTestConfig def {
testLspConfig=config
, testPluginDescriptor=plugin
, testDirLocation = Left fp
} (const 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
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 <plugin-name>
-- @
--
-- 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
pure result
-- | 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
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 ()

19
hls-test-utils/src/Test/Hls/Util.hs
View File

@ -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 =

34
plugins/hls-hlint-plugin/test/Main.hs
View File

@ -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"

16
plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs
View File

@ -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

38
plugins/hls-notes-plugin/test/NotesTest.hs
View File

@ -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

7
plugins/hls-refactor-plugin/test/Main.hs
View File

@ -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 }

6
plugins/hls-rename-plugin/test/Main.hs
View File

@ -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

4
plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs
View File

@ -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

51
plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs
View File

@ -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

2
plugins/hls-splice-plugin/test/Main.hs
View File

@ -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}

9
plugins/hls-stan-plugin/test/Main.hs
View File

@ -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

2
src/Ide/Main.hs
View File

@ -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

6
test/functional/Config.hs
View File

@ -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