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

ghcide/exe/Main.hs

@@ -51,7 +51,9 @@ main = do
 
     whenJust argsCwd IO.setCurrentDirectory
 
-    Main.defaultMain def
+    let arguments = if argsTesting then Main.testing else def
+
+    Main.defaultMain arguments
         {Main.argCommand = argsCommand
 
         ,Main.argsRules = do
@@ -62,23 +64,13 @@ main = do
             unless argsDisableKick $
                 action kick
 
-        ,Main.argsHlsPlugins =
-            pluginDescToIdePlugins $
-            GhcIde.descriptors
-            ++ [Test.blockCommandDescriptor "block-command" | argsTesting]
-
-        ,Main.argsGhcidePlugin = if argsTesting
-            then Test.plugin
-            else mempty
-
         ,Main.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i)
 
-        ,Main.argsIdeOptions = \config  sessionLoader ->
-            let defOptions = defaultIdeOptions sessionLoader
+        ,Main.argsIdeOptions = \config sessionLoader ->
+            let defOptions = Main.argsIdeOptions arguments config sessionLoader
             in defOptions
                 { optShakeProfiling = argsShakeProfiling
                 , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
-                , optTesting = IdeTesting argsTesting
                 , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
                 , optCheckParents = pure $ checkParents config
                 , optCheckProject = pure $ checkProject config

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

@@ -102,7 +102,7 @@ data SessionLoadingOptions = SessionLoadingOptions
   --   or 'Nothing' to respect the cradle setting
   , getCacheDirs           :: String -> [String] -> IO CacheDirs
   -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'
-  , getInitialGhcLibDir    :: FilePath -> IO (Maybe LibDir)
+  , getInitialGhcLibDir    :: Logger -> FilePath -> IO (Maybe LibDir)
   , fakeUid                :: UnitId
     -- ^ unit id used to tag the internal component built by ghcide
     --   To reuse external interface files the unit ids must match,
@@ -140,11 +140,11 @@ loadWithImplicitCradle mHieYaml rootDir = do
     Just yaml -> HieBios.loadCradle yaml
     Nothing   -> loadImplicitHieCradle $ addTrailingPathSeparator rootDir
 
-getInitialGhcLibDirDefault :: FilePath -> IO (Maybe LibDir)
-getInitialGhcLibDirDefault rootDir = do
+getInitialGhcLibDirDefault :: Logger -> FilePath -> IO (Maybe LibDir)
+getInitialGhcLibDirDefault logger rootDir = do
   hieYaml <- findCradle def rootDir
   cradle <- loadCradle def hieYaml rootDir
-  hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle
+  logDebug logger $ T.pack $ "setInitialDynFlags cradle: " ++ show cradle
   libDirRes <- getRuntimeGhcLibDir cradle
   case libDirRes of
       CradleSuccess libdir -> pure $ Just $ LibDir libdir
@@ -156,9 +156,9 @@ getInitialGhcLibDirDefault rootDir = do
         pure Nothing
 
 -- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir
-setInitialDynFlags :: FilePath -> SessionLoadingOptions -> IO (Maybe LibDir)
-setInitialDynFlags rootDir SessionLoadingOptions{..} = do
-  libdir <- getInitialGhcLibDir rootDir
+setInitialDynFlags :: Logger -> FilePath -> SessionLoadingOptions -> IO (Maybe LibDir)
+setInitialDynFlags logger rootDir SessionLoadingOptions{..} = do
+  libdir <- getInitialGhcLibDir logger rootDir
   dynFlags <- mapM dynFlagsForPrinting libdir
   mapM_ setUnsafeGlobalDynFlags dynFlags
   pure libdir
@@ -167,8 +167,8 @@ setInitialDynFlags rootDir SessionLoadingOptions{..} = do
 -- writing. Actions are picked off one by one from the `HieWriterChan` and executed in serial
 -- by a worker thread using a dedicated database connection.
 -- This is done in order to serialize writes to the database, or else SQLite becomes unhappy
-runWithDb :: FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO ()
-runWithDb fp k = do
+runWithDb :: Logger -> FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO ()
+runWithDb logger fp k = do
   -- Delete the database if it has an incompatible schema version
   withHieDb fp (const $ pure ())
     `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp
@@ -186,9 +186,9 @@ runWithDb fp k = do
         k <- atomically $ readTQueue chan
         k db
           `Safe.catch` \e@SQLError{} -> do
-            hPutStrLn stderr $ "SQLite error in worker, ignoring: " ++ show e
+            logDebug logger $ T.pack $ "SQLite error in worker, ignoring: " ++ show e
           `Safe.catchAny` \e -> do
-            hPutStrLn stderr $ "Uncaught error in database worker, ignoring: " ++ show e
+            logDebug logger $ T.pack $ "Uncaught error in database worker, ignoring: " ++ show e
 
 
 getHieDbLoc :: FilePath -> IO FilePath
@@ -361,7 +361,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
             res <- loadDLL hscEnv "libm.so.6"
             case res of
               Nothing -> pure ()
-              Just err -> hPutStrLn stderr $
+              Just err -> logDebug logger $ T.pack $
                 "Error dynamically loading libm.so.6:\n" <> err
 
           -- Make a map from unit-id to DynFlags, this is used when trying to
@@ -425,7 +425,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
            let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))
                          <> " (for " <> T.pack lfp <> ")"
            eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $
-              cradleToOptsAndLibDir cradle cfp
+              cradleToOptsAndLibDir logger cradle cfp
 
            logDebug logger $ T.pack ("Session loading result: " <> show eopts)
            case eopts of
@@ -495,11 +495,11 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
 -- This then builds dependencies or whatever based on the cradle, gets the
 -- GHC options/dynflags needed for the session and the GHC library directory
 
-cradleToOptsAndLibDir :: Show a => Cradle a -> FilePath
+cradleToOptsAndLibDir :: Show a => Logger -> Cradle a -> FilePath
                       -> IO (Either [CradleError] (ComponentOptions, FilePath))
-cradleToOptsAndLibDir cradle file = do
+cradleToOptsAndLibDir logger cradle file = do
     -- Start off by getting the session options
-    hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle
+    logDebug logger $ T.pack $ "Output from setting up the cradle " <> show cradle
     cradleRes <- HieBios.getCompilerOptions file cradle
     case cradleRes of
         CradleSuccess r -> do

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

@@ -731,7 +731,11 @@ getModSummaryFromImports env fp modTime contents = do
     liftIO $ evaluate $ rnf srcImports
     liftIO $ evaluate $ rnf textualImports
 
-    modLoc <- liftIO $ mkHomeModLocation dflags mod fp
+    modLoc <- liftIO $ if mod == mAIN_NAME
+        -- specially in tests it's common to have lots of nameless modules
+        -- mkHomeModLocation will map them to the same hi/hie locations
+        then mkHomeModLocation dflags (pathToModuleName fp) fp
+        else mkHomeModLocation dflags mod fp
 
     let modl = mkHomeModule (hscHomeUnit (hscSetFlags dflags env)) mod
         sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile
@@ -994,3 +998,11 @@ lookupName hsc_env mod name = do
             ATcId{tct_id=id} -> return (AnId id)
             _                -> panic "tcRnLookupName'"
     return res
+
+
+pathToModuleName :: FilePath -> ModuleName
+pathToModuleName = mkModuleName . map rep
+  where
+      rep c | isPathSeparator c = '_'
+      rep ':' = '_'
+      rep c = c

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

@@ -141,7 +141,8 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan
                         T.pack $ "Fatal error in server thread: " <> show e
                     exitClientMsg
                 handleServerException _ = pure ()
-            _ <- flip forkFinally handleServerException $ runWithDb dbLoc $ \hiedb hieChan -> do
+                logger = ideLogger ide
+            _ <- flip forkFinally handleServerException $ runWithDb logger dbLoc $ \hiedb hieChan -> do
               putMVar dbMVar (hiedb,hieChan)
               forever $ do
                 msg <- readChan clientMsgChan

ghcide/src/Development/IDE/Main.hs

@@ -6,7 +6,7 @@ module Development.IDE.Main
 ,isLSP
 ,commandP
 ,defaultMain
-) where
+,testing) where
 import           Control.Concurrent.Extra              (newLock, readVar,
                                                         withLock,
                                                         withNumCapabilities)
@@ -55,19 +55,23 @@ import           Development.IDE.LSP.LanguageServer    (runLanguageServer)
 import           Development.IDE.Plugin                (Plugin (pluginHandlers, pluginModifyDynflags, pluginRules))
 import           Development.IDE.Plugin.HLS            (asGhcIdePlugin)
 import qualified Development.IDE.Plugin.HLS.GhcIde     as Ghcide
+import qualified Development.IDE.Plugin.Test           as Test
 import           Development.IDE.Session               (SessionLoadingOptions,
                                                         getHieDbLoc,
                                                         loadSessionWithOptions,
                                                         runWithDb,
                                                         setInitialDynFlags)
 import           Development.IDE.Types.Location        (NormalizedUri,
                                                         toNormalizedFilePath')
-import           Development.IDE.Types.Logger          (Logger (Logger))
+import           Development.IDE.Types.Logger          (Logger (Logger),
+                                                        logDebug, logInfo)
 import           Development.IDE.Types.Options         (IdeGhcSession,
                                                         IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset),
+                                                        IdeTesting (IdeTesting),
                                                         clientSupportsProgress,
                                                         defaultIdeOptions,
-                                                        optModifyDynFlags)
+                                                        optModifyDynFlags,
+                                                        optTesting)
 import           Development.IDE.Types.Shake           (Key (Key))
 import           GHC.Conc                              (getNumProcessors)
 import           GHC.IO.Encoding                       (setLocaleEncoding)
@@ -81,6 +85,7 @@ import           Ide.Plugin.ConfigUtils                (pluginsToDefaultConfig,
                                                         pluginsToVSCodeExtensionSchema)
 import           Ide.PluginUtils                       (allLspCmdIds',
                                                         getProcessID,
+                                                        idePluginsToPluginDesc,
                                                         pluginDescToIdePlugins)
 import           Ide.Types                             (IdeCommand (IdeCommand),
                                                         IdePlugins,
@@ -201,6 +206,18 @@ instance Default Arguments where
                 return newStdout
         }
 
+testing :: Arguments
+testing = def {
+    argsHlsPlugins = pluginDescToIdePlugins $
+        idePluginsToPluginDesc (argsHlsPlugins def)
+        ++ [Test.blockCommandDescriptor "block-command", Test.plugin],
+    argsIdeOptions = \config sessionLoader ->
+            let defOptions = argsIdeOptions def config sessionLoader
+            in defOptions {
+                optTesting = IdeTesting True
+            }
+}
+
 -- | Cheap stderr logger that relies on LineBuffering
 stderrLogger :: IO Logger
 stderrLogger = do
@@ -235,20 +252,20 @@ defaultMain Arguments{..} = do
             LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins
         LSP -> withNumCapabilities (maybe (numProcessors `div` 2) fromIntegral argsThreads) $ do
             t <- offsetTime
-            hPutStrLn stderr "Starting LSP server..."
-            hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"
+            logInfo logger "Starting LSP server..."
+            logInfo logger "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"
             runLanguageServer options inH outH argsGetHieDbLoc argsDefaultHlsConfig argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do
                 traverse_ IO.setCurrentDirectory rootPath
                 t <- t
-                hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
+                logInfo logger $ T.pack $ "Started LSP server in " ++ showDuration 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 dir argsSessionLoadingOptions
-                        `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)
+                    setInitialDynFlags logger dir argsSessionLoadingOptions
+                        `catchAny` (\e -> (logDebug logger $ T.pack $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)
 
 
                 sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir
@@ -257,7 +274,7 @@ defaultMain Arguments{..} = do
 
                 -- disable runSubset if the client doesn't support watched files
                 runSubset <- (optRunSubset def_options &&) <$> LSP.runLspT env isWatchSupported
-                hPutStrLn stderr $ "runSubset: " <> show runSubset
+                logDebug logger $ T.pack $ "runSubset: " <> show runSubset
 
                 let options = def_options
                             { optReportProgress = clientSupportsProgress caps
@@ -283,7 +300,7 @@ defaultMain Arguments{..} = do
         Check argFiles -> do
           dir <- IO.getCurrentDirectory
           dbLoc <- getHieDbLoc dir
-          runWithDb dbLoc $ \hiedb hieChan -> do
+          runWithDb logger dbLoc $ \hiedb hieChan -> do
             -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
             hSetEncoding stdout utf8
             hSetEncoding stderr utf8
@@ -347,14 +364,14 @@ defaultMain Arguments{..} = do
         Db dir opts cmd -> do
             dbLoc <- getHieDbLoc dir
             hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc
-            mlibdir <- setInitialDynFlags dir def
+            mlibdir <- setInitialDynFlags logger dir def
             case mlibdir of
                 Nothing     -> exitWith $ ExitFailure 1
                 Just libdir -> HieDb.runCommand libdir opts{HieDb.database = dbLoc} cmd
 
         Custom projectRoot (IdeCommand c) -> do
           dbLoc <- getHieDbLoc projectRoot
-          runWithDb dbLoc $ \hiedb hieChan -> do
+          runWithDb logger dbLoc $ \hiedb hieChan -> do
             vfs <- makeVFSHandle
             sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions "."
             let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveAnyClass     #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GADTs              #-}
+{-# LANGUAGE PolyKinds          #-}
 -- | A plugin that adds custom messages for use in tests
 module Development.IDE.Plugin.Test
   ( TestRequest(..)
@@ -18,7 +19,6 @@ import           Data.Aeson
 import           Data.Aeson.Types
 import           Data.Bifunctor
 import           Data.CaseInsensitive           (CI, original)
-import           Data.Default                   (def)
 import           Data.Maybe                     (isJust)
 import           Data.String
 import           Data.Text                      (Text, pack)
@@ -27,8 +27,6 @@ import           Development.IDE.Core.Service
 import           Development.IDE.Core.Shake
 import           Development.IDE.GHC.Compat
 import           Development.IDE.Graph          (Action)
-import           Development.IDE.LSP.Server
-import qualified Development.IDE.Plugin         as P
 import           Development.IDE.Types.Action
 import           Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv))
 import           Development.IDE.Types.Location (fromUri)
@@ -50,11 +48,11 @@ data TestRequest
 newtype WaitForIdeRuleResult = WaitForIdeRuleResult { ideResultSuccess::Bool}
     deriving newtype (FromJSON, ToJSON)
 
-plugin :: P.Plugin c
-plugin = def {
-    P.pluginRules = return (),
-    P.pluginHandlers = requestHandler (SCustomMethod "test") testRequestHandler'
-}
+plugin :: PluginDescriptor IdeState
+plugin = (defaultPluginDescriptor "test") {
+    pluginHandlers = mkPluginHandler (SCustomMethod "test") $ \st _ ->
+        testRequestHandler' st
+    }
   where
       testRequestHandler' ide req
         | Just customReq <- parseMaybe parseJSON req

ghcide/test/exe/Main.hs

@@ -4627,7 +4627,7 @@ projectCompletionTests =
                 <- compls
               , _label == "anidentifier"
               ]
-        liftIO $ compls' @?= ["Defined in 'A"], 
+        liftIO $ compls' @?= ["Defined in 'A"],
       testSession' "auto complete project imports" $ \dir-> do
         liftIO $ writeFile (dir </> "hie.yaml")
             "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}"
@@ -5822,7 +5822,7 @@ unitTests = do
                     | i <- [(1::Int)..20]
                 ] ++ Ghcide.descriptors
 
