Skip to content

Commit edf7be5

Browse files
pepeiborrapepeiborra
authored
Enable the ghcide test plugin in HLS test suites (#2243)
* convert to HLS plugin * remove unnecessary check * use waitForBUildQueue in the Tactics test suite * use waitForBuildQueue in the splice test suite * use waitForBuildQueue in golden test helpers * really enable Test plugin * silenceStdErr to honor LSP_TEST_LOG_STDERR * Disable timeout in tactics testsuite * no longer silence stderr Instead, send all ghcide output through the logger and keep stderr open for fatals * silence the tactics plugin * fix ModLocation for nameless modules
1 parent 682386d commit edf7be5

File tree

14 files changed

+169
-109
lines changed

14 files changed

+169
-109
lines changed

‎ghcide/exe/Main.hs

Lines changed: 5 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -51,7 +51,9 @@ main = do
5151

5252
whenJust argsCwd IO.setCurrentDirectory
5353

54-
Main.defaultMain def
54+
let arguments = if argsTesting then Main.testing else def
55+
56+
Main.defaultMain arguments
5557
{Main.argCommand = argsCommand
5658

5759
,Main.argsRules = do
@@ -62,23 +64,13 @@ main = do
6264
unless argsDisableKick $
6365
action kick
6466

65-
,Main.argsHlsPlugins =
66-
pluginDescToIdePlugins $
67-
GhcIde.descriptors
68-
++ [Test.blockCommandDescriptor "block-command" | argsTesting]
69-
70-
,Main.argsGhcidePlugin = if argsTesting
71-
then Test.plugin
72-
else mempty
73-
7467
,Main.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i)
7568

76-
,Main.argsIdeOptions = \config sessionLoader ->
77-
let defOptions = defaultIdeOptions sessionLoader
69+
,Main.argsIdeOptions = \config sessionLoader ->
70+
let defOptions = Main.argsIdeOptions arguments config sessionLoader
7871
in defOptions
7972
{ optShakeProfiling = argsShakeProfiling
8073
, optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
81-
, optTesting = IdeTesting argsTesting
8274
, optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
8375
, optCheckParents = pure $ checkParents config
8476
, optCheckProject = pure $ checkProject config

‎ghcide/session-loader/Development/IDE/Session.hs

Lines changed: 16 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -102,7 +102,7 @@ data SessionLoadingOptions = SessionLoadingOptions
102102
-- or 'Nothing' to respect the cradle setting
103103
, getCacheDirs :: String -> [String] -> IO CacheDirs
104104
-- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'
105-
, getInitialGhcLibDir :: FilePath -> IO (Maybe LibDir)
105+
, getInitialGhcLibDir :: Logger -> FilePath -> IO (Maybe LibDir)
106106
, fakeUid :: UnitId
107107
-- ^ unit id used to tag the internal component built by ghcide
108108
-- To reuse external interface files the unit ids must match,
@@ -140,11 +140,11 @@ loadWithImplicitCradle mHieYaml rootDir = do
140140
Just yaml -> HieBios.loadCradle yaml
141141
Nothing -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir
142142

143-
getInitialGhcLibDirDefault :: FilePath -> IO (Maybe LibDir)
144-
getInitialGhcLibDirDefault rootDir = do
143+
getInitialGhcLibDirDefault :: Logger -> FilePath -> IO (Maybe LibDir)
144+
getInitialGhcLibDirDefault logger rootDir = do
145145
hieYaml <- findCradle def rootDir
146146
cradle <- loadCradle def hieYaml rootDir
147-
hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle
147+
logDebug logger $ T.pack $ "setInitialDynFlags cradle: " ++ show cradle
148148
libDirRes <- getRuntimeGhcLibDir cradle
149149
case libDirRes of
150150
CradleSuccess libdir -> pure $ Just $ LibDir libdir
@@ -156,9 +156,9 @@ getInitialGhcLibDirDefault rootDir = do
156156
pure Nothing
157157

158158
-- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir
159-
setInitialDynFlags :: FilePath -> SessionLoadingOptions -> IO (Maybe LibDir)
160-
setInitialDynFlags rootDir SessionLoadingOptions{..} = do
161-
libdir <- getInitialGhcLibDir rootDir
159+
setInitialDynFlags :: Logger -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir)
160+
setInitialDynFlags logger rootDir SessionLoadingOptions{..} = do
161+
libdir <- getInitialGhcLibDir logger rootDir
162162
dynFlags <- mapM dynFlagsForPrinting libdir
163163
mapM_ setUnsafeGlobalDynFlags dynFlags
164164
pure libdir
@@ -167,8 +167,8 @@ setInitialDynFlags rootDir SessionLoadingOptions{..} = do
167167
-- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial
168168
-- by a worker thread using a dedicated database connection.
169169
-- This is done in order to serialize writes to the database, or else SQLite becomes unhappy
170-
runWithDb :: FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO ()
171-
runWithDb fp k = do
170+
runWithDb :: Logger -> FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO ()
171+
runWithDb logger fp k = do
172172
-- Delete the database if it has an incompatible schema version
173173
withHieDb fp (const $ pure ())
174174
`Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp
@@ -186,9 +186,9 @@ runWithDb fp k = do
186186
k <- atomically $ readTQueue chan
187187
k db
188188
`Safe.catch` \e@SQLError{} -> do
189-
hPutStrLn stderr $ "SQLite error in worker, ignoring: " ++ show e
189+
logDebug logger $ T.pack $ "SQLite error in worker, ignoring: " ++ show e
190190
`Safe.catchAny` \e -> do
191-
hPutStrLn stderr $ "Uncaught error in database worker, ignoring: " ++ show e
191+
logDebug logger $ T.pack $ "Uncaught error in database worker, ignoring: " ++ show e
192192

193193

194194
getHieDbLoc :: FilePath -> IO FilePath
@@ -361,7 +361,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
361361
res <- loadDLL hscEnv "libm.so.6"
362362
case res of
363363
Nothing -> pure ()
364-
Just err -> hPutStrLn stderr $
364+
Just err -> logDebug logger $ T.pack $
365365
"Error dynamically loading libm.so.6:\n" <> err
366366

367367
-- Make a map from unit-id to DynFlags, this is used when trying to
@@ -425,7 +425,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
425425
let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))
426426
<> " (for " <> T.pack lfp <> ")"
427427
eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $
428-
cradleToOptsAndLibDir cradle cfp
428+
cradleToOptsAndLibDir logger cradle cfp
429429

430430
logDebug logger $ T.pack ("Session loading result: " <> show eopts)
431431
case eopts of
@@ -495,11 +495,11 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
495495
-- This then builds dependencies or whatever based on the cradle, gets the
496496
-- GHC options/dynflags needed for the session and the GHC library directory
497497

498-
cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath
498+
cradleToOptsAndLibDir :: Show a => Logger -> Cradle a -> FilePath
499499
-> IO (Either [CradleError] (ComponentOptions, FilePath))
500-
cradleToOptsAndLibDir cradle file = do
500+
cradleToOptsAndLibDir logger cradle file = do
501501
-- Start off by getting the session options
502-
hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle
502+
logDebug logger $ T.pack $ "Output from setting up the cradle " <> show cradle
503503
cradleRes <- HieBios.getCompilerOptions file cradle
504504
case cradleRes of
505505
CradleSuccess r -> do

‎ghcide/src/Development/IDE/Core/Compile.hs

Lines changed: 13 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -731,7 +731,11 @@ getModSummaryFromImports env fp modTime contents = do
731731
liftIO $ evaluate $ rnf srcImports
732732
liftIO $ evaluate $ rnf textualImports
733733

734-
modLoc <- liftIO $ mkHomeModLocation dflags mod fp
734+
modLoc <- liftIO $ if mod == mAIN_NAME
735+
-- specially in tests it's common to have lots of nameless modules
736+
-- mkHomeModLocation will map them to the same hi/hie locations
737+
then mkHomeModLocation dflags (pathToModuleName fp) fp
738+
else mkHomeModLocation dflags mod fp
735739

736740
let modl = mkHomeModule (hscHomeUnit (hscSetFlags dflags env)) mod
737741
sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile
@@ -994,3 +998,11 @@ lookupName hsc_env mod name = do
994998
ATcId{tct_id=id} -> return (AnId id)
995999
_ -> panic "tcRnLookupName'"
9961000
return res
1001+
1002+
1003+
pathToModuleName :: FilePath -> ModuleName
1004+
pathToModuleName = mkModuleName . map rep
1005+
where
1006+
rep c | isPathSeparator c = '_'
1007+
rep ':' = '_'
1008+
rep c = c

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

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -141,7 +141,8 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan
141141
T.pack $ "Fatal error in server thread: " <> show e
142142
exitClientMsg
143143
handleServerException _ = pure ()
144-
_ <- flip forkFinally handleServerException $ runWithDb dbLoc $ \hiedb hieChan -> do
144+
logger = ideLogger ide
145+
_ <- flip forkFinally handleServerException $ runWithDb logger dbLoc $ \hiedb hieChan -> do
145146
putMVar dbMVar (hiedb,hieChan)
146147
forever $ do
147148
msg <- readChan clientMsgChan

‎ghcide/src/Development/IDE/Main.hs

Lines changed: 29 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,7 @@ module Development.IDE.Main
66
,isLSP
77
,commandP
88
,defaultMain
9-
) where
9+
,testing) where
1010
import Control.Concurrent.Extra (newLock, readVar,
1111
withLock,
1212
withNumCapabilities)
@@ -55,19 +55,23 @@ import Development.IDE.LSP.LanguageServer (runLanguageServer)
5555
import Development.IDE.Plugin (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules))
5656
import Development.IDE.Plugin.HLS (asGhcIdePlugin)
5757
import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide
58+
import qualified Development.IDE.Plugin.Test as Test
5859
import Development.IDE.Session (SessionLoadingOptions,
5960
getHieDbLoc,
6061
loadSessionWithOptions,
6162
runWithDb,
6263
setInitialDynFlags)
6364
import Development.IDE.Types.Location (NormalizedUri,
6465
toNormalizedFilePath')
65-
import Development.IDE.Types.Logger (Logger (Logger))
66+
import Development.IDE.Types.Logger (Logger (Logger),
67+
logDebug, logInfo)
6668
import Development.IDE.Types.Options (IdeGhcSession,
6769
IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset),
70+
IdeTesting (IdeTesting),
6871
clientSupportsProgress,
6972
defaultIdeOptions,
70-
optModifyDynFlags)
73+
optModifyDynFlags,
74+
optTesting)
7175
import Development.IDE.Types.Shake (Key (Key))
7276
import GHC.Conc (getNumProcessors)
7377
import GHC.IO.Encoding (setLocaleEncoding)
@@ -81,6 +85,7 @@ import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig,
8185
pluginsToVSCodeExtensionSchema)
8286
import Ide.PluginUtils (allLspCmdIds',
8387
getProcessID,
88+
idePluginsToPluginDesc,
8489
pluginDescToIdePlugins)
8590
import Ide.Types (IdeCommand (IdeCommand),
8691
IdePlugins,
@@ -201,6 +206,18 @@ instance Default Arguments where
201206
return newStdout
202207
}
203208

209+
testing :: Arguments
210+
testing = def {
211+
argsHlsPlugins = pluginDescToIdePlugins $
212+
idePluginsToPluginDesc (argsHlsPlugins def)
213+
++ [Test.blockCommandDescriptor "block-command", Test.plugin],
214+
argsIdeOptions = \config sessionLoader ->
215+
let defOptions = argsIdeOptions def config sessionLoader
216+
in defOptions {
217+
optTesting = IdeTesting True
218+
}
219+
}
220+
204221
-- | Cheap stderr logger that relies on LineBuffering
205222
stderrLogger :: IO Logger
206223
stderrLogger = do
@@ -235,20 +252,20 @@ defaultMain Arguments{..} = do
235252
LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins
236253
LSP -> withNumCapabilities (maybe (numProcessors `div` 2) fromIntegral argsThreads) $ do
237254
t <- offsetTime
238-
hPutStrLn stderr "Starting LSP server..."
239-
hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"
255+
logInfo logger "Starting LSP server..."
256+
logInfo logger "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"
240257
runLanguageServer options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do
241258
traverse_ IO.setCurrentDirectory rootPath
242259
t <- t
243-
hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
260+
logInfo logger $ T.pack $ "Started LSP server in " ++ showDuration t
244261

245262
dir <- maybe IO.getCurrentDirectory return rootPath
246263

247264
-- We want to set the global DynFlags right now, so that we can use
248265
-- `unsafeGlobalDynFlags` even before the project is configured
249266
_mlibdir <-
250-
setInitialDynFlags dir argsSessionLoadingOptions
251-
`catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)
267+
setInitialDynFlags logger dir argsSessionLoadingOptions
268+
`catchAny` (\e -> (logDebug logger $ T.pack $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)
252269

253270

254271
sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir
@@ -257,7 +274,7 @@ defaultMain Arguments{..} = do
257274

258275
-- disable runSubset if the client doesn't support watched files
259276
runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported
260-
hPutStrLn stderr $ "runSubset: " <> show runSubset
277+
logDebug logger $ T.pack $ "runSubset: " <> show runSubset
261278

262279
let options = def_options
263280
{ optReportProgress = clientSupportsProgress caps
@@ -283,7 +300,7 @@ defaultMain Arguments{..} = do
283300
Check argFiles -> do
284301
dir <- IO.getCurrentDirectory
285302
dbLoc <- getHieDbLoc dir
286-
runWithDb dbLoc $ \hiedb hieChan -> do
303+
runWithDb logger dbLoc $ \hiedb hieChan -> do
287304
-- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
288305
hSetEncoding stdout utf8
289306
hSetEncoding stderr utf8
@@ -347,14 +364,14 @@ defaultMain Arguments{..} = do
347364
Db dir opts cmd -> do
348365
dbLoc <- getHieDbLoc dir
349366
hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc
350-
mlibdir <- setInitialDynFlags dir def
367+
mlibdir <- setInitialDynFlags logger dir def
351368
case mlibdir of
352369
Nothing -> exitWith $ ExitFailure 1
353370
Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd
354371

355372
Custom projectRoot (IdeCommand c) -> do
356373
dbLoc <- getHieDbLoc projectRoot
357-
runWithDb dbLoc $ \hiedb hieChan -> do
374+
runWithDb logger dbLoc $ \hiedb hieChan -> do
358375
vfs <- makeVFSHandle
359376
sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "."
360377
let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader

‎ghcide/src/Development/IDE/Plugin/Test.hs

Lines changed: 6 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
{-# LANGUAGE DeriveAnyClass #-}
22
{-# LANGUAGE DerivingStrategies #-}
33
{-# LANGUAGE GADTs #-}
4+
{-# LANGUAGE PolyKinds #-}
45
-- | A plugin that adds custom messages for use in tests
56
module Development.IDE.Plugin.Test
67
( TestRequest(..)
@@ -18,7 +19,6 @@ import Data.Aeson
1819
import Data.Aeson.Types
1920
import Data.Bifunctor
2021
import Data.CaseInsensitive (CI, original)
21-
import Data.Default (def)
2222
import Data.Maybe (isJust)
2323
import Data.String
2424
import Data.Text (Text, pack)
@@ -27,8 +27,6 @@ import Development.IDE.Core.Service
2727
import Development.IDE.Core.Shake
2828
import Development.IDE.GHC.Compat
2929
import Development.IDE.Graph (Action)
30-
import Development.IDE.LSP.Server
31-
import qualified Development.IDE.Plugin as P
3230
import Development.IDE.Types.Action
3331
import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv))
3432
import Development.IDE.Types.Location (fromUri)
@@ -50,11 +48,11 @@ data TestRequest
5048
newtype WaitForIdeRuleResult = WaitForIdeRuleResult { ideResultSuccess::Bool}
5149
deriving newtype (FromJSON, ToJSON)
5250

53-
plugin :: P.Plugin c
54-
plugin = def {
55-
P.pluginRules = return (),
56-
P.pluginHandlers = requestHandler (SCustomMethod "test") testRequestHandler'
57-
}
51+
plugin :: PluginDescriptor IdeState
52+
plugin = (defaultPluginDescriptor "test") {
53+
pluginHandlers = mkPluginHandler (SCustomMethod "test") $ \st _ ->
54+
testRequestHandler' st
55+
}
5856
where
5957
testRequestHandler' ide req
6058
| Just customReq <- parseMaybe parseJSON req

‎ghcide/test/exe/Main.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -4627,7 +4627,7 @@ projectCompletionTests =
46274627
<- compls
46284628
, _label == "anidentifier"
46294629
]
4630-
liftIO $ compls' @?= ["Defined in 'A"],
4630+
liftIO $ compls' @?= ["Defined in 'A"],
46314631
testSession' "auto complete project imports" $ \dir-> do
46324632
liftIO $ writeFile (dir </> "hie.yaml")
46334633
"cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}"
@@ -5822,7 +5822,7 @@ unitTests = do
58225822
| i <- [(1::Int)..20]
58235823
] ++ Ghcide.descriptors
58245824

5825-
testIde def{IDE.argsHlsPlugins = plugins} $ do
5825+
testIde IDE.testing{IDE.argsHlsPlugins = plugins} $ do
58265826
_ <- createDoc "haskell" "A.hs" "module A where"
58275827
waitForProgressDone
58285828
actualOrder <- liftIO $ readIORef orderRef

‎hls-plugin-api/src/Ide/PluginUtils.hs

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ module Ide.PluginUtils
1010
diffText,
1111
diffText',
1212
pluginDescToIdePlugins,
13+
idePluginsToPluginDesc,
1314
responseError,
1415
getClientConfig,
1516
getPluginConfig,
@@ -24,7 +25,8 @@ module Ide.PluginUtils
2425
allLspCmdIds',
2526
installSigUsr1Handler,
2627
subRange,
27-
usePropertyLsp)
28+
usePropertyLsp,
29+
)
2830
where
2931

3032

@@ -149,6 +151,8 @@ pluginDescToIdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState
149151
pluginDescToIdePlugins plugins =
150152
IdePlugins $ map (\p -> (pluginId p, p)) $ nubOrdOn pluginId plugins
151153

154+
idePluginsToPluginDesc :: IdePlugins ideState -> [PluginDescriptor ideState]
155+
idePluginsToPluginDesc (IdePlugins pp) = map snd pp
152156

153157
-- ---------------------------------------------------------------------
154158
-- | Returns the current client configuration. It is not wise to permanently

0 commit comments

Comments
 (0)