Avoid reordering plugins (haskell#1629)

* Avoid reordering plugins

Order of execution matters for notification plugins, so lets avoid unnecessary
reorderings

* remove duplicate plugins

* fix tests

ghcide/ghcide.cabal

@@ -315,6 +315,7 @@ test-suite ghcide-tests
         implicit-hie:gen-hie
     build-depends:
         aeson,
+        async,
         base,
         binary,
         bytestring,

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 =

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"

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

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

@@ -37,7 +37,7 @@ import           Language.LSP.Types
 import qualified Language.LSP.Types              as J
 import           Language.LSP.Types.Capabilities
 
-import qualified Data.Map.Strict                 as Map
+import           Data.Containers.ListUtils       (nubOrdOn)
 import           Ide.Plugin.Config
 import           Ide.Plugin.Properties
 import           Language.LSP.Server
@@ -144,7 +144,8 @@ 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)) $ nubOrdOn pluginId plugins
 
 
 -- ---------------------------------------------------------------------
@@ -214,12 +215,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

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)]}
 
 -- ---------------------------------------------------------------------
 

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

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