Skip to content

Commit e0c93c2

Browse files
pepeiborrapepeiborra
committed
Avoid reordering plugins
Order of execution matters for notification plugins, so lets avoid unnecessary reorderings
1 parent c5f5d20 commit e0c93c2

File tree

9 files changed

+63
-23
lines changed

9 files changed

+63
-23
lines changed

‎ghcide/ghcide.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -315,6 +315,7 @@ test-suite ghcide-tests
315315
implicit-hie:gen-hie
316316
build-depends:
317317
aeson,
318+
async,
318319
base,
319320
binary,
320321
bytestring,

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,7 @@ import Data.Aeson (Value)
2323
import Data.Maybe
2424
import qualified Data.Set as Set
2525
import qualified Data.Text as T
26-
import qualified Development.IDE.GHC.Util as Ghcide
26+
2727
import Development.IDE.LSP.Server
2828
import Development.IDE.Session (runWithDb)
2929
import Ide.Types (traceWithSpan)

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

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,6 @@ import qualified Language.LSP.Types.Capabilities as LSP
1919
import Development.IDE.Core.IdeConfiguration
2020
import Development.IDE.Core.Service
2121
import Development.IDE.Core.Shake
22-
import Development.IDE.LSP.Server
2322
import Development.IDE.Types.Location
2423
import Development.IDE.Types.Logger
2524
import Development.IDE.Types.Options

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

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -45,13 +45,12 @@ import UnliftIO.Exception (catchAny)
4545

4646
-- | Map a set of plugins to the underlying ghcide engine.
4747
asGhcIdePlugin :: Config -> IdePlugins IdeState -> Plugin Config
48-
asGhcIdePlugin defaultConfig mp =
48+
asGhcIdePlugin defaultConfig (IdePlugins ls) =
4949
mkPlugin rulesPlugins HLS.pluginRules <>
5050
mkPlugin executeCommandPlugins HLS.pluginCommands <>
5151
mkPlugin (extensiblePlugins defaultConfig) HLS.pluginHandlers <>
5252
mkPlugin (extensibleNotificationPlugins defaultConfig) HLS.pluginNotificationHandlers
5353
where
54-
ls = Map.toList (ipMap mp)
5554

5655
mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config
5756
mkPlugin maker selector =

‎ghcide/test/exe/Main.hs

Lines changed: 54 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,7 @@ import Development.IDE.Core.PositionMapping (PositionResult (..),
3636
positionResultToMaybe,
3737
toCurrent)
3838
import Development.IDE.Core.Shake (Q (..))
39+
import Development.IDE.Main as IDE
3940
import Development.IDE.GHC.Util
4041
import Development.IDE.Plugin.Completions.Types (extendImportCommandId)
4142
import Development.IDE.Plugin.TypeLenses (typeLensCommandId)
@@ -75,7 +76,7 @@ import qualified System.IO.Extra
7576
import System.Info.Extra (isWindows)
7677
import System.Process.Extra (CreateProcess (cwd),
7778
proc,
78-
readCreateProcessWithExitCode)
79+
readCreateProcessWithExitCode, createPipe)
7980
import Test.QuickCheck
8081
-- import Test.QuickCheck.Instances ()
8182
import Control.Lens ((^.))
@@ -92,6 +93,14 @@ import Test.Tasty.ExpectedFailure
9293
import Test.Tasty.HUnit
9394
import Test.Tasty.Ingredients.Rerun
9495
import Test.Tasty.QuickCheck
96+
import Data.IORef
97+
import Ide.PluginUtils (pluginDescToIdePlugins)
98+
import Control.Concurrent.Async
99+
import Ide.Types
100+
import Data.String (IsString(fromString))
101+
import qualified Language.LSP.Types as LSP
102+
import Data.IORef.Extra (atomicModifyIORef_)
103+
import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide
95104

