Deduplicate HLS plugins

exe/Plugins.hs

@@ -211,12 +211,8 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
 #if hls_gadt
       GADT.descriptor "gadt" :
 #endif
-    -- The ghcide descriptors should come last so that the notification handlers
-    -- (which restart the Shake build) run after everything else
       GhcIde.descriptors pluginRecorder
 #if explicitFixity
-    -- Make this plugin has a lower priority than ghcide's plugin to ensure
-    -- type info display first.
       ++ [ExplicitFixity.descriptor pluginRecorder]
 #endif
     examplePlugins =

ghcide/ghcide.cabal

@@ -192,6 +192,7 @@ library
         Development.IDE.Monitoring.EKG
         Development.IDE.LSP.HoverDefinition
         Development.IDE.LSP.LanguageServer
+        Development.IDE.LSP.Notifications
         Development.IDE.LSP.Outline
         Development.IDE.LSP.Server
         Development.IDE.Session
@@ -225,7 +226,6 @@ library
         Development.IDE.Core.FileExists
         Development.IDE.GHC.CPP
         Development.IDE.GHC.Warnings
-        Development.IDE.LSP.Notifications
         Development.IDE.Plugin.CodeAction.PositionIndexed
         Development.IDE.Plugin.CodeAction.Args
         Development.IDE.Plugin.Completions.Logic

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

@@ -10,6 +10,7 @@ module Development.IDE.LSP.Notifications
     ( whenUriFile
     , descriptor
     , Log(..)
+    , ghcideNotificationsPluginPriority
     ) where
 
 import           Language.LSP.Types
@@ -38,6 +39,7 @@ import           Development.IDE.Types.Location
 import           Development.IDE.Types.Logger
 import           Development.IDE.Types.Shake           (toKey)
 import           Ide.Types
+import           Numeric.Natural
 
 data Log
   = LogShake Shake.Log
@@ -138,5 +140,12 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHa
       success <- registerFileWatches globs
       unless success $
         liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"
-  ]
+  ],
+
+    -- The ghcide descriptors should come last'ish so that the notification handlers
+    -- (which restart the Shake build) run after everything else
+        pluginPriority = ghcideNotificationsPluginPriority
     }
+
+ghcideNotificationsPluginPriority :: Natural
+ghcideNotificationsPluginPriority = defaultPluginPriority - 900

ghcide/src/Development/IDE/Main.hs

@@ -21,6 +21,7 @@ import           Control.Exception.Safe                   (SomeException,
 import           Control.Monad.Extra                      (concatMapM, unless,
                                                            when)
 import qualified Data.Aeson.Encode.Pretty                 as A
+import           Data.Coerce                              (coerce)
 import           Data.Default                             (Default (def))
 import           Data.Foldable                            (traverse_)
 import           Data.Hashable                            (hashed)
@@ -92,7 +93,8 @@ import           Development.IDE.Types.Logger             (Logger,
                                                            Recorder,
                                                            WithPriority,
                                                            cmapWithPrio,
-                                                           logWith, vsep, (<+>))
+                                                           logWith, nest, vsep,
+                                                           (<+>))
 import           Development.IDE.Types.Monitoring         (Monitoring)
 import           Development.IDE.Types.Options            (IdeGhcSession,
                                                            IdeOptions (optCheckParents, optCheckProject, optReportProgress, optRunSubset),
@@ -122,7 +124,7 @@ import           Ide.Types                                (IdeCommand (IdeComman
                                                            IdePlugins,
                                                            PluginDescriptor (PluginDescriptor, pluginCli),
                                                            PluginId (PluginId),
-                                                           ipMap)
+                                                           ipMap, pluginId)
 import qualified Language.LSP.Server                      as LSP
 import qualified "list-t" ListT
 import           Numeric.Natural                          (Natural)
@@ -146,7 +148,7 @@ import           Text.Printf                              (printf)
 
 data Log
   = LogHeapStats !HeapStats.Log
-  | LogLspStart
+  | LogLspStart [PluginId]
   | LogLspStartDuration !Seconds
   | LogShouldRunSubset !Bool
   | LogOnlyPartialGhc92Support
@@ -163,10 +165,12 @@ data Log
 instance Pretty Log where
   pretty = \case
     LogHeapStats log -> pretty log
-    LogLspStart ->
-      vsep
-        [ "Staring LSP server..."
-        , "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"]
+    LogLspStart pluginIds ->
+      nest 2 $ vsep
+        [ "Starting LSP server..."
+        , "If you are seeing this in a terminal, you probably should have run WITHOUT the --lsp option!"
+        , "PluginIds:" <+> pretty (coerce @_ @[T.Text] pluginIds)
+        ]
     LogLspStartDuration duration ->
       "Started LSP server in" <+> pretty (showDuration duration)
     LogShouldRunSubset shouldRunSubset ->
@@ -224,7 +228,7 @@ commandP plugins =
 
     pluginCommands = mconcat
         [ command (T.unpack pId) (Custom <$> p)
-        | (PluginId pId, PluginDescriptor{pluginCli = Just p}) <- ipMap plugins
+        | PluginDescriptor{pluginCli = Just p, pluginId = PluginId pId} <- ipMap plugins
         ]
 
 
@@ -336,7 +340,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re
             LT.putStrLn $ decodeUtf8 $ A.encodePretty $ pluginsToDefaultConfig argsHlsPlugins
         LSP -> withNumCapabilities (maybe (numProcessors `div` 2) fromIntegral argsThreads) $ do
             t <- offsetTime
-            log Info LogLspStart
+            log Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins)
 
             let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState
                 getIdeState env rootPath withHieDb hieChan = do

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

