From 70244e153b3f8fd3aae8f9a6e2e977d7e66c6f91 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 27 Mar 2021 17:24:11 +0000 Subject: [PATCH 1/3] Avoid reordering plugins Order of execution matters for notification plugins, so lets avoid unnecessary reorderings --- ghcide/ghcide.cabal | 1 + ghcide/src/Development/IDE/Plugin/HLS.hs | 3 +- ghcide/test/exe/Main.hs | 63 +++++++++++++++++--- hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs | 5 +- hls-plugin-api/src/Ide/PluginUtils.hs | 6 +- hls-plugin-api/src/Ide/Types.hs | 2 +- src/Ide/Main.hs | 3 +- 7 files changed, 62 insertions(+), 21 deletions(-) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index e61b07aa88..3086f0b422 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -315,6 +315,7 @@ test-suite ghcide-tests implicit-hie:gen-hie build-depends: aeson, + async, base, binary, bytestring, diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 66d611ea14..e17656203d 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -44,13 +44,12 @@ import UnliftIO.Exception (catchAny) -- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config -asGhcIdePlugin mp = +asGhcIdePlugin (IdePlugins ls) = mkPlugin rulesPlugins HLS.pluginRules <> mkPlugin executeCommandPlugins HLS.pluginCommands <> mkPlugin extensiblePlugins HLS.pluginHandlers <> mkPlugin extensibleNotificationPlugins HLS.pluginNotificationHandlers where - ls = Map.toList (ipMap mp) mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config mkPlugin maker selector = diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 28081dbb65..7089247fd6 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -36,6 +36,7 @@ import Development.IDE.Core.PositionMapping (PositionResult (..), positionResultToMaybe, toCurrent) import Development.IDE.Core.Shake (Q (..)) +import Development.IDE.Main as IDE import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types (extendImportCommandId) import Development.IDE.Plugin.TypeLenses (typeLensCommandId) @@ -75,7 +76,7 @@ import qualified System.IO.Extra import System.Info.Extra (isWindows) import System.Process.Extra (CreateProcess (cwd), proc, - readCreateProcessWithExitCode) + readCreateProcessWithExitCode, createPipe) import Test.QuickCheck -- import Test.QuickCheck.Instances () import Control.Lens ((^.)) @@ -92,6 +93,14 @@ import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit import Test.Tasty.Ingredients.Rerun import Test.Tasty.QuickCheck +import Data.IORef +import Ide.PluginUtils (pluginDescToIdePlugins) +import Control.Concurrent.Async +import Ide.Types +import Data.String (IsString(fromString)) +import qualified Language.LSP.Types as LSP +import Data.IORef.Extra (atomicModifyIORef_) +import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case @@ -179,7 +188,7 @@ initializeResponseTests = withResource acquire release tests where , chk "NO doc link" _documentLinkProvider Nothing , chk "NO color" _colorProvider (Just $ InL False) , chk "NO folding range" _foldingRangeProvider (Just $ InL False) - , che " execute command" _executeCommandProvider [blockCommandId, extendImportCommandId, typeLensCommandId] + , che " execute command" _executeCommandProvider [extendImportCommandId, typeLensCommandId, blockCommandId] , chk " workspace" _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) , chk "NO experimental" _experimental Nothing ] where @@ -5145,21 +5154,26 @@ runInDir' dir startExeIn startSessionIn extraOptions s = do -- HIE calls getXgdDirectory which assumes that HOME is set. -- Only sets HOME if it wasn't already set. setEnv "HOME" "/homeless-shelter" False - let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True } + conf <- getConfigFromEnv + runSessionWithConfig conf cmd lspTestCaps projDir s + +getConfigFromEnv :: IO SessionConfig +getConfigFromEnv = do logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR" timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT" - let conf = defaultConfig{messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride} - -- uncomment this or set LSP_TEST_LOG_STDERR=1 to see all logging - -- { logStdErr = True } - -- uncomment this or set LSP_TEST_LOG_MESSAGES=1 to see all messages - -- { logMessages = True } - runSessionWithConfig conf{logColor} cmd lspTestCaps projDir s + return defaultConfig + { messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride + , logColor + } where checkEnv :: String -> IO (Maybe Bool) checkEnv s = fmap convertVal <$> getEnv s convertVal "0" = False convertVal _ = True +lspTestCaps :: ClientCapabilities +lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True } + openTestDataDoc :: FilePath -> Session TextDocumentIdentifier openTestDataDoc path = do source <- liftIO $ readFileUtf8 $ "test/data" path @@ -5227,8 +5241,39 @@ unitTests = do let expected = "1:2-3:4" assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $ expected `isInfixOf` shown + , testCase "notification handlers run sequentially" $ do + orderRef <- newIORef [] + let plugins = pluginDescToIdePlugins $ + [ (defaultPluginDescriptor $ fromString $ show i) + { pluginNotificationHandlers = mconcat + [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \_ _ _ -> + liftIO $ atomicModifyIORef_ orderRef (i:) + ] + } + | i <- [(1::Int)..20] + ] ++ Ghcide.descriptors + + testIde def{argsHlsPlugins = plugins} $ do + _ <- createDoc "haskell" "A.hs" "module A where" + waitForProgressDone + actualOrder <- liftIO $ readIORef orderRef + + liftIO $ actualOrder @?= reverse [(1::Int)..20] ] +testIde :: Arguments -> Session () -> IO () +testIde arguments session = do + config <- getConfigFromEnv + (hInRead, hInWrite) <- createPipe + (hOutRead, hOutWrite) <- createPipe + let server = IDE.defaultMain arguments + { argsHandleIn = pure hInRead + , argsHandleOut = pure hOutWrite + } + + withAsync server $ \_ -> + runSessionWithHandles hInWrite hOutRead config lspTestCaps "." session + positionMappingTests :: TestTree positionMappingTests = testGroup "position mapping" diff --git a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs index fad0fe7ed9..4badc44d43 100644 --- a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs +++ b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs @@ -11,7 +11,6 @@ import Data.Default (def) import qualified Data.Dependent.Map as DMap import qualified Data.Dependent.Sum as DSum import qualified Data.HashMap.Lazy as HMap -import qualified Data.Map as Map import Ide.Plugin.Config import Ide.Plugin.Properties (toDefaultJSON, toVSCodeExtensionSchema) import Ide.Types @@ -36,7 +35,7 @@ pluginsToDefaultConfig IdePlugins {..} = defaultConfig@Config {} = def unsafeValueToObject (A.Object o) = o unsafeValueToObject _ = error "impossible" - elems = A.object $ mconcat $ singlePlugin <$> Map.elems ipMap + elems = A.object $ mconcat $ singlePlugin <$> map snd ipMap -- Splice genericDefaultConfig and dedicatedDefaultConfig -- Example: -- @@ -100,7 +99,7 @@ pluginsToDefaultConfig IdePlugins {..} = -- | Generates json schema used in haskell vscode extension -- Similar to 'pluginsToDefaultConfig' but simpler, since schema has a flatten structure pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value -pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> Map.elems ipMap +pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> map snd ipMap where singlePlugin PluginDescriptor {..} = genericSchema <> dedicatedSchema where diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 896256df40..1c49e78eb1 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -37,7 +37,6 @@ import Language.LSP.Types import qualified Language.LSP.Types as J import Language.LSP.Types.Capabilities -import qualified Data.Map.Strict as Map import Ide.Plugin.Config import Ide.Plugin.Properties import Language.LSP.Server @@ -144,7 +143,7 @@ clientSupportsDocumentChanges caps = -- --------------------------------------------------------------------- pluginDescToIdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState -pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins +pluginDescToIdePlugins plugins = IdePlugins $ map (\p -> (pluginId p, p)) plugins -- --------------------------------------------------------------------- @@ -214,12 +213,11 @@ positionInRange (Position pl po) (Range (Position sl so) (Position el eo)) = -- --------------------------------------------------------------------- allLspCmdIds' :: T.Text -> IdePlugins ideState -> [T.Text] -allLspCmdIds' pid mp = mkPlugin (allLspCmdIds pid) (Just . pluginCommands) +allLspCmdIds' pid (IdePlugins ls) = mkPlugin (allLspCmdIds pid) (Just . pluginCommands) where justs (p, Just x) = [(p, x)] justs (_, Nothing) = [] - ls = Map.toList (ipMap mp) mkPlugin maker selector = maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 1983b6025d..3ccc4145b7 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -54,7 +54,7 @@ import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- newtype IdePlugins ideState = IdePlugins - { ipMap :: Map.Map PluginId (PluginDescriptor ideState)} + { ipMap :: [(PluginId, PluginDescriptor ideState)]} -- --------------------------------------------------------------------- diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index 3d496a1354..d662cced3b 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -13,7 +13,6 @@ import Control.Monad.Extra import qualified Data.Aeson.Encode.Pretty as A import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Default -import qualified Data.Map.Strict as Map import qualified Data.Text as T import Development.IDE.Core.Rules import qualified Development.IDE.Main as Main @@ -97,7 +96,7 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do when argLSP $ do hPutStrLn stderr "Starting (haskell-language-server)LSP server..." hPutStrLn stderr $ " with arguments: " <> show lspArgs - hPutStrLn stderr $ " with plugins: " <> show (Map.keys $ ipMap idePlugins) + hPutStrLn stderr $ " with plugins: " <> show (map fst $ ipMap idePlugins) hPutStrLn stderr $ " in directory: " <> dir hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" From 206628c04fffc024e5a63379665c7be80ddf6485 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 28 Mar 2021 19:10:48 +0100 Subject: [PATCH 2/3] remove duplicate plugins --- hls-plugin-api/src/Ide/PluginUtils.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 1c49e78eb1..384735e191 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -37,6 +37,7 @@ import Language.LSP.Types import qualified Language.LSP.Types as J import Language.LSP.Types.Capabilities +import Data.Containers.ListUtils (nubOrdOn) import Ide.Plugin.Config import Ide.Plugin.Properties import Language.LSP.Server @@ -143,7 +144,8 @@ clientSupportsDocumentChanges caps = -- --------------------------------------------------------------------- pluginDescToIdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState -pluginDescToIdePlugins plugins = IdePlugins $ map (\p -> (pluginId p, p)) plugins +pluginDescToIdePlugins plugins = + IdePlugins $ map (\p -> (pluginId p, p)) $ nubOrdOn pluginId plugins -- --------------------------------------------------------------------- From 9c443345d2e0c761f7caeb00209a03b55853ba6d Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 28 Mar 2021 20:59:02 +0100 Subject: [PATCH 3/3] fix tests --- test/functional/FunctionalCodeAction.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index 6e706973dd..6a531113f2 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -372,7 +372,8 @@ redundantImportTests = testGroup "redundant import code actions" [ , testCase "doesn't touch other imports" $ runSession hlsCommand noLiteralCaps "test/testdata/redundantImportTest/" $ do doc <- openDoc "src/MultipleImports.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" - InL cmd : _ <- getAllCodeActions doc + cas <- getAllCodeActions doc + cmd <- liftIO $ inspectCommand cas ["redundant import"] executeCommand cmd _ <- anyRequest contents <- documentContents doc @@ -439,11 +440,12 @@ signatureTests = testGroup "missing top level signature code actions" [ doc <- openDoc "TopLevelSignature.hs" "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" - cas <- map fromAction <$> getAllCodeActions doc + cas <- getAllCodeActions doc - liftIO $ "add signature: main :: IO ()" `elem` map (^. L.title) cas @? "Contains code action" + liftIO $ expectCodeAction cas ["add signature: main :: IO ()"] - executeCodeAction $ head cas + replaceWithStuff <- liftIO $ inspectCodeAction cas ["add signature"] + executeCodeAction replaceWithStuff contents <- documentContents doc