Skip to content

Commit d43a087

Browse files
pepeiborraisovector
pepeiborra
authored and
isovector
committed
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
1 parent 2285f68 commit d43a087

File tree

8 files changed

+70
-25
lines changed

8 files changed

+70
-25
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/Plugin/HLS.hs‎

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

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

5554
mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config
5655
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
@@ -5145,21 +5154,26 @@ runInDir' dir startExeIn startSessionIn extraOptions s = do
51455154
-- HIE calls getXgdDirectory which assumes that HOME is set.
51465155
-- Only sets HOME if it wasn't already set.
51475156
setEnv "HOME" "/homeless-shelter" False
5148-
let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }
5157+
conf <- getConfigFromEnv
5158+
runSessionWithConfig conf cmd lspTestCaps projDir s
5159+
5160+
getConfigFromEnv :: IO SessionConfig
5161+
getConfigFromEnv = do
51495162
logColor <- fromMaybe True <$> checkEnv "LSP_TEST_LOG_COLOR"
51505163
timeoutOverride <- fmap read <$> getEnv "LSP_TIMEOUT"
5151-
let conf = defaultConfig{messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride}
5152-
-- uncomment this or set LSP_TEST_LOG_STDERR=1 to see all logging
5153-
-- { logStdErr = True }
5154-
-- uncomment this or set LSP_TEST_LOG_MESSAGES=1 to see all messages
5155-
-- { logMessages = True }
5156-
runSessionWithConfig conf{logColor} cmd lspTestCaps projDir s
5164+
return defaultConfig
5165+
{ messageTimeout = fromMaybe (messageTimeout defaultConfig) timeoutOverride
5166+
, logColor
5167+
}
51575168
where
51585169
checkEnv :: String -> IO (Maybe Bool)
51595170
checkEnv s = fmap convertVal <$> getEnv s
51605171
convertVal "0" = False
51615172
convertVal _ = True
51625173

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

5264+
testIde :: Arguments -> Session () -> IO ()
5265+
testIde arguments session = do
5266+
config <- getConfigFromEnv
5267+
(hInRead, hInWrite) <- createPipe
5268+
(hOutRead, hOutWrite) <- createPipe
5269+
let server = IDE.defaultMain arguments
5270+
{ argsHandleIn = pure hInRead
5271+
, argsHandleOut = pure hOutWrite
5272+
}
5273+
5274+
withAsync server $ \_ ->
5275+
runSessionWithHandles hInWrite hOutRead config lspTestCaps "." session
5276+
52325277
positionMappingTests :: TestTree
52335278
positionMappingTests =
52345279
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: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -37,7 +37,7 @@ 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
40+
import Data.Containers.ListUtils (nubOrdOn)
4141
import Ide.Plugin.Config
4242
import Ide.Plugin.Properties
4343
import Language.LSP.Server
@@ -144,7 +144,8 @@ clientSupportsDocumentChanges caps =
144144
-- ---------------------------------------------------------------------
145145

146146
pluginDescToIdePlugins :: [PluginDescriptor ideState] -> IdePlugins ideState
147-
pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins
147+
pluginDescToIdePlugins plugins =
148+
IdePlugins $ map (\p -> (pluginId p, p)) $ nubOrdOn pluginId plugins
148149

149150

150151
-- ---------------------------------------------------------------------
@@ -214,12 +215,11 @@ positionInRange (Position pl po) (Range (Position sl so) (Position el eo)) =
214215
-- ---------------------------------------------------------------------
215216

216217
allLspCmdIds' :: T.Text -> IdePlugins ideState -> [T.Text]
217-
allLspCmdIds' pid mp = mkPlugin (allLspCmdIds pid) (Just . pluginCommands)
218+
allLspCmdIds' pid (IdePlugins ls) = mkPlugin (allLspCmdIds pid) (Just . pluginCommands)
218219
where
219220
justs (p, Just x) = [(p, x)]
220221
justs (_, Nothing) = []
221222

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

224224
mkPlugin maker selector
225225
= 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

‎test/functional/FunctionalCodeAction.hs‎

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -372,7 +372,8 @@ redundantImportTests = testGroup "redundant import code actions" [
372372
, testCase "doesn't touch other imports" $ runSession hlsCommand noLiteralCaps "test/testdata/redundantImportTest/" $ do
373373
doc <- openDoc "src/MultipleImports.hs" "haskell"
374374
_ <- waitForDiagnosticsFromSource doc "typecheck"
375-
InL cmd : _ <- getAllCodeActions doc
375+
cas <- getAllCodeActions doc
376+
cmd <- liftIO $ inspectCommand cas ["redundant import"]
376377
executeCommand cmd
377378
_ <- anyRequest
378379
contents <- documentContents doc
@@ -439,11 +440,12 @@ signatureTests = testGroup "missing top level signature code actions" [
439440
doc <- openDoc "TopLevelSignature.hs" "haskell"
440441

441442
_ <- waitForDiagnosticsFromSource doc "typecheck"
442-
cas <- map fromAction <$> getAllCodeActions doc
443+
cas <- getAllCodeActions doc
443444

444-
liftIO $ "add signature: main :: IO ()" `elem` map (^. L.title) cas @? "Contains code action"
445+
liftIO $ expectCodeAction cas ["add signature: main :: IO ()"]
445446

446-
executeCodeAction $ head cas
447+
replaceWithStuff <- liftIO $ inspectCodeAction cas ["add signature"]
448+
executeCodeAction replaceWithStuff
447449

448450
contents <- documentContents doc
449451

0 commit comments

Comments
 (0)