@@ -5,6 +5,7 @@
 module Development.IDE.Plugin.Completions
     ( descriptor
     , Log(..)
+    , ghcideCompletionsPluginPriority
     ) where
 
 import           Control.Concurrent.Async                     (concurrently)
@@ -49,6 +50,7 @@ import           Ide.Types
 import qualified Language.LSP.Server                          as LSP
 import           Language.LSP.Types
 import qualified Language.LSP.VFS                             as VFS
+import           Numeric.Natural
 import           Text.Fuzzy.Parallel                          (Scored (..))
 
 data Log = LogShake Shake.Log deriving Show
@@ -57,12 +59,16 @@ instance Pretty Log where
   pretty = \case
     LogShake log -> pretty log
 
+ghcideCompletionsPluginPriority :: Natural
+ghcideCompletionsPluginPriority = defaultPluginPriority
+
 descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
 descriptor recorder plId = (defaultPluginDescriptor plId)
   { pluginRules = produceCompletions recorder
   , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP
   , pluginCommands = [extendImportCommand]
   , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}
+  , pluginPriority = ghcideCompletionsPluginPriority
   }
 
 produceCompletions :: Recorder (WithPriority Log) -> Rules ()

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

@@ -13,7 +13,6 @@ import           Control.Exception            (SomeException)
 import           Control.Lens                 ((^.))
 import           Control.Monad
 import qualified Data.Aeson                   as J
-import           Data.Bifunctor
 import           Data.Dependent.Map           (DMap)
 import qualified Data.Dependent.Map           as DMap
 import           Data.Dependent.Sum
@@ -96,7 +95,7 @@ asGhcIdePlugin recorder (IdePlugins ls) =
 
         mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config
         mkPlugin maker selector =
-          case map (second selector) ls of
+          case map (\p -> (pluginId p, selector p)) ls of
             -- If there are no plugins that provide a descriptor, use mempty to
             -- create the plugin – otherwise we we end up declaring handlers for
             -- capabilities that there are no plugins for

ghcide/test/exe/Main.hs

@@ -290,7 +290,8 @@ initializeResponseTests = withResource acquire release tests where
             doTest = do
                 ir <- getInitializeResponse
                 let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir
-                zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) expected commands
+                    commandNames = (!! 2) . T.splitOn ":" <$> commands
+                zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames)
 
   innerCaps :: ResponseMessage Initialize -> ServerCapabilities
   innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c
@@ -6750,24 +6751,26 @@ unitTests recorder logger = 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
+     , testCase "notification handlers run in priority order" $ do
         orderRef <- newIORef []
         let plugins = pluginDescToIdePlugins $