96105
waitForProgressBegin :: Session ()
97106
waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case
@@ -179,7 +188,7 @@ initializeResponseTests = withResource acquire release tests where
179188
, chk "NO doc link" _documentLinkProvider Nothing
180189
, chk "NO color" _colorProvider (Just $ InL False)
181190
, chk "NO folding range" _foldingRangeProvider (Just $ InL False)
182-
, che " execute command" _executeCommandProvider [blockCommandId, extendImportCommandId, typeLensCommandId]
191+
, che " execute command" _executeCommandProvider [extendImportCommandId, typeLensCommandId, blockCommandId]
183192
, chk " workspace" _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )}))
184193
, chk "NO experimental" _experimental Nothing
185194
] where
@@ -5143,21 +5152,26 @@ runInDir' dir startExeIn startSessionIn extraOptions s = do
51435152
-- HIE calls getXgdDirectory which assumes that HOME is set.
51445153
-- Only sets HOME if it wasn't already set.
51455154
setEnv "HOME" "/homeless-shelter" False
5146-
let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }
5155+
conf <- getConfigFromEnv
5156+
runSessionWithConfig conf cmd lspTestCaps projDir s
5157+
5158+
getConfigFromEnv :: IO SessionConfig
5159+
getConfigFromEnv = do
51475160
logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR"
51485161
timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT"
5149-
let conf = defaultConfig{messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride}
5150-
-- uncomment this or set LSP_TEST_LOG_STDERR=1 to see all logging
5151-
-- { logStdErr = True }
5152-
-- uncomment this or set LSP_TEST_LOG_MESSAGES=1 to see all messages
5153-
-- { logMessages = True }
5154-
runSessionWithConfig conf{logColor} cmd lspTestCaps projDir s
5162+
return defaultConfig
5163+
{ messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride
5164+
, logColor
5165+
}
51555166
where
51565167
checkEnv :: String -> IO (Maybe Bool)
51575168
checkEnv s = fmap convertVal <$> getEnv s
51585169
convertVal "0" = False
51595170
convertVal _ = True
51605171

5172+
lspTestCaps :: ClientCapabilities
5173+
lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }
5174+
51615175
openTestDataDoc :: FilePath -> Session TextDocumentIdentifier
51625176
openTestDataDoc path = do
51635177
source <- liftIO $ readFileUtf8 $ "test/data" </> path
@@ -5225,8 +5239,39 @@ unitTests = do
52255239
let expected = "1:2-3:4"
52265240
assertBool (unwords ["expected to find range", expected, "in diagnostic", shown]) $
52275241
expected `isInfixOf` shown
5242+
, testCase "notification handlers run sequentially" $ do
5243+
orderRef <- newIORef []
5244+
let plugins = pluginDescToIdePlugins $
5245+
[ (defaultPluginDescriptor $ fromString $ show i)
5246+
{ pluginNotificationHandlers = mconcat
5247+
[ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \_ _ _ ->
5248+
liftIO $ atomicModifyIORef_ orderRef (i:)
5249+
]
5250+
}
5251+
| i <- [(1::Int)..20]
5252+
] ++ Ghcide.descriptors
5253+
5254+
testIde def{argsHlsPlugins = plugins} $ do
5255+
_ <- createDoc "haskell" "A.hs" "module A where"
5256+
waitForProgressDone
5257+
actualOrder <- liftIO $ readIORef orderRef
5258+
5259+
liftIO $ actualOrder @?= reverse [(1::Int)..20]
52285260
]
52295261

