diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 49cc071dbe..0698fbe98d 100644 --- a/ghcide/exe/Main.hs +++ b/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 diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index c2a190e486..a0af4d235a 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index ce889fb7ba..b90eea94b4 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 6118805885..e0467c5114 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 4a9b81cfb0..b755969ada 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/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,6 +55,7 @@ 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, @@ -62,12 +63,15 @@ import Development.IDE.Session (SessionLoadingOptions, 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 diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 7a1a9469ac..9c3f37c13a 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/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 diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index f1599baf25..0f7e78fa28 100644 --- a/ghcide/test/exe/Main.hs +++ b/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 diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index bf65f5f513..66d6f30144 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/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 diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index c83d2c6e89..7cf6d3b882 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -46,7 +46,10 @@ import GHC.Generics import Ide.Plugin.Config import Ide.Plugin.Properties import Language.LSP.Server (LspM, getVirtualFile) -import Language.LSP.Types hiding (SemanticTokenAbsolute(length, line), SemanticTokenRelative(length), SemanticTokensEdit(_start)) +import Language.LSP.Types hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start)) import Language.LSP.Types.Capabilities (ClientCapabilities (ClientCapabilities), TextDocumentClientCapabilities (_codeAction, _documentSymbol)) import Language.LSP.Types.Lens as J (HasChildren (children), @@ -285,6 +288,10 @@ instance PluginMethod CallHierarchyIncomingCalls where instance PluginMethod CallHierarchyOutgoingCalls where pluginEnabled _ = pluginEnabledConfig plcCallHierarchyOn +instance PluginMethod CustomMethod where + pluginEnabled _ _ _ = True + combineResponses _ _ _ _ (x :| _) = x + -- --------------------------------------------------------------------- -- | Methods which have a PluginMethod instance @@ -488,8 +495,6 @@ instance HasTracing CallHierarchyOutgoingCallsParams -- --------------------------------------------------------------------- {-# NOINLINE pROCESS_ID #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} pROCESS_ID :: T.Text pROCESS_ID = unsafePerformIO getPid diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index a0b0134bee..512ae1b744 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -1,6 +1,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty, @@ -23,48 +25,47 @@ module Test.Hls PluginDescriptor, IdeState, waitForBuildQueue - ) + ,waitForTypecheck,waitForAction) where import Control.Applicative.Combinators -import Control.Concurrent.Async (async, cancel, wait) +import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Extra import Control.Exception.Base -import Control.Monad (unless) +import Control.Monad (unless, void) import Control.Monad.IO.Class -import Data.Aeson (Value (Null), toJSON) -import Data.ByteString.Lazy (ByteString) -import Data.Default (def) -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, hDuplicateTo', - noLogging) -import Development.IDE.Graph (ShakeOptions (shakeThreads)) +import Data.Aeson (Value (Null), toJSON) +import qualified Data.Aeson as A +import Data.ByteString.Lazy (ByteString) +import Data.Default (def) +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, noLogging) +import Development.IDE.Graph (ShakeOptions (shakeThreads)) import Development.IDE.Main -import qualified Development.IDE.Main as Ghcide -import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide -import Development.IDE.Plugin.Test (TestRequest (WaitForShakeQueue)) +import qualified Development.IDE.Main as Ghcide +import Development.IDE.Plugin.Test (TestRequest (WaitForIdeRule, WaitForShakeQueue), + WaitForIdeRuleResult (ideResultSuccess)) import Development.IDE.Types.Options import GHC.IO.Handle -import Ide.Plugin.Config (Config, formattingProvider) -import Ide.PluginUtils (pluginDescToIdePlugins) +import Ide.Plugin.Config (Config, formattingProvider) +import Ide.PluginUtils (idePluginsToPluginDesc, pluginDescToIdePlugins) import Ide.Types import Language.LSP.Test -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import Language.LSP.Types.Capabilities (ClientCapabilities) -import System.Directory (getCurrentDirectory, - setCurrentDirectory) +import Language.LSP.Types hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start)) +import Language.LSP.Types.Capabilities (ClientCapabilities) +import System.Directory (getCurrentDirectory, + setCurrentDirectory) import System.FilePath -import System.IO.Extra -import System.IO.Unsafe (unsafePerformIO) -import System.Process.Extra (createPipe) +import System.IO.Unsafe (unsafePerformIO) +import System.Process.Extra (createPipe) import System.Time.Extra import Test.Hls.Util -import Test.Tasty hiding (Timeout) +import Test.Tasty hiding (Timeout) import Test.Tasty.ExpectedFailure import Test.Tasty.Golden import Test.Tasty.HUnit @@ -95,6 +96,7 @@ goldenWithHaskellDoc plugin title testDataDir path desc ext act = $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "haskell" + void waitForBuildQueue act doc documentContents doc @@ -114,6 +116,7 @@ goldenWithHaskellDocFormatter plugin formatter title testDataDir path desc ext a $ TL.encodeUtf8 . TL.fromStrict <$> do doc <- openDoc (path <.> ext) "haskell" + void waitForBuildQueue act doc documentContents doc @@ -128,18 +131,6 @@ runSessionWithServerFormatter plugin formatter = def fullCaps --- | Run an action, with stderr silenced -silenceStderr :: IO a -> IO a -silenceStderr action = withTempFile $ \temp -> - bracket (openFile temp ReadWriteMode) hClose $ \h -> do - old <- hDuplicate stderr - buf <- hGetBuffering stderr - h `hDuplicateTo'` stderr - action `finally` do - old `hDuplicateTo'` stderr - hSetBuffering stderr buf - hClose old - -- | Restore cwd after running an action keepCurrentDirectory :: IO a -> IO a keepCurrentDirectory = bracket getCurrentDirectory setCurrentDirectory . const @@ -162,13 +153,13 @@ runSessionWithServer' :: FilePath -> Session a -> IO a -runSessionWithServer' plugin conf sconf caps root s = withLock lock $ keepCurrentDirectory $ silenceStderr $ do +runSessionWithServer' plugin conf sconf caps root s = withLock lock $ keepCurrentDirectory $ do (inR, inW) <- createPipe (outR, outW) <- createPipe server <- async $ Ghcide.defaultMain - def + testing { argsHandleIn = pure inR, argsHandleOut = pure outW, argsDefaultHlsConfig = conf, @@ -176,7 +167,7 @@ runSessionWithServer' plugin conf sconf caps root s = withLock lock $ keepCurren argsIdeOptions = \config sessionLoader -> let ideOptions = (argsIdeOptions def config sessionLoader) {optTesting = IdeTesting True} in ideOptions {optShakeOptions = (optShakeOptions ideOptions) {shakeThreads = 2}}, - argsHlsPlugins = pluginDescToIdePlugins $ plugin ++ Ghcide.descriptors + argsHlsPlugins = pluginDescToIdePlugins $ plugin ++ idePluginsToPluginDesc (argsHlsPlugins testing) } x <- runSessionWithHandles inW outR sconf caps root s hClose inW @@ -222,3 +213,17 @@ waitForBuildQueue = do ResponseMessage{_result=Right Null} -> return td -- assume a ghcide binary lacking the WaitForShakeQueue method _ -> return 0 + +waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) +waitForAction key TextDocumentIdentifier{_uri} = do + let cm = SCustomMethod "test" + waitId <- sendRequest cm (A.toJSON $ WaitForIdeRule key _uri) + ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId + return $ do + e <- _result + case A.fromJSON e of + A.Error e -> Left $ ResponseError InternalError (T.pack e) Nothing + A.Success a -> pure a + +waitForTypecheck :: TextDocumentIdentifier -> Session (Either ResponseError Bool) +waitForTypecheck tid = fmap ideResultSuccess <$> waitForAction "typecheck" tid diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index c12640dc91..23c187846c 100644 --- a/plugins/hls-splice-plugin/test/Main.hs +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -65,6 +65,9 @@ goldenTest :: FilePath -> ExpandStyle -> Int -> Int -> TestTree goldenTest fp tc line col = goldenWithHaskellDoc splicePlugin (fp <> " (golden)") testDataDir fp "expected" "hs" $ \doc -> do _ <- waitForDiagnostics + -- wait for the entire build to finish, so that code actions that + -- use stale data will get uptodate stuff + void waitForBuildQueue actions <- getCodeActions doc $ pointRange line col case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of Just (InR CodeAction {_command = Just c}) -> do @@ -89,6 +92,8 @@ goldenTestWithEdit fp tc line col = void $ applyEdit doc $ TextEdit theRange alt changeDoc doc [TextDocumentContentChangeEvent (Just theRange) Nothing alt] void waitForDiagnostics + -- wait for the entire build to finish + void waitForBuildQueue actions <- getCodeActions doc $ pointRange line col case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of Just (InR CodeAction {_command = Just c}) -> do diff --git a/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/TacticActions.hs b/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/TacticActions.hs index c993f60a6c..01ddfe4fe1 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/TacticActions.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/TacticActions.hs @@ -25,6 +25,8 @@ import Wingman.LanguageServer.TacticProviders import Wingman.Machinery (runTactic, scoreSolution) import Wingman.Range import Wingman.Types +import Development.IDE.Core.Service (getIdeOptionsIO) +import Development.IDE.Types.Options (IdeTesting(IdeTesting), IdeOptions (IdeOptions, optTesting)) ------------------------------------------------------------------------------ @@ -34,7 +36,7 @@ makeTacticInteraction -> Interaction makeTacticInteraction cmd = Interaction $ Continuation @_ @HoleTarget cmd - (SynthesizeCodeAction $ \env@LspEnv{..} hj -> do + (SynthesizeCodeAction $ \env hj -> do pure $ commandProvider cmd $ TacticProviderData { tpd_lspEnv = env @@ -48,9 +50,13 @@ makeTacticInteraction cmd = let span = fmap (rangeToRealSrcSpan (fromNormalizedFilePath fc_nfp)) hj_range TrackedStale _ pmmap <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource pm_span <- liftMaybe $ mapAgeFrom pmmap span + IdeOptions{optTesting = IdeTesting isTesting} <- + liftIO $ getIdeOptionsIO (shakeExtras le_ideState) + let t = commandTactic cmd var_name + timeout = if isTesting then maxBound else cfg_timeout_seconds le_config * seconds - liftIO $ runTactic (cfg_timeout_seconds le_config * seconds) hj_ctx hj_jdg t >>= \case + liftIO $ runTactic timeout hj_ctx hj_jdg t >>= \case Left err -> pure $ pure diff --git a/plugins/hls-tactics-plugin/src/Wingman/Debug.hs b/plugins/hls-tactics-plugin/src/Wingman/Debug.hs index 1c5e0f5517..5dcdee57c0 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Debug.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Debug.hs @@ -1,7 +1,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeApplications #-} - +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} module Wingman.Debug ( unsafeRender , unsafeRender' @@ -16,7 +17,7 @@ module Wingman.Debug import Control.DeepSeq import Control.Exception -import Debug.Trace +import qualified Debug.Trace import Development.IDE.GHC.Compat (PlainGhcException, Outputable(..), SDoc, showSDocUnsafe) import System.IO.Unsafe (unsafePerformIO) @@ -47,3 +48,15 @@ traceIdX str a = trace (mappend ("!!!" <> str <> ": ") $ show a) a traceFX :: String -> (a -> String) -> a -> a traceFX str f a = trace (mappend ("!!!" <> str <> ": ") $ f a) a +traceM :: Applicative f => String -> f () +trace :: String -> a -> a +traceShowId :: Show a => a -> a +#ifdef DEBUG +traceM = Debug.Trace.traceM +trace = Debug.Trace.trace +traceShowId = Debug.Trace.traceShowId +#else +traceM _ = pure () +trace _ = id +traceShowId = id +#endif diff --git a/plugins/hls-tactics-plugin/test/Utils.hs b/plugins/hls-tactics-plugin/test/Utils.hs index ec1eba5893..547007e09c 100644 --- a/plugins/hls-tactics-plugin/test/Utils.hs +++ b/plugins/hls-tactics-plugin/test/Utils.hs @@ -84,8 +84,11 @@ mkTest name fp line col ts = it name $ do resetGlobalHoleRef runSessionForTactics $ do doc <- openDoc (fp <.> "hs") "haskell" - _ <- waitForDiagnostics - waitForAllProgressDone + -- wait for diagnostics to start coming + void waitForDiagnostics + -- wait for the entire build to finish, so that Tactics code actions that + -- use stale data will get uptodate stuff + void $ waitForTypecheck doc actions <- getCodeActions doc $ pointRange line col let titles = mapMaybe codeActionTitle actions for_ ts $ \(f, tc, var) -> do @@ -109,10 +112,10 @@ mkGoldenTest eq tc occ line col input = runSessionForTactics $ do doc <- openDoc (input <.> "hs") "haskell" -- wait for diagnostics to start coming - _ <- waitForDiagnostics + void waitForDiagnostics -- wait for the entire build to finish, so that Tactics code actions that -- use stale data will get uptodate stuff - void waitForBuildQueue + void $ waitForTypecheck doc actions <- getCodeActions doc $ pointRange line col case find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions of Just (InR CodeAction {_command = Just c}) -> do @@ -127,7 +130,6 @@ mkGoldenTest eq tc occ line col input = liftIO $ edited `eq` expected _ -> error $ show actions - mkCodeLensTest :: FilePath -> SpecWith ()