-                [ (defaultPluginDescriptor $ fromString $ show i)
+                [ (priorityPluginDescriptor i)
                     { pluginNotificationHandlers = mconcat
                         [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \_ _ _ _ ->
                             liftIO $ atomicModifyIORef_ orderRef (i:)
                         ]
                     }
-                    | i <- [(1::Int)..20]
+                    | i <- [1..20]
                 ] ++ Ghcide.descriptors (cmapWithPrio LogGhcIde recorder)
+            priorityPluginDescriptor i = (defaultPluginDescriptor $ fromString $ show i){pluginPriority = i}
 
         testIde recorder (IDE.testing (cmapWithPrio LogIDEMain recorder) logger){IDE.argsHlsPlugins = plugins} $ do
             _ <- createDoc "A.hs" "haskell" "module A where"
             waitForProgressDone
-            actualOrder <- liftIO $ readIORef orderRef
+            actualOrder <- liftIO $ reverse <$> readIORef orderRef
 
-            liftIO $ actualOrder @?= reverse [(1::Int)..20]
+            -- Handlers are run in priority descending order
+            liftIO $ actualOrder @?= [20, 19 .. 1]
      , ignoreTestBecause "The test fails sometimes showing 10000us" $
          testCase "timestamps have millisecond resolution" $ do
            resolution_us <- findResolution_us 1

hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs

@@ -34,7 +34,7 @@ pluginsToDefaultConfig IdePlugins {..} =
   A.toJSON defaultConfig & ix "haskell" . _Object . at "plugin" ?~ elems
   where
     defaultConfig@Config {} = def
-    elems = A.object $ mconcat $ singlePlugin <$> map snd ipMap
+    elems = A.object $ mconcat $ singlePlugin <$> ipMap
     -- Splice genericDefaultConfig and dedicatedDefaultConfig
     -- Example:
     --
@@ -96,7 +96,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 snd ipMap
+pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> ipMap
   where
     singlePlugin PluginDescriptor {pluginConfigDescriptor = ConfigDescriptor {..}, ..} = genericSchema <> dedicatedSchema
       where

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

@@ -36,13 +36,13 @@ module Ide.PluginUtils
 where
 
 
+import           Control.Arrow                   ((&&&))
 import           Control.Monad.Extra             (maybeM)
 import           Control.Monad.Trans.Class       (lift)
 import           Control.Monad.Trans.Except      (ExceptT, runExceptT, throwE)
 import           Data.Algorithm.Diff
 import           Data.Algorithm.DiffOutput
 import           Data.Bifunctor                  (Bifunctor (first))
-import           Data.Containers.ListUtils       (nubOrdOn)
 import qualified Data.HashMap.Strict             as H
 import           Data.String                     (IsString (fromString))
 import qualified Data.Text                       as T
@@ -159,11 +159,10 @@ clientSupportsDocumentChanges caps =
 -- ---------------------------------------------------------------------
 
 pluginDescToIdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState
-pluginDescToIdePlugins plugins =
-    IdePlugins $ map (\p -> (pluginId p, p)) $ nubOrdOn pluginId plugins
+pluginDescToIdePlugins = IdePlugins
 
 idePluginsToPluginDesc :: IdePlugins ideState -> [PluginDescriptor ideState]
-idePluginsToPluginDesc (IdePlugins pp) = map snd pp
+idePluginsToPluginDesc (IdePlugins pp) = pp
 
 -- ---------------------------------------------------------------------
 -- | Returns the current client configuration. It is not wise to permanently
@@ -226,15 +225,8 @@ positionInRange p (Range sp ep) = sp <= p && p < ep -- Range's end position is e
 -- ---------------------------------------------------------------------
 
 allLspCmdIds' :: T.Text -> IdePlugins ideState -> [T.Text]
-allLspCmdIds' pid (IdePlugins ls) = mkPlugin (allLspCmdIds pid) (Just . pluginCommands)
-    where
-        justs (p, Just x)  = [(p, x)]
-        justs (_, Nothing) = []
-
-
-        mkPlugin maker selector
-            = maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls
-
+allLspCmdIds' pid (IdePlugins ls) =
+    allLspCmdIds pid $ map (pluginId &&& pluginCommands) ls
 
 allLspCmdIds :: T.Text -> [(PluginId, [PluginCommand ideState])] -> [T.Text]
 allLspCmdIds pid commands = concatMap go commands