5262+
testIde :: Arguments -> Session () -> IO ()
5263+
testIde arguments session = do
5264+
config <- getConfigFromEnv
5265+
(hInRead, hInWrite) <- createPipe
5266+
(hOutRead, hOutWrite) <- createPipe
5267+
let server = IDE.defaultMain arguments
5268+
{ argsHandleIn = pure hInRead
5269+
, argsHandleOut = pure hOutWrite
5270+
}
5271+
5272+
withAsync server $ \_ ->
5273+
runSessionWithHandles hInWrite hOutRead config lspTestCaps "." session
5274+
52305275
positionMappingTests :: TestTree
52315276
positionMappingTests =
52325277
testGroup "position mapping"

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

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,6 @@ import Data.Default (def)
1111
import qualified Data.Dependent.Map as DMap
1212
import qualified Data.Dependent.Sum as DSum
1313
import qualified Data.HashMap.Lazy as HMap
14-
import qualified Data.Map as Map
1514
import Ide.Plugin.Config
1615
import Ide.Plugin.Properties (toDefaultJSON, toVSCodeExtensionSchema)
1716
import Ide.Types
@@ -36,7 +35,7 @@ pluginsToDefaultConfig IdePlugins {..} =
3635
defaultConfig@Config {} = def
3736
unsafeValueToObject (A.Object o) = o
3837
unsafeValueToObject _ = error "impossible"
39-
elems = A.object $ mconcat $ singlePlugin <$> Map.elems ipMap
38+
elems = A.object $ mconcat $ singlePlugin <$> map snd ipMap
4039
-- Splice genericDefaultConfig and dedicatedDefaultConfig
4140
-- Example:
4241
--
@@ -100,7 +99,7 @@ pluginsToDefaultConfig IdePlugins {..} =
10099
-- | Generates json schema used in haskell vscode extension
101100
-- Similar to 'pluginsToDefaultConfig' but simpler, since schema has a flatten structure
102101
pluginsToVSCodeExtensionSchema :: IdePlugins a -> A.Value
103-
pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> Map.elems ipMap
102+
pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlugin <$> map snd ipMap
104103
where
105104
singlePlugin PluginDescriptor {..} = genericSchema <> dedicatedSchema
106105
where

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

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -37,7 +37,6 @@ import Language.LSP.Types
3737
import qualified Language.LSP.Types as J
3838
import Language.LSP.Types.Capabilities
3939

40-
import qualified Data.Map.Strict as Map
4140
import Ide.Plugin.Config
4241
import Ide.Plugin.Properties
4342
import Language.LSP.Server
@@ -144,7 +143,7 @@ clientSupportsDocumentChanges caps =
144143
-- ---------------------------------------------------------------------
145144

146145
pluginDescToIdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState
147-
pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins
146+
pluginDescToIdePlugins plugins = IdePlugins $ map (\p -> (pluginId p, p)) plugins
148147

149148

150149
-- ---------------------------------------------------------------------
@@ -214,12 +213,11 @@ positionInRange (Position pl po) (Range (Position sl so) (Position el eo)) =
214213
-- ---------------------------------------------------------------------
215214

216215
allLspCmdIds' :: T.Text -> IdePlugins ideState -> [T.Text]
217-
allLspCmdIds' pid mp = mkPlugin (allLspCmdIds pid) (Just . pluginCommands)
216+
allLspCmdIds' pid (IdePlugins ls) = mkPlugin (allLspCmdIds pid) (Just . pluginCommands)
218217
where
219218
justs (p, Just x) = [(p, x)]
220219
justs (_, Nothing) = []
221220

222-
ls = Map.toList (ipMap mp)
223221

224222
mkPlugin maker selector
225223
= maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls

‎hls-plugin-api/src/Ide/Types.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -54,7 +54,7 @@ import Text.Regex.TDFA.Text ()
5454
-- ---------------------------------------------------------------------
5555

5656
newtype IdePlugins ideState = IdePlugins
57-
{ ipMap :: Map.Map PluginId (PluginDescriptor ideState)}
57+
{ ipMap :: [(PluginId, PluginDescriptor ideState)]}
5858

5959
-- ---------------------------------------------------------------------
6060

‎src/Ide/Main.hs

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,6 @@ import Control.Monad.Extra
1313
import qualified Data.Aeson.Encode.Pretty as A
1414
import qualified Data.ByteString.Lazy.Char8 as LBS
1515
import Data.Default
16-
import qualified Data.Map.Strict as Map
1716
import qualified Data.Text as T
1817
import Development.IDE.Core.Rules
1918
import qualified Development.IDE.Main as Main
@@ -97,7 +96,7 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do
9796
when argLSP $ do
9897
hPutStrLn stderr "Starting (haskell-language-server)LSP server..."
9998
hPutStrLn stderr $ " with arguments: " <> show lspArgs
100-
hPutStrLn stderr $ " with plugins: " <> show (Map.keys $ ipMap idePlugins)
99+
hPutStrLn stderr $ " with plugins: " <> show (map fst $ ipMap idePlugins)
101100
hPutStrLn stderr $ " in directory: " <> dir
102101
hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
103102

0 commit comments

Comments
 (0)