-        testIde def{IDE.argsHlsPlugins = plugins} $ do
+        testIde IDE.testing{IDE.argsHlsPlugins = plugins} $ do
             _ <- createDoc "haskell" "A.hs" "module A where"
             waitForProgressDone
             actualOrder <- liftIO $ readIORef orderRef

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

@@ -10,6 +10,7 @@ module Ide.PluginUtils
     diffText,
     diffText',
     pluginDescToIdePlugins,
+    idePluginsToPluginDesc,
     responseError,
     getClientConfig,
     getPluginConfig,
@@ -24,7 +25,8 @@ module Ide.PluginUtils
     allLspCmdIds',
     installSigUsr1Handler,
     subRange,
-    usePropertyLsp)
+    usePropertyLsp,
+    )
 where
 
 
@@ -149,6 +151,8 @@ pluginDescToIdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState
 pluginDescToIdePlugins plugins =
     IdePlugins $ map (\p -> (pluginId p, p)) $ nubOrdOn pluginId plugins
 
+idePluginsToPluginDesc :: IdePlugins ideState -> [PluginDescriptor ideState]
+idePluginsToPluginDesc (IdePlugins pp) = map snd pp
 
 -- ---------------------------------------------------------------------
 -- | Returns the current client configuration. It is not wise to permanently