ghcide 0.7.4.0 → 0.7.5.0

raw patch · 49 files changed

+1930/−1896 lines, 49 filesdep +dependent-mapdep +dependent-sumdep +lspdep −ghc-libdep −ghc-lib-parserdep −haskell-lspdep ~hls-plugin-apidep ~lsp-testPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: dependent-map, dependent-sum, lsp, lsp-types, unliftio, unliftio-core

Dependencies removed: ghc-lib, ghc-lib-parser, haskell-lsp, haskell-lsp-types

Dependency ranges changed: hls-plugin-api, lsp-test

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• bench/hist/Main.hs +22/−2
• bench/lib/Experiments.hs +43/−35
• exe/Main.hs +68/−204
• ghcide.cabal +31/−51
• session-loader/Development/IDE/Session.hs +39/−42
• src/Development/IDE/Core/Compile.hs +45/−52
• src/Development/IDE/Core/FileExists.hs +18/−9
• src/Development/IDE/Core/FileStore.hs +9/−7
• src/Development/IDE/Core/IdeConfiguration.hs +1/−1
• src/Development/IDE/Core/OfInterest.hs +2/−1
• src/Development/IDE/Core/PositionMapping.hs +1/−1
• src/Development/IDE/Core/RuleTypes.hs +7/−7
• src/Development/IDE/Core/Rules.hs +44/−60
• src/Development/IDE/Core/Service.hs +8/−16
• src/Development/IDE/Core/Shake.hs +76/−79
• src/Development/IDE/Core/Tracing.hs +16/−12
• src/Development/IDE/GHC/ExactPrint.hs +96/−9
• src/Development/IDE/GHC/Warnings.hs +3/−2
• src/Development/IDE/Import/DependencyInformation.hs +6/−32
• src/Development/IDE/Import/FindImports.hs +3/−3
• src/Development/IDE/LSP/HoverDefinition.hs +30/−34
• src/Development/IDE/LSP/LanguageServer.hs +99/−153
• src/Development/IDE/LSP/Notifications.hs +102/−106
• src/Development/IDE/LSP/Outline.hs +13/−18
• src/Development/IDE/LSP/Protocol.hs +0/−23
• src/Development/IDE/LSP/Server.hs +46/−70
• src/Development/IDE/Main.hs +224/−0
• src/Development/IDE/Plugin.hs +6/−7
• src/Development/IDE/Plugin/CodeAction.hs +122/−28
• src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +14/−8
• src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs +1/−1
• src/Development/IDE/Plugin/Completions.hs +47/−44
• src/Development/IDE/Plugin/Completions/Logic.hs +23/−26
• src/Development/IDE/Plugin/Completions/Types.hs +3/−1
• src/Development/IDE/Plugin/HLS.hs +121/−428
• src/Development/IDE/Plugin/HLS/Formatter.hs +0/−70
• src/Development/IDE/Plugin/HLS/GhcIde.hs +11/−16
• src/Development/IDE/Plugin/Test.hs +23/−28
• src/Development/IDE/Plugin/TypeLenses.hs +14/−12
• src/Development/IDE/Spans/AtPoint.hs +10/−2
• src/Development/IDE/Spans/Documentation.hs +11/−14
• src/Development/IDE/Types/Diagnostics.hs +2/−2
• src/Development/IDE/Types/HscEnvEq.hs +48/−10
• src/Development/IDE/Types/Location.hs +2/−2
• src/Development/IDE/Types/Options.hs +5/−6
• src/Development/IDE/Types/Shake.hs +1/−1
• test/exe/Main.hs +369/−131
• test/src/Development/IDE/Test.hs +33/−30

@@ -1,3 +1,15 @@+### 0.7.5 (2021-02-??)+* Tone down some logInfos to logDebug (#1385) - Pepe Iborra+* Show window message when auto extending import lists (#1371) - Potato Hatsue+* Catch GHC errors in listing module names (#1367) - Potato Hatsue+* Upgrade to lsp-1.0 (#1284) - wz1000+* Added Development.IDE.Main (#1338) - Pepe Iborra+* Fix completion snippets on DuplicateRecordFields (#1360) - Potato Hatsue+* Add code action for hiding shadowed identifiers from imports (#1322) - Potato Hatsue+* Make find-definition work better with multi-components (#1357) - wz1000+* Index files on first open (#1358) - wz1000+* Fix code actions regression (#1349) - Pepe Iborra+ ### 0.7.4 (2021-02-08) * Support for references via hiedb (#704) - wz1000 * Fix space leak on cradle reloads (#1316) - Pepe Iborra

@@ -55,6 +55,7 @@ import System.Console.GetOpt import Data.Maybe import Control.Monad.Extra+import System.FilePath   configPath :: FilePath@@ -84,7 +85,12 @@       _ -> want wants  ghcideBuildRules :: MkBuildRules BuildSystem-ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" buildGhcide+ghcideBuildRules = MkBuildRules findGhcForBuildSystem "ghcide" projectDepends buildGhcide+  where+      projectDepends = do+        need . map ("src" </>) =<< getDirectoryFiles "src" ["//*.hs"]+        need . map ("session-loader" </>) =<< getDirectoryFiles "session-loader" ["//*.hs"]+        need =<< getDirectoryFiles "." ["*.cabal"]  -------------------------------------------------------------------------------- @@ -116,7 +122,7 @@   let build = outputFolder configStatic    buildRules build ghcideBuildRules-  benchRules build (MkBenchRules (askOracle $ GetSamples ()) benchGhcide "ghcide")+  benchRules build (MkBenchRules (askOracle $ GetSamples ()) benchGhcide warmupGhcide "ghcide")   csvRules build   svgRules build   heapProfileRules build@@ -141,6 +147,7 @@         ,"--install-method=copy"         ,"--overwrite-policy=always"         ,"--ghc-options=-rtsopts"+        ,"--ghc-options=-eventlog"         ]  buildGhcide Stack args out =@@ -150,6 +157,7 @@         ,"ghcide:ghcide"         ,"--copy-bins"         ,"--ghc-options=-rtsopts"+        ,"--ghc-options=-eventlog"         ]  benchGhcide@@ -170,3 +178,15 @@     [ "--stack" | Stack == buildSystem     ] +warmupGhcide :: BuildSystem -> FilePath -> [CmdOption] -> Example -> Action ()+warmupGhcide buildSystem exePath args example = do+  command args "ghcide-bench" $+    [ "--no-clean",+      "-v",+      "--samples=1",+      "--ghcide=" <> exePath,+      "--select=hover"+    ] +++    exampleToOptions example +++    [ "--stack" | Stack == buildSystem+    ]

@@ -1,7 +1,9 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ImpredicativeTypes #-}+{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-}  module Experiments ( Bench(..)@@ -20,19 +22,19 @@ , exampleToOptions ) where import Control.Applicative.Combinators (skipManyTill)-import Control.Exception.Safe+import Control.Exception.Safe (IOException, handleAny, try) import Control.Monad.Extra import Control.Monad.IO.Class-import Data.Aeson (Value(Null))+import Data.Aeson (Value(Null), toJSON) import Data.List import Data.Maybe import qualified Data.Text as T import Data.Version import Development.IDE.Plugin.Test import Experiments.Types-import Language.Haskell.LSP.Test-import Language.Haskell.LSP.Types-import Language.Haskell.LSP.Types.Capabilities+import Language.LSP.Test+import Language.LSP.Types+import Language.LSP.Types.Capabilities import Numeric.Natural import Options.Applicative import System.Directory@@ -41,6 +43,7 @@ import System.Process import System.Time.Extra import Text.ParserCombinators.ReadP (readP_to_S)+import Development.Shake (cmd_, CmdOption (Cwd, FileStdout))  charEdit :: Position -> TextDocumentContentChangeEvent charEdit p =@@ -78,13 +81,13 @@           isJust <$> getHover doc (fromJust identifierP),       ---------------------------------------------------------------------------------------       bench "getDefinition" $ allWithIdentifierPos $ \DocumentPositions{..} ->-        not . null <$> getDefinitions doc (fromJust identifierP),+        either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP),       ---------------------------------------------------------------------------------------       bench "getDefinition after edit" $ \docs -> do           forM_ docs $ \DocumentPositions{..} ->             changeDoc doc [charEdit stringLiteralP]           flip allWithIdentifierPos docs $ \DocumentPositions{..} ->-            not . null <$> getDefinitions doc (fromJust identifierP),+            either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP),       ---------------------------------------------------------------------------------------       bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do         fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc,@@ -147,7 +150,7 @@         ( \docs -> do             Just hieYaml <- uriToFilePath <$> getDocUri "hie.yaml"             liftIO $ appendFile hieYaml "##\n"-            sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+            sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $                 List [ FileEvent (filePathToUri "hie.yaml") FcChanged ]             forM_ docs $ \DocumentPositions{..} ->               changeDoc doc [charEdit stringLiteralP]@@ -162,7 +165,7 @@         (\docs -> do             Just hieYaml <- uriToFilePath <$> getDocUri "hie.yaml"             liftIO $ appendFile hieYaml "##\n"-            sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+            sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $                 List [ FileEvent (filePathToUri "hie.yaml") FcChanged ]             flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP)         )@@ -358,7 +361,9 @@ waitForProgressDone = loop   where     loop = do-      void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)+      ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case+        FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()+        _ -> Nothing       done <- null <$> getIncompleteProgressSessions       unless done loop @@ -392,8 +397,9 @@             else do                 output (showDuration t)                 -- Wait for the delayed actions to finish-                waitId <- sendRequest (CustomClientMethod "test") WaitForShakeQueue-                (td, resp) <- duration $ skipManyTill anyMessage $ responseForId waitId+                let m = SCustomMethod "test"+                waitId <- sendRequest m (toJSON WaitForShakeQueue)+                (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId                 case resp of                     ResponseMessage{_result=Right Null} -> do                       loop (userWaits+t) (delayedWork+td) (n -1)@@ -423,19 +429,24 @@ setup = do --   when alreadyExists $ removeDirectoryRecursive examplesPath   benchDir <- case example ?config of-      UsePackage{..} -> return examplePath+      UsePackage{..} -> do+          let hieYamlPath = examplePath </> "hie.yaml"+          alreadyExists <- doesFileExist hieYamlPath+          unless alreadyExists $+                cmd_ (Cwd examplePath) (FileStdout hieYamlPath) ("gen-hie"::String)+          return examplePath       GetPackage{..} -> do         let path = examplesPath </> package             package = exampleName <> "-" <> showVersion exampleVersion+            hieYamlPath = path </> "hie.yaml"         alreadySetup <- doesDirectoryExist path         unless alreadySetup $           case buildTool ?config of             Cabal -> do                 let cabalVerbosity = "-v" ++ show (fromEnum (verbose ?config))                 callCommandLogging $ "cabal get " <> cabalVerbosity <> " " <> package <> " -d " <> examplesPath-                writeFile-                    (path </> "hie.yaml")-                    ("cradle: {cabal: {component: " <> exampleName <> "}}")+                let hieYamlPath = path </> "hie.yaml"+                cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String)                 -- Need this in case there is a parent cabal.project somewhere                 writeFile                     (path </> "cabal.project")@@ -464,9 +475,7 @@                             ]                         ) -                writeFile-                    (path </> "hie.yaml")-                    ("cradle: {stack: {component: " <> show (exampleName <> ":lib") <> "}}")+                cmd_ (Cwd path) (FileStdout hieYamlPath) ("gen-hie"::String) ["--stack"::String]         return path    whenJust (shakeProfiling ?config) $ createDirectoryIfMissing True@@ -498,22 +507,21 @@          -- Find an identifier defined in another file in this project         symbols <- getDocumentSymbols doc-        case symbols of-            Left [DocumentSymbol{_children = Just (List symbols)}] -> do-                let endOfImports = case symbols of-                        DocumentSymbol{_kind = SkModule, _name = "imports", _range } : _ ->-                            Position (succ $ _line $ _end _range) 4-                        DocumentSymbol{_range} : _ -> _start _range-                        [] -> error "Module has no symbols"-                contents <- documentContents doc--                identifierP <- searchSymbol doc contents endOfImports--                return $ DocumentPositions{..}-            other ->-                error $ "symbols: " <> show other-+        let endOfImports = case symbols of+                Left symbols | Just x <- findEndOfImports symbols -> x+                _ -> error $ "symbols: " <> show symbols+        contents <- documentContents doc+        identifierP <- searchSymbol doc contents endOfImports+        return $ DocumentPositions{..} +findEndOfImports :: [DocumentSymbol] -> Maybe Position+findEndOfImports (DocumentSymbol{_kind = SkModule, _name = "imports", _range} : _) =+    Just $ Position (succ $ _line $ _end _range) 4+findEndOfImports [DocumentSymbol{_kind = SkFile, _children = Just (List cc)}] =+    findEndOfImports cc+findEndOfImports (DocumentSymbol{_range} : _) =+    Just $ _start _range+findEndOfImports _ = Nothing  -------------------------------------------------------------------------------------------- @@ -559,7 +567,7 @@       checkDefinitions pos = do         defs <- getDefinitions doc pos         case defs of-            [Location uri _] -> return $ uri /= _uri+            (InL [Location uri _]) -> return $ uri /= _uri             _ -> return False       checkCompletions pos =         not . null <$> getCompletions doc pos

@@ -5,61 +5,34 @@  module Main(main) where -import Arguments-import Control.Concurrent.Extra-import Control.Monad.Extra-import Control.Exception.Safe-import Control.Lens ( (^.) )-import Data.Default-import Data.List.Extra-import Data.Maybe+import Arguments ( Arguments'(..), IdeCmd(..), getArguments )+import Control.Concurrent.Extra ( newLock, withLock )+import Control.Monad.Extra ( unless, when, whenJust )+import Data.Default ( Default(def) )+import Data.List.Extra ( upper )+import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Data.Text.IO as T-import Data.Version-import Development.IDE.Core.Debouncer-import Development.IDE.Core.FileStore-import Development.IDE.Core.OfInterest-import Development.IDE.Core.Service-import Development.IDE.Core.Rules-import Development.IDE.Core.Shake-import Development.IDE.Core.RuleTypes-import Development.IDE.LSP.Protocol-import Development.IDE.Types.Location-import Development.IDE.Types.Diagnostics+import Data.Version ( showVersion )+import Development.GitRev ( gitHash )+import Development.IDE ( Logger(Logger), Priority(Info), action )+import Development.IDE.Core.OfInterest (kick)+import Development.IDE.Core.Rules (mainRule)+import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde+import qualified Development.IDE.Plugin.Test as Test+import Development.IDE.Session (setInitialDynFlags, getHieDbLoc) import Development.IDE.Types.Options-import Development.IDE.Types.Logger-import Development.IDE.Plugin-import Development.IDE.Plugin.Test as Test-import Development.IDE.Session (loadSession, setInitialDynFlags, getHieDbLoc, runWithDb)-import Development.Shake (ShakeOptions (shakeThreads))-import qualified Language.Haskell.LSP.Core as LSP-import Language.Haskell.LSP.Messages-import Language.Haskell.LSP.Types-import Language.Haskell.LSP.Types.Lens (params, initializationOptions)-import Development.IDE.LSP.LanguageServer-import qualified System.Directory.Extra as IO-import System.Environment-import System.IO-import System.Info-import System.Exit-import System.FilePath-import System.Time.Extra-import Paths_ghcide-import Development.GitRev-import qualified Data.HashMap.Strict as HashMap-import qualified Data.Aeson as J--import HIE.Bios.Cradle-import Development.IDE (action)-import Text.Printf-import Development.IDE.Core.Tracing-import Development.IDE.Types.Shake (Key(Key))-import Development.IDE.Plugin.HLS (asGhcIdePlugin)-import Development.IDE.Plugin.HLS.GhcIde as GhcIde-import Ide.Plugin.Config-import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins)-+import qualified Development.IDE.Main as Main+import Development.Shake (ShakeOptions(shakeThreads))+import Ide.Plugin.Config (Config(checkParents, checkProject))+import Ide.PluginUtils (pluginDescToIdePlugins) import HieDb.Run (Options(..), runCommand)+import Paths_ghcide ( version )+import qualified System.Directory.Extra as IO+import System.Environment ( getExecutablePath )+import System.Exit ( ExitCode(ExitFailure), exitSuccess, exitWith )+import System.Info ( compilerVersion )+import System.IO ( stderr, hPutStrLn )  ghcideVersion :: IO String ghcideVersion = do@@ -83,171 +56,62 @@      whenJust argsCwd IO.setCurrentDirectory --    dir <- IO.getCurrentDirectory-    dbLoc <- getHieDbLoc dir+    -- lock to avoid overlapping output on stdout+    lock <- newLock+    let logger = Logger $ \pri msg -> when (pri >= logLevel) $ withLock lock $+            T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg+        logLevel = if argsVerbose then minBound else Info      case argFilesOrCmd of       DbCmd opts cmd -> do-        mlibdir <- setInitialDynFlags+        dir <- IO.getCurrentDirectory+        dbLoc <- getHieDbLoc dir+        mlibdir <- setInitialDynFlags def         case mlibdir of           Nothing -> exitWith $ ExitFailure 1-          Just libdir ->-            runCommand libdir opts{database = dbLoc} cmd-      Typecheck (Just -> argFilesOrCmd) | not argLSP -> runWithDb dbLoc $ runIde Arguments{..}-      _ -> let argFilesOrCmd = Nothing in runWithDb dbLoc $ runIde Arguments{..}---runIde :: Arguments' (Maybe [FilePath]) -> HieDb -> IndexQueue -> IO ()-runIde Arguments{..} hiedb hiechan = do-    -- lock to avoid overlapping output on stdout-    lock <- newLock-    let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $-            T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg--    dir <- IO.getCurrentDirectory+          Just libdir -> runCommand libdir opts{database = dbLoc} cmd -    let hlsPlugins = pluginDescToIdePlugins $-            GhcIde.descriptors ++-            [ Test.blockCommandDescriptor "block-command" | argsTesting]+      _ -> do -    pid <- T.pack . show <$> getProcessID-    let hlsPlugin = asGhcIdePlugin hlsPlugins-        hlsCommands = allLspCmdIds' pid hlsPlugins+          case argFilesOrCmd of+              LSP -> do+                hPutStrLn stderr "Starting LSP server..."+                hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"+              _ -> return () -    let plugins = hlsPlugin-            <> if argsTesting then Test.plugin else mempty-        onInitialConfiguration :: InitializeRequest -> Either T.Text Config-        onInitialConfiguration x = case x ^. params . initializationOptions of-          Nothing -> Right def-          Just v -> case J.fromJSON v of-            J.Error err -> Left $ T.pack err-            J.Success a -> Right a-        onConfigurationChange = const $ Left "Updating Not supported"-        options = def { LSP.executeCommandCommands = Just hlsCommands-                      , LSP.completionTriggerCharacters = Just "."-                      }-    case argFilesOrCmd of-      Nothing -> do-        t <- offsetTime-        hPutStrLn stderr "Starting LSP server..."-        hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"-        runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg getConfig rootPath -> do-            t <- t-            hPutStrLn stderr $ "Started LSP server in " ++ showDuration t+          Main.defaultMain def+            {Main.argFiles = case argFilesOrCmd of+                Typecheck x | not argLSP -> Just x+                _ -> Nothing -            -- We want to set the global DynFlags right now, so that we can use-            -- `unsafeGlobalDynFlags` even before the project is configured-            -- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath')-            -- before calling this function-            _mlibdir <- setInitialDynFlags-                          `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)+            ,Main.argsLogger = logger -            sessionLoader <- loadSession $ fromMaybe dir rootPath-            config <- fromMaybe def <$> getConfig-            let options = defOptions-                    { optReportProgress    = clientSupportsProgress caps-                    , optShakeProfiling    = argsShakeProfiling-                    , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling-                    , optTesting           = IdeTesting argsTesting-                    , optShakeOptions      = (optShakeOptions defOptions){shakeThreads = argsThreads}-                    , optCheckParents      = checkParents config-                    , optCheckProject      = checkProject config-                    }-                defOptions = defaultIdeOptions sessionLoader-                logLevel = if argsVerbose then minBound else Info-            debouncer <- newAsyncDebouncer-            let rules = do-                  -- install the main and ghcide-plugin rules-                  mainRule-                  pluginRules plugins-                  -- install the kick action, which triggers a typecheck on every-                  -- Shake database restart, i.e. on every user edit.-                  unless argsDisableKick $+            ,Main.argsRules = do+                -- install the main and ghcide-plugin rules+                mainRule+                -- install the kick action, which triggers a typecheck on every+                -- Shake database restart, i.e. on every user edit.+                unless argsDisableKick $                     action kick-            initialise caps rules-                getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs hiedb hiechan-      Just argFiles -> do-        -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error-        hSetEncoding stdout utf8-        hSetEncoding stderr utf8 -        putStrLn $ "Ghcide setup tester in " ++ dir ++ "."-        putStrLn "Report bugs at https://github.com/haskell/ghcide/issues"--        putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir-        files <- expandFiles (argFiles ++ ["." | null argFiles])-        -- LSP works with absolute file paths, so try and behave similarly-        files <- nubOrd <$> mapM IO.canonicalizePath files-        putStrLn $ "Found " ++ show (length files) ++ " files"--        putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"-        cradles <- mapM findCradle files-        let ucradles = nubOrd cradles-        let n = length ucradles-        putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]-        when (n > 0) $ putStrLn $ "  (" ++ intercalate ", " (catMaybes ucradles) ++ ")"-        putStrLn "\nStep 3/4: Initializing the IDE"-        vfs <- makeVFSHandle-        debouncer <- newAsyncDebouncer-        let dummyWithProg _ _ f = f (const (pure ()))-        sessionLoader <- loadSession dir-        let options = defOptions-                    { optShakeProfiling    = argsShakeProfiling-                    -- , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling-                    , optTesting           = IdeTesting argsTesting-                    , optShakeOptions      = (optShakeOptions defOptions){shakeThreads = argsThreads}-                    , optCheckParents      = NeverCheck-                    , optCheckProject      = False-                    }-            defOptions = defaultIdeOptions sessionLoader-            logLevel = if argsVerbose then minBound else Info-        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer options vfs hiedb hiechan--        putStrLn "\nStep 4/4: Type checking the files"-        setFilesOfInterest ide $ HashMap.fromList $ map ((, OnDisk) . toNormalizedFilePath') files-        results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files)-        _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' files)-        _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' files)-        let (worked, failed) = partition fst $ zip (map isJust results) files-        when (failed /= []) $-            putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed--        let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"-        putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)"--        when argsOTMemoryProfiling $ do-            let valuesRef = state $ shakeExtras ide-            values <- readVar valuesRef-            let consoleObserver Nothing = return $ \size -> printf "Total: %.2fMB\n" (fromIntegral @Int @Double size / 1e6)-                consoleObserver (Just k) = return $ \size -> printf "  - %s: %.2fKB\n" (show k) (fromIntegral @Int @Double size / 1e3)--            printf "# Shake value store contents(%d):\n" (length values)-            let keys = nub-                     $ Key GhcSession : Key GhcSessionDeps-                     : [ k | (_,k) <- HashMap.keys values, k /= Key GhcSessionIO]-                     ++ [Key GhcSessionIO]-            measureMemory (logger logLevel) [keys] consoleObserver valuesRef--        unless (null failed) (exitWith $ ExitFailure (length failed))+            ,Main.argsHlsPlugins =+                pluginDescToIdePlugins $+                GhcIde.descriptors+                ++ [Test.blockCommandDescriptor "block-command" | argsTesting] -{-# ANN runIde ("HLint: ignore Use nubOrd" :: String) #-}+            ,Main.argsGhcidePlugin = if argsTesting+                then Test.plugin+                else mempty -expandFiles :: [FilePath] -> IO [FilePath]-expandFiles = concatMapM $ \x -> do-    b <- IO.doesFileExist x-    if b then return [x] else do-        let recurse "." = True-            recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc-            recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories-        files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x-        when (null files) $-            fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x-        return files+            ,Main.argsIdeOptions = \(fromMaybe def -> config) sessionLoader ->+                let defOptions = defaultIdeOptions sessionLoader+                in defOptions+                  { optShakeProfiling = argsShakeProfiling+                  , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling+                  , optTesting = IdeTesting argsTesting+                  , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}+                  , optCheckParents = pure $ checkParents config+                  , optCheckProject = pure $ checkProject config+                  }+            } --- | Print an LSP event.-showEvent :: Lock -> FromServerMessage -> IO ()-showEvent _ (EventFileDiagnostics _ []) = return ()-showEvent lock (EventFileDiagnostics (toNormalizedFilePath' -> file) diags) =-    withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags-showEvent lock e = withLock lock $ print e

@@ -2,7 +2,7 @@ build-type:         Simple category:           Development name:               ghcide-version:            0.7.4.0+version:            0.7.5.0 license:            Apache-2.0 license-file:       LICENSE author:             Digital Asset and Ghcide contributors@@ -13,7 +13,7 @@     A library for building Haskell IDE's on top of the GHC API. homepage:           https://github.com/haskell/ghcide#readme bug-reports:        https://github.com/haskell/ghcide/issues-tested-with:        GHC == 8.6.4 || == 8.6.5 || == 8.8.2 || == 8.8.3 || == 8.8.4 || == 8.10.1 || == 8.10.2 || == 8.10.3+tested-with:        GHC == 8.6.4 || == 8.6.5 || == 8.8.2 || == 8.8.3 || == 8.8.4 || == 8.10.2 || == 8.10.3 || == 8.10.4 extra-source-files: include/ghc-api-version.h README.md CHANGELOG.md                     test/data/hover/*.hs                     test/data/multi/cabal.project@@ -27,11 +27,6 @@     type:     git     location: https://github.com/haskell/ghcide.git -flag ghc-lib-  description: build against ghc-lib instead of the ghc package-  default: False-  manual: True- library     default-language:   Haskell2010     build-depends:@@ -46,6 +41,8 @@         data-default,         deepseq,         directory,+        dependent-map,+        dependent-sum,         dlist,         extra >= 1.7.4,         fuzzy,@@ -55,12 +52,12 @@         Glob,         haddock-library >= 1.8,         hashable,-        haskell-lsp-types == 0.23.*,-        haskell-lsp == 0.23.*,         hie-compat,-        hls-plugin-api >= 0.7,+        hls-plugin-api >= 0.7.1,         lens,         hiedb == 0.3.0.1,+        lsp-types == 1.1.*,+        lsp == 1.1.1.0,         mtl,         network-uri,         parallel,@@ -88,19 +85,12 @@         vector,         bytestring-encoding,         opentelemetry >=0.6.1,-        heapsize ==0.3.*-    if flag(ghc-lib)-      build-depends:-        ghc-lib >= 8.8,-        ghc-lib-parser >= 8.8-      cpp-options: -DGHC_LIB-    else-      build-depends:+        heapsize ==0.3.*,+        unliftio,+        unliftio-core,         ghc-boot-th,         ghc-boot,         ghc >= 8.6,-        -- These dependencies are used by Development.IDE.Session and are-        -- Haskell specific. So don't use them when building with -fghc-lib!         ghc-check >=0.5.0.1,         ghc-paths,         cryptohash-sha1 >=0.11.100 && <0.12,@@ -131,13 +121,18 @@         TupleSections         TypeApplications         ViewPatterns+        DataKinds+        TypeOperators+        KindSignatures      hs-source-dirs:         src+        session-loader     include-dirs:         include     exposed-modules:         Development.IDE+        Development.IDE.Main         Development.IDE.Core.Debouncer         Development.IDE.Core.FileStore         Development.IDE.Core.IdeConfiguration@@ -150,16 +145,18 @@         Development.IDE.Core.Shake         Development.IDE.Core.Tracing         Development.IDE.GHC.Compat+        Development.IDE.Core.Compile         Development.IDE.GHC.Error         Development.IDE.GHC.ExactPrint         Development.IDE.GHC.Orphans         Development.IDE.GHC.Util         Development.IDE.Import.DependencyInformation+        Development.IDE.Import.FindImports         Development.IDE.LSP.HoverDefinition         Development.IDE.LSP.LanguageServer         Development.IDE.LSP.Outline-        Development.IDE.LSP.Protocol         Development.IDE.LSP.Server+        Development.IDE.Session         Development.IDE.Spans.Common         Development.IDE.Spans.Documentation         Development.IDE.Spans.AtPoint@@ -182,31 +179,16 @@         Development.IDE.Plugin.Test         Development.IDE.Plugin.TypeLenses -    -- Unfortunately, we cannot use loadSession with ghc-lib since hie-bios uses-    -- the real GHC library and the types are incompatible. Furthermore, when-    -- building with ghc-lib we need to make this Haskell agnostic, so no-    -- hie-bios!-    -- We also put these modules into a separate hs-source-dirs so we can avoid-    -- compiling them at all if ghc-lib is not set-    if !flag(ghc-lib)-      hs-source-dirs:-        session-loader-      exposed-modules:-        Development.IDE.Session-      other-modules:-        Development.IDE.Session.VersionCheck     other-modules:-        Development.IDE.Core.Compile         Development.IDE.Core.FileExists         Development.IDE.GHC.CPP         Development.IDE.GHC.Warnings-        Development.IDE.Import.FindImports         Development.IDE.LSP.Notifications         Development.IDE.Plugin.CodeAction.PositionIndexed         Development.IDE.Plugin.Completions.Logic-        Development.IDE.Plugin.HLS.Formatter+        Development.IDE.Session.VersionCheck         Development.IDE.Types.Action-    ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns+    ghc-options: -Wall -Wno-name-shadowing -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors  executable ghcide-test-preprocessor     default-language: Haskell2010@@ -225,7 +207,8 @@     other-modules: Experiments.Types     build-tool-depends:         ghcide:ghcide-bench,-        hp2pretty:hp2pretty+        hp2pretty:hp2pretty,+        implicit-hie:gen-hie     default-extensions:         BangPatterns         DeriveFunctor@@ -254,8 +237,6 @@         yaml  executable ghcide-    if flag(ghc-lib)-      buildable: False     default-language:   Haskell2010     include-dirs:         include@@ -283,8 +264,8 @@         safe-exceptions,         ghc,         hashable,-        haskell-lsp,-        haskell-lsp-types,+        lsp,+        lsp-types,         heapsize,         hie-bios,         hls-plugin-api,@@ -315,13 +296,12 @@         ViewPatterns  test-suite ghcide-tests-    if flag(ghc-lib)-      buildable: False     type: exitcode-stdio-1.0     default-language: Haskell2010     build-tool-depends:         ghcide:ghcide,-        ghcide:ghcide-test-preprocessor+        ghcide:ghcide-test-preprocessor,+        implicit-hie:gen-hie     build-depends:         aeson,         base,@@ -343,12 +323,12 @@         ghcide,         ghc-typelits-knownnat,         haddock-library,-        haskell-lsp,-        haskell-lsp-types,+        lsp,+        lsp-types,         hls-plugin-api,         network-uri,         lens,-        lsp-test >= 0.12.0.0 && < 0.13,+        lsp-test == 0.13.0.0,         optparse-applicative,         process,         QuickCheck,@@ -369,7 +349,7 @@           record-hasfield     hs-source-dirs: test/cabal test/exe test/src bench/lib     include-dirs: include-    ghc-options: -threaded -Wall -Wno-name-shadowing -O0+    ghc-options: -threaded -Wall -Wno-name-shadowing -O0 -Wno-unticked-promoted-constructors     main-is: Main.hs     other-modules:         Development.IDE.Test@@ -405,7 +385,7 @@         extra,         filepath,         ghcide,-        lsp-test >= 0.12.0.0 && < 0.13,+        lsp-test == 0.13.0.0,         optparse-applicative,         process,         safe-exceptions,

@@ -8,7 +8,6 @@ module Development.IDE.Session   (SessionLoadingOptions(..)   ,CacheDirs(..)-  ,defaultLoadingOptions   ,loadSession   ,loadSessionWithOptions   ,setInitialDynFlags@@ -34,6 +33,7 @@ import Data.Aeson import Data.Bifunctor import qualified Data.ByteString.Base16 as B16+import Data.Default import Data.Either.Extra import Data.Function import Data.Hashable@@ -60,9 +60,8 @@ import HIE.Bios.Environment hiding (getCacheDir) import HIE.Bios.Types import Hie.Implicit.Cradle (loadImplicitHieCradle)-import Language.Haskell.LSP.Core-import Language.Haskell.LSP.Messages-import Language.Haskell.LSP.Types+import Language.LSP.Server+import Language.LSP.Types import System.Directory import qualified System.Directory.Extra as IO import System.FilePath@@ -99,23 +98,26 @@   --   return the path for storing generated GHC artifacts,   --   or 'Nothing' to respect the cradle setting   , getCacheDirs :: String -> [String] -> IO CacheDirs+  -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'+  , getInitialGhcLibDir :: IO (Maybe LibDir)   } -defaultLoadingOptions :: SessionLoadingOptions-defaultLoadingOptions = SessionLoadingOptions-    {findCradle = HieBios.findCradle-    ,loadCradle = HieBios.loadCradle-    ,getCacheDirs = getCacheDirsDefault-    }+instance Default SessionLoadingOptions where+    def = SessionLoadingOptions+        {findCradle = HieBios.findCradle+        ,loadCradle = HieBios.loadCradle+        ,getCacheDirs = getCacheDirsDefault+        ,getInitialGhcLibDir = getInitialGhcLibDirDefault+        } --- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir-setInitialDynFlags :: IO (Maybe LibDir)-setInitialDynFlags = do+getInitialGhcLibDirDefault :: IO (Maybe LibDir)+getInitialGhcLibDirDefault = do   dir <- IO.getCurrentDirectory   hieYaml <- runMaybeT $ yamlConfig dir-  cradle <- maybe (HieBios.loadImplicitCradle $ addTrailingPathSeparator dir) HieBios.loadCradle hieYaml+  cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) HieBios.loadCradle hieYaml+  hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle   libDirRes <- getRuntimeGhcLibDir cradle-  libdir <- case libDirRes of+  case libDirRes of       CradleSuccess libdir -> pure $ Just $ LibDir libdir       CradleFail err -> do         hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,dir,hieYaml,cradle)@@ -123,6 +125,11 @@       CradleNone -> do         hPutStrLn stderr $ "Couldn't load cradle (CradleNone)"         pure Nothing++-- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir+setInitialDynFlags :: SessionLoadingOptions -> IO (Maybe LibDir)+setInitialDynFlags SessionLoadingOptions{..} = do+  libdir <- getInitialGhcLibDir   dynFlags <- mapM dynFlagsForPrinting libdir   mapM_ setUnsafeGlobalDynFlags dynFlags   pure libdir@@ -177,7 +184,7 @@ -- components mapping to the same hie.yaml file are mapped to the same -- HscEnv which is updated as new components are discovered. loadSession :: FilePath -> IO (Action IdeGhcSession)-loadSession = loadSessionWithOptions defaultLoadingOptions+loadSession = loadSessionWithOptions def  loadSessionWithOptions :: SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession) loadSessionWithOptions SessionLoadingOptions{..} dir = do@@ -208,12 +215,11 @@   runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath])))    return $ do-    extras@ShakeExtras{logger, eventer, restartShakeSession,-                       withIndefiniteProgress, ideNc, knownTargetsVar+    extras@ShakeExtras{logger, restartShakeSession, ideNc, knownTargetsVar, lspEnv                       } <- getShakeExtras      IdeOptions{ optTesting = IdeTesting optTesting-              , optCheckProject = checkProject+              , optCheckProject = getCheckProject               , optCustomDynFlags               , optExtensions               } <- getIdeOptions@@ -358,6 +364,7 @@           restartShakeSession []            -- Typecheck all files in the project on startup+          checkProject <- getCheckProject           unless (null cs || not checkProject) $ do                 cfps' <- liftIO $ filterM (IO.doesFileExist . fromNormalizedFilePath) (concatMap targetLocations cs)                 void $ shakeEnqueue extras $ mkDelayedAction "InitialLoad" Debug $ void $ do@@ -376,17 +383,19 @@            lfp <- flip makeRelative cfp <$> getCurrentDirectory            logInfo logger $ T.pack ("Consulting the cradle for " <> show lfp) -           when (isNothing hieYaml) $ eventer $ notifyUserImplicitCradle lfp+           when (isNothing hieYaml) $ mRunLspT lspEnv $+             sendNotification SWindowShowMessage $ notifyUserImplicitCradle lfp             cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) loadCradle hieYaml -           when optTesting $ eventer $ notifyCradleLoaded lfp+           when optTesting $ mRunLspT lspEnv $+            sendNotification (SCustomMethod "ghcide/cradle/loaded") (toJSON cfp)             -- Display a user friendly progress message here: They probably don't know what a cradle is            let progMsg = "Setting up " <> T.pack (takeBaseName (cradleRootDir cradle))                          <> " (for " <> T.pack lfp <> ")"-           eopts <- withIndefiniteProgress progMsg NotCancellable $-             cradleToOptsAndLibDir cradle cfp+           eopts <- mRunLspTCallback lspEnv (withIndefiniteProgress progMsg NotCancellable) $+              cradleToOptsAndLibDir cradle cfp             logDebug logger $ T.pack ("Session loading result: " <> show eopts)            case eopts of@@ -612,7 +621,7 @@ -- For the exact reason, see Note [Avoiding bad interface files]. setCacheDirs :: MonadIO m => Logger -> CacheDirs -> DynFlags -> m DynFlags setCacheDirs logger CacheDirs{..} dflags = do-    liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir+    liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack (fromMaybe cacheDir hiCacheDir)     pure $ dflags           & maybe id setHiDir hiCacheDir           & maybe id setHieDir hieCacheDir@@ -796,24 +805,12 @@ cacheDir :: String cacheDir = "ghcide" -notifyUserImplicitCradle:: FilePath -> FromServerMessage-notifyUserImplicitCradle fp =-    NotShowMessage $-    NotificationMessage "2.0" WindowShowMessage $ ShowMessageParams MtInfo $-      "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for "-      <> T.pack fp <>-      ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n" <>-      "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error."--notifyCradleLoaded :: FilePath -> FromServerMessage-notifyCradleLoaded fp =-    NotCustomServer $-    NotificationMessage "2.0" (CustomServerMethod cradleLoadedMethod) $-    toJSON fp--cradleLoadedMethod :: T.Text-cradleLoadedMethod = "ghcide/cradle/loaded"-+notifyUserImplicitCradle:: FilePath -> ShowMessageParams+notifyUserImplicitCradle fp =ShowMessageParams MtWarning $+  "No [cradle](https://github.com/mpickering/hie-bios#hie-bios) found for "+  <> T.pack fp <>+  ".\n Proceeding with [implicit cradle](https://hackage.haskell.org/package/implicit-hie).\n"<>+  "You should ignore this message, unless you see a 'Multi Cradle: No prefixes matched' error." ----------------------------------------------------------------------------------------------------  data PackageSetupException

@@ -48,7 +48,7 @@  import HieDb -import Language.Haskell.LSP.Types (DiagnosticTag(..))+import Language.LSP.Types (DiagnosticTag(..))  import LoadIface (loadModuleInterface) import DriverPhases@@ -106,8 +106,8 @@ import Maybes (orElse)  import qualified Data.HashMap.Strict as HashMap-import qualified Language.Haskell.LSP.Messages as LSP-import qualified Language.Haskell.LSP.Types as LSP+import qualified Language.LSP.Types as LSP+import qualified Language.LSP.Server as LSP import Control.Concurrent.STM hiding (orElse) import Control.Concurrent.Extra import Data.Functor@@ -521,9 +521,9 @@             -- If the hash in the pending list doesn't match the current hash, then skip             Just pendingHash -> pendingHash /= hash         unless newerScheduled $ do-          tok <- pre+          pre           addRefsFromLoaded db targetPath (RealFile $ fromNormalizedFilePath srcPath) hash hf-          post tok+          post   where     mod_location    = ms_location mod_summary     targetPath      = Compat.ml_hie_file mod_location@@ -531,46 +531,42 @@      -- Get a progress token to report progress and update it for the current file     pre = do-      tok <- modifyVar indexProgressToken $ \case-        x@(Just tok) -> pure (x, tok)+      tok <- modifyVar indexProgressToken $ fmap dupe . \case+        x@(Just _) -> pure x         -- Create a token if we don't already have one         Nothing -> do-          u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> newUnique-          lspId <- getLspId se-          eventer se $ LSP.ReqWorkDoneProgressCreate $-            LSP.fmServerWorkDoneProgressCreateRequest lspId $-              LSP.WorkDoneProgressCreateParams { _token = u }-          eventer se $ LSP.NotWorkDoneProgressBegin $-            LSP.fmServerWorkDoneProgressBeginNotification-              LSP.ProgressParams-                  { _token = u-                  , _value = LSP.WorkDoneProgressBeginParams-                    { _title = "Indexing references from:"-                    , _cancellable = Nothing-                    , _message = Nothing-                    , _percentage = Nothing-                    }+          case lspEnv se of+            Nothing -> pure Nothing+            Just env -> LSP.runLspT env $ do+              u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique+              -- TODO: Wait for the progress create response to use the token+              _ <- LSP.sendRequest LSP.SWindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ())+              LSP.sendNotification LSP.SProgress $ LSP.ProgressParams u $+                LSP.Begin $ LSP.WorkDoneProgressBeginParams+                  { _title = "Indexing references from:"+                  , _cancellable = Nothing+                  , _message = Nothing+                  , _percentage = Nothing                   }-          pure (Just u, u)+              pure (Just u)+       (!done, !remaining) <- atomically $ do         done <- readTVar indexCompleted         remaining <- HashMap.size <$> readTVar indexPending         pure (done, remaining)+       let progress = " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..."-      eventer se $ LSP.NotWorkDoneProgressReport $-        LSP.fmServerWorkDoneProgressReportNotification-          LSP.ProgressParams-              { _token = tok-              , _value = LSP.WorkDoneProgressReportParams-                { _cancellable = Nothing-                , _message = Just $ T.pack (show srcPath) <> progress-                , _percentage = Nothing-                }-              }-      pure tok +      whenJust (lspEnv se) $ \env -> whenJust tok $ \tok -> LSP.runLspT env $+        LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $+          LSP.Report $ LSP.WorkDoneProgressReportParams+            { _cancellable = Nothing+            , _message = Just $ T.pack (show srcPath) <> progress+            , _percentage = Nothing+            }+     -- Report the progress once we are done indexing this file-    post tok = do+    post = do       mdone <- atomically $ do         -- Remove current element from pending         pending <- stateTVar indexPending $@@ -579,23 +575,20 @@         -- If we are done, report and reset completed         whenMaybe (HashMap.null pending) $           swapTVar indexCompleted 0-      when (coerce $ ideTesting se) $-        eventer se $ LSP.NotCustomServer $-          LSP.NotificationMessage "2.0" (LSP.CustomServerMethod "ghcide/reference/ready") (toJSON $ fromNormalizedFilePath srcPath)-      case mdone of-        Nothing -> pure ()-        Just done ->-          modifyVar_ indexProgressToken $ \_ -> do-            eventer se $ LSP.NotWorkDoneProgressEnd $-              LSP.fmServerWorkDoneProgressEndNotification-                LSP.ProgressParams-                    { _token = tok-                    , _value = LSP.WorkDoneProgressEndParams-                      { _message = Just $ "Finished indexing " <> T.pack (show done) <> " files"-                      }-                    }-            -- We are done with the current indexing cycle, so destroy the token-            pure Nothing+      whenJust (lspEnv se) $ \env -> LSP.runLspT env $+        when (coerce $ ideTesting se) $+          LSP.sendNotification (LSP.SCustomMethod "ghcide/reference/ready") $+            toJSON $ fromNormalizedFilePath srcPath+      whenJust mdone $ \done ->+        modifyVar_ indexProgressToken $ \tok -> do+          whenJust (lspEnv se) $ \env -> LSP.runLspT env $+            whenJust tok $ \tok ->+              LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $+                LSP.End $ LSP.WorkDoneProgressEndParams+                  { _message = Just $ "Finished indexing " <> T.pack (show done) <> " files"+                  }+          -- We are done with the current indexing cycle, so destroy the token+          pure Nothing  writeAndIndexHieFile :: HscEnv -> ShakeExtras -> ModSummary -> NormalizedFilePath -> [GHC.AvailInfo] -> HieASTs Type -> BS.ByteString -> IO [FileDiagnostic] writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source =

@@ -26,7 +26,9 @@ import           Development.Shake import           Development.Shake.Classes import           GHC.Generics-import           Language.Haskell.LSP.Types.Capabilities+import           Language.LSP.Server hiding (getVirtualFile)+import           Language.LSP.Types+import           Language.LSP.Types.Capabilities import qualified System.Directory as Dir import qualified System.FilePath.Glob as Glob @@ -148,8 +150,18 @@ -- | Installs the 'getFileExists' rules. --   Provides a fast implementation if client supports dynamic watched files. --   Creates a global state as a side effect in that case.-fileExistsRules :: ClientCapabilities -> VFSHandle -> Rules ()-fileExistsRules ClientCapabilities{_workspace} vfs = do+fileExistsRules :: Maybe (LanguageContextEnv c) -> VFSHandle -> Rules ()+fileExistsRules lspEnv vfs = do+  supportsWatchedFiles <- case lspEnv of+    Just lspEnv' -> liftIO $ runLspT lspEnv' $ do+      ClientCapabilities {_workspace} <- getClientCapabilities+      case () of+        _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace+          , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles+          , Just True <- _dynamicRegistration+          -> pure True+        _ -> pure False+    Nothing -> pure False   -- Create the global always, although it should only be used if we have fast rules.   -- But there's a chance someone will send unexpected notifications anyway,   -- e.g. https://github.com/haskell/ghcide/issues/599@@ -159,12 +171,9 @@   opts <- liftIO $ getIdeOptionsIO extras   let globs = watchedGlobs opts -  case () of-    _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace-      , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles-      , Just True <- _dynamicRegistration-        -> fileExistsRulesFast globs vfs-      | otherwise -> fileExistsRulesSlow vfs+  if supportsWatchedFiles+    then fileExistsRulesFast globs vfs+    else fileExistsRulesSlow vfs  -- Requires an lsp client that provides WatchedFiles notifications, but assumes that this has already been checked. fileExistsRulesFast :: [String] -> VFSHandle -> Rules ()

@@ -59,8 +59,9 @@  import qualified Development.IDE.Types.Logger as L -import Language.Haskell.LSP.Core-import Language.Haskell.LSP.VFS+import Language.LSP.Server hiding (getVirtualFile)+import qualified Language.LSP.Server as LSP+import Language.LSP.VFS  makeVFSHandle :: IO VFSHandle makeVFSHandle = do@@ -77,9 +78,9 @@                     Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs         } -makeLSPVFSHandle :: LspFuncs c -> VFSHandle-makeLSPVFSHandle lspFuncs = VFSHandle-    { getVirtualFile = getVirtualFileFunc lspFuncs+makeLSPVFSHandle :: LanguageContextEnv c -> VFSHandle+makeLSPVFSHandle lspEnv = VFSHandle+    { getVirtualFile = runLspT lspEnv . LSP.getVirtualFile     , setVirtualFileContents = Nothing    } @@ -179,7 +180,7 @@       Nothing -> do         foi <- use_ IsFileOfInterest f         liftIO $ case foi of-          IsFOI Modified -> getCurrentTime+          IsFOI Modified{} -> getCurrentTime           _ -> do             (large,small) <- getModTime $ fromNormalizedFilePath f             pure $ internalTimeToUTCTime large small@@ -200,7 +201,8 @@                 -> IO () setFileModified state saved nfp = do     ideOptions <- getIdeOptionsIO $ shakeExtras state-    let checkParents = case optCheckParents ideOptions of+    doCheckParents <- optCheckParents ideOptions+    let checkParents = case doCheckParents of           AlwaysCheck -> True           CheckOnSaveAndClose -> saved           _ -> False

@@ -21,7 +21,7 @@ import           Development.IDE.Core.Shake import           Development.IDE.Types.Location import           Development.Shake-import           Language.Haskell.LSP.Types+import           Language.LSP.Types import           System.FilePath (isRelative)  -- | Lsp client relevant configuration details

@@ -104,7 +104,8 @@      -- Update the exports map for non FOIs     -- We can skip this if checkProject is True, assuming they never change under our feet.-    IdeOptions{ optCheckProject = checkProject } <- getIdeOptions+    IdeOptions{ optCheckProject = doCheckProject } <- getIdeOptions+    checkProject <- liftIO doCheckProject     ifaces <- if checkProject then return Nothing else runMaybeT $ do         deps <- MaybeT $ sequence <$> uses GetDependencies files         hiResults <- lift $ uses GetModIface (nubOrd $ foldMap transitiveModuleDeps deps)

@@ -24,7 +24,7 @@  import Control.Monad import qualified Data.Text as T-import Language.Haskell.LSP.Types+import Language.LSP.Types import Data.List import Data.Algorithm.Diff import Data.Bifunctor

@@ -26,19 +26,17 @@ import Development.IDE.Types.KnownTargets import           Data.Hashable import           Data.Typeable-import qualified Data.Set as S import qualified Data.Map as M import           Development.Shake import           GHC.Generics                             (Generic) -import Module (InstalledUnitId) import HscTypes (ModGuts, hm_iface, HomeModInfo, hm_linkable)  import           Development.IDE.Spans.Common import           Development.IDE.Spans.LocalBindings import           Development.IDE.Import.FindImports (ArtifactsLocation) import Data.ByteString (ByteString)-import Language.Haskell.LSP.Types (NormalizedFilePath)+import Language.LSP.Types (NormalizedFilePath) import TcRnMonad (TcGblEnv) import qualified Data.ByteString.Char8 as BS import Development.IDE.Types.Options (IdeGhcSession)@@ -223,9 +221,8 @@ -- | A GHC session preloaded with all the dependencies type instance RuleResult GhcSessionDeps = HscEnvEq --- | Resolve the imports in a module to the file path of a module--- in the same package or the package id of another package.-type instance RuleResult GetLocatedImports = ([(Located ModuleName, Maybe ArtifactsLocation)], S.Set InstalledUnitId)+-- | Resolve the imports in a module to the file path of a module in the same package+type instance RuleResult GetLocatedImports = [(Located ModuleName, Maybe ArtifactsLocation)]  -- | This rule is used to report import cycles. It depends on GetDependencyInformation. -- We cannot report the cycles directly from GetDependencyInformation since@@ -296,7 +293,10 @@ instance Binary   GetFileContents  -data FileOfInterestStatus = OnDisk | Modified+data FileOfInterestStatus+  = OnDisk+  | Modified { firstOpen :: !Bool -- ^ was this file just opened+             }   deriving (Eq, Show, Typeable, Generic) instance Hashable FileOfInterestStatus instance NFData   FileOfInterestStatus

@@ -57,14 +57,17 @@     getBindingsRule,     needsCompilationRule,     generateCoreRule,-    getImportMapRule+    getImportMapRule,+    regenerateHiFile,+    ghcSessionDepsDefinition,+    getParsedModuleDefinition,+    typeCheckRuleDefinition,     ) where  import Fingerprint -import Data.Aeson (fromJSON,toJSON, Result(Success), FromJSON)+import Data.Aeson (toJSON, Result(Success)) import Data.Binary hiding (get, put)-import Data.Default import Data.Tuple.Extra import Control.Monad.Extra import Control.Monad.Trans.Class@@ -83,7 +86,6 @@ import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule, writeHieFile, TargetModule, TargetFile) import Development.IDE.GHC.ExactPrint import Development.IDE.GHC.Util-import Data.Either.Extra import qualified Development.IDE.Types.Logger as L import Data.Maybe import           Data.Foldable@@ -99,10 +101,9 @@ import Development.IDE.Core.RuleTypes import qualified Data.ByteString.Char8 as BS import Development.IDE.Core.PositionMapping-import           Language.Haskell.LSP.Types (DocumentHighlight (..), SymbolInformation(..))-import Language.Haskell.LSP.VFS-import qualified Language.Haskell.LSP.Messages as LSP-import qualified Language.Haskell.LSP.Types as LSP+import           Language.LSP.Types (DocumentHighlight (..), SymbolInformation(..), SMethod(SCustomMethod))+import qualified Language.LSP.Server as LSP+import Language.LSP.VFS  import qualified GHC.LanguageExtensions as LangExt import HscTypes hiding (TargetModule, TargetFile)@@ -136,6 +137,8 @@ import Data.ByteString.Encoding as T  import qualified HieDb+import Ide.Plugin.Config+import qualified Data.Aeson.Types as A  -- | This is useful for rules to convert rules that can only produce errors or -- a result into the more general IdeResult type that supports producing@@ -402,17 +405,11 @@         (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do             diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetExists modName mbPkgName isSource             case diagOrImp of-                Left diags -> pure (diags, Left (modName, Nothing))-                Right (FileImport path) -> pure ([], Left (modName, Just path))-                Right (PackageImport pkgId) -> liftIO $ do-                    diagsOrPkgDeps <- computePackageDeps env pkgId-                    case diagsOrPkgDeps of-                        Left diags -> pure (diags, Right Nothing)-                        Right pkgIds -> pure ([], Right $ Just $ pkgId : pkgIds)-        let (moduleImports, pkgImports) = partitionEithers imports'-        case sequence pkgImports of-            Nothing -> pure (concat diags, Nothing)-            Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))+                Left diags -> pure (diags, Just (modName, Nothing))+                Right (FileImport path) -> pure ([], Just (modName, Just path))+                Right PackageImport -> pure ([], Nothing)+        let moduleImports = catMaybes imports'+        pure (concat diags, Just moduleImports)  type RawDepM a = StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action a @@ -427,19 +424,23 @@ -- imports recursively. rawDependencyInformation :: [NormalizedFilePath] -> Action RawDependencyInformation rawDependencyInformation fs = do-    (rdi, ss) <- execRawDepM (mapM_ go fs)+    (rdi, ss) <- execRawDepM (goPlural fs)     let bm = IntMap.foldrWithKey (updateBootMap rdi) IntMap.empty ss     return (rdi { rawBootMap = bm })   where+    goPlural ff = do+        mss <- lift $ (fmap.fmap) fst <$> uses GetModSummaryWithoutTimestamps ff+        zipWithM go ff mss+     go :: NormalizedFilePath -- ^ Current module being processed+       -> Maybe ModSummary   -- ^ ModSummary of the module        -> StateT (RawDependencyInformation, IntMap ArtifactsLocation) Action FilePathId-    go f = do+    go f msum = do       -- First check to see if we have already processed the FilePath       -- If we have, just return its Id but don't update any of the state.       -- Otherwise, we need to process its imports.       checkAlreadyProcessed f $ do-          msum <- lift $ fmap fst <$> use GetModSummaryWithoutTimestamps f-          let al =  modSummaryToArtifactsLocation f msum+          let al = modSummaryToArtifactsLocation f msum           -- Get a fresh FilePathId for the new file           fId <- getFreshFid al           -- Adding an edge to the bootmap so we can make sure to@@ -454,19 +455,19 @@             -- elements in the queue               modifyRawDepInfo (insertImport fId (Left ModuleParseError))               return fId-            Just (modImports, pkgImports) -> do+            Just modImports -> do               -- Get NFPs of the imports which have corresponding files               -- Imports either come locally from a file or from a package.               let (no_file, with_file) = splitImports modImports                   (mns, ls) = unzip with_file               -- Recursively process all the imports we just learnt about               -- and get back a list of their FilePathIds-              fids <- mapM (go . artifactFilePath) ls+              fids <- goPlural $ map artifactFilePath ls               -- Associate together the ModuleName with the FilePathId               let moduleImports' = map (,Nothing) no_file ++ zip mns (map Just fids)               -- Insert into the map the information about this modules               -- imports.-              modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports' pkgImports)+              modifyRawDepInfo $ insertImport fId (Right $ ModuleImports moduleImports')               return fId  @@ -593,10 +594,10 @@    isFoi <- use_ IsFileOfInterest f   diagsWrite <- case isFoi of-    IsFOI Modified -> do-      when (coerce $ ideTesting se) $-        liftIO $ eventer se $ LSP.NotCustomServer $-          LSP.NotificationMessage "2.0" (LSP.CustomServerMethod "ghcide/reference/ready") (toJSON $ fromNormalizedFilePath f)+    IsFOI Modified{firstOpen = False} -> do+      when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $+        LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $+          toJSON $ fromNormalizedFilePath f       pure []     _ | Just asts <- masts -> do           source <- getSourceFileSource f@@ -612,7 +613,7 @@ getImportMapRule :: Rules () getImportMapRule = define $ \GetImportMap f -> do   im <- use GetLocatedImports f-  let mkImports (fileImports, _) = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports+  let mkImports fileImports = M.fromList $ mapMaybe (\(m, mfp) -> (unLoc m,) . artifactFilePath <$> mfp) fileImports   pure ([], ImportMap . mkImports <$> im)  -- | Ensure that go to definition doesn't block on startup@@ -636,17 +637,7 @@       (hscEnv -> hsc, _)        <- useWithStale_ GhcSessionDeps file       (HAR{refMap=rf}, _)       <- useWithStale_ GetHieAst file --- When possible, rely on the haddocks embedded in our interface files--- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'-#if !defined(GHC_LIB)-      let parsedDeps = []-#else-      deps <- fromMaybe (TransitiveDependencies [] [] []) <$> use GetDependencies file-      let tdeps = transitiveModuleDeps deps-      parsedDeps <- uses_ GetParsedModule tdeps-#endif--      dkMap <- liftIO $ mkDocMap hsc parsedDeps rf tc+      dkMap <- liftIO $ mkDocMap hsc rf tc       return ([],Just dkMap)  -- | Persistent rule to ensure that hover doesn't block on startup@@ -665,7 +656,7 @@ readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction HieFile readHieFileFromDisk hie_loc = do   nc <- asks ideNc-  log <- asks $ L.logInfo . logger+  log <- asks $ L.logDebug . logger   res <- liftIO $ tryAny $ loadHieFile (mkUpdater nc) hie_loc   liftIO . log $ either (const $ "FAILED LOADING HIE FILE FOR:" <> T.pack (show hie_loc))                         (const $ "SUCCEEDED LOADING HIE FILE FOR:" <> T.pack (show hie_loc))@@ -826,9 +817,9 @@       | hash == HieDb.modInfoHash (HieDb.hieModInfo row)       , hie_loc == HieDb.hieModuleHieFile row  -> do       -- All good, the db has indexed the file-      when (coerce $ ideTesting se) $-        liftIO $ eventer se $ LSP.NotCustomServer $-          LSP.NotificationMessage "2.0" (LSP.CustomServerMethod "ghcide/reference/ready") (toJSON $ fromNormalizedFilePath f)+      when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $+        LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $+          toJSON $ fromNormalizedFilePath f     -- Not in db, must re-index     _ -> do       ehf <- liftIO $ runIdeAction "GetModIfaceFromDiskAndIndex" se $ runExceptT $@@ -838,7 +829,7 @@         Left err -> fail $ "failed to read .hie file " ++ show hie_loc ++ ": " ++ displayException err         -- can just re-index the file we read from disk         Right hf -> liftIO $ do-          L.logInfo (logger se) $ "Re-indexing hie file for" <> T.pack (show f)+          L.logDebug (logger se) $ "Re-indexing hie file for" <> T.pack (show f)           indexHieFile se ms f hash hf    let fp = hiFileFingerPrint x@@ -857,7 +848,7 @@             if modificationTime x < modificationTime modVersion                 then pure SourceModified                 else do-                    (fileImports, _) <- use_ GetLocatedImports f+                    fileImports <- use_ GetLocatedImports f                     let imports = fmap artifactFilePath . snd <$> fileImports                     deps <- uses_ IsHiFileStable (catMaybes imports)                     pure $ if all (== SourceUnmodifiedAndStable) deps@@ -924,7 +915,6 @@  getModIfaceRule :: Rules () getModIfaceRule = defineEarlyCutoff $ \GetModIface f -> do-#if !defined(GHC_LIB)   fileOfInterest <- use_ IsFileOfInterest f   res@(_,(_,mhmi)) <- case fileOfInterest of     IsFOI status -> do@@ -951,13 +941,6 @@       compiledLinkables <- getCompiledLinkables <$> getIdeGlobalAction       liftIO $ modifyVar_ compiledLinkables $ \old -> pure $ extendModuleEnv old mod time   pure res-#else-    tm <- use_ TypeCheck f-    hsc <- hscEnv <$> use_ GhcSessionDeps f-    (diags, !hiFile) <- liftIO $ compileToObjCodeIfNeeded hsc Nothing (error "can't compile with ghc-lib") tm-    let fp = hiFileFingerPrint <$> hiFile-    return (fp, (diags, hiFile))-#endif  getModIfaceWithoutLinkableRule :: Rules () getModIfaceWithoutLinkableRule = defineEarlyCutoff $ \GetModIfaceWithoutLinkable f -> do@@ -1047,12 +1030,13 @@  -- | Returns the client configurarion stored in the IdeState. -- You can use this function to access it from shake Rules-getClientConfigAction :: (Default a, FromJSON a) => Action a-getClientConfigAction = do+getClientConfigAction :: Config -- ^ default value+                      -> Action Config+getClientConfigAction defValue = do   mbVal <- unhashed <$> useNoFile_ GetClientSettings-  case fromJSON <$> mbVal of+  case A.parse (parseConfig defValue) <$> mbVal of     Just (Success c) -> return c-    _ -> return def+    _ -> return defValue  -- | For now we always use bytecode getLinkableType :: NormalizedFilePath -> Action (Maybe LinkableType)

@@ -25,9 +25,9 @@ import           Development.IDE.Core.OfInterest import Development.IDE.Types.Logger as Logger import           Development.Shake-import qualified Language.Haskell.LSP.Messages as LSP-import qualified Language.Haskell.LSP.Types as LSP-import qualified Language.Haskell.LSP.Types.Capabilities as LSP+import qualified Language.LSP.Server as LSP+import qualified Language.LSP.Types as LSP+import           Ide.Plugin.Config  import           Development.IDE.Core.Shake import Control.Monad@@ -37,12 +37,8 @@ -- Exposed API  -- | Initialise the Compiler Service.-initialise :: LSP.ClientCapabilities-           -> Rules ()-           -> IO LSP.LspId-           -> (LSP.FromServerMessage -> IO ())-           -> WithProgressFunc-           -> WithIndefiniteProgressFunc+initialise :: Rules ()+           -> Maybe (LSP.LanguageContextEnv Config)            -> Logger            -> Debouncer LSP.NormalizedUri            -> IdeOptions@@ -50,13 +46,9 @@            -> HieDb            -> IndexQueue            -> IO IdeState-initialise caps mainRule getLspId toDiags wProg wIndefProg logger debouncer options vfs hiedb hiedbChan =+initialise mainRule lspEnv logger debouncer options vfs hiedb hiedbChan =     shakeOpen-        getLspId-        toDiags-        wProg-        wIndefProg-        caps+        lspEnv         logger         debouncer         (optShakeProfiling options)@@ -70,7 +62,7 @@             addIdeGlobal $ GlobalIdeOptions options             fileStoreRules vfs             ofInterestRules-            fileExistsRules caps vfs+            fileExistsRules lspEnv vfs             mainRule  writeProfile :: IdeState -> FilePath -> IO ()

@@ -7,6 +7,7 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE PolyKinds #-}  -- | A Shake implementation of the compiler service. --@@ -39,6 +40,7 @@     BadDependency(..),     define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,     getDiagnostics,+    mRunLspT, mRunLspTCallback,     getHiddenDiagnostics,     IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,     getIdeGlobalExtras,@@ -48,7 +50,6 @@     garbageCollect,     knownTargets,     setPriority,-    sendEvent,     ideLogger,     actionLogger,     FileVersion(..),@@ -97,7 +98,7 @@ import Development.IDE.Types.KnownTargets import Development.IDE.Types.Shake import qualified Development.IDE.Types.Logger as Logger-import Language.Haskell.LSP.Diagnostics+import Language.LSP.Diagnostics import qualified Data.SortedList as SL import           Development.IDE.Types.Diagnostics import Development.IDE.Types.Exports@@ -107,19 +108,16 @@ import           Control.Concurrent.Extra import           Control.Concurrent.STM import           Control.DeepSeq-import           Control.Exception.Extra import           System.Time.Extra import           Data.Typeable-import qualified Language.Haskell.LSP.Core as LSP-import qualified Language.Haskell.LSP.Messages as LSP-import qualified Language.Haskell.LSP.Types as LSP+import qualified Language.LSP.Server as LSP+import qualified Language.LSP.Types as LSP import           System.FilePath hiding (makeRelative) import qualified Development.Shake as Shake import           Control.Monad.Extra import           Data.Time import           GHC.Generics-import           System.IO.Unsafe-import Language.Haskell.LSP.Types+import Language.LSP.Types import qualified Control.Monad.STM as STM import Control.Monad.IO.Class import Control.Monad.Reader@@ -127,17 +125,21 @@ import Data.Traversable import Data.Hashable import Development.IDE.Core.Tracing-import Language.Haskell.LSP.VFS+import Language.LSP.VFS  import Data.IORef import NameCache import UniqSupply import PrelInfo-import Language.Haskell.LSP.Types.Capabilities+import Language.LSP.Types.Capabilities import OpenTelemetry.Eventlog import GHC.Fingerprint  import HieDb.Types+import           Control.Exception.Extra hiding (bracket_)+import UnliftIO.Exception (bracket_)+import           Ide.Plugin.Config+import Data.Default  -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by@@ -156,7 +158,8 @@  -- information we stash inside the shakeExtra field data ShakeExtras = ShakeExtras-    {eventer :: LSP.FromServerMessage -> IO ()+    { --eventer :: LSP.FromServerMessage -> IO ()+     lspEnv :: Maybe (LSP.LanguageContextEnv Config)     ,debouncer :: Debouncer NormalizedUri     ,logger :: Logger     ,globals :: Var (HMap.HashMap TypeRep Dynamic)@@ -174,15 +177,10 @@     ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int)     -- ^ How many rules are running for each file     ,progressUpdate :: ProgressEvent -> IO ()-    -- ^ The generator for unique Lsp identifiers     ,ideTesting :: IdeTesting     -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants     ,session :: MVar ShakeSession     -- ^ Used in the GhcSession rule to forcefully restart the session after adding a new component-    ,withProgress           :: WithProgressFunc-    -- ^ Report progress about some long running operation (on top of the progress shown by 'lspShakeProgress')-    ,withIndefiniteProgress :: WithIndefiniteProgressFunc-    -- ^ Same as 'withProgress', but for processes that do not report the percentage complete     ,restartShakeSession :: [DelayedAction ()] -> IO ()     ,ideNc :: IORef NameCache     -- | A mapping of module name to known target (or candidate targets, if missing)@@ -197,12 +195,11 @@     , persistentKeys :: Var (HMap.HashMap Key GetStalePersistent)       -- ^ Registery for functions that compute/get "stale" results for the rule       -- (possibly from disk)-    , getLspId :: IO LspId     , vfs :: VFSHandle     }  type WithProgressFunc = forall a.-    T.Text -> LSP.ProgressCancellable -> ((LSP.Progress -> IO ()) -> IO a) -> IO a+    T.Text -> LSP.ProgressCancellable -> ((LSP.ProgressAmount -> IO ()) -> IO a) -> IO a type WithIndefiniteProgressFunc = forall a.     T.Text -> LSP.ProgressCancellable -> IO a -> IO a @@ -373,29 +370,24 @@     ,shakeSession    :: MVar ShakeSession     ,shakeClose      :: IO ()     ,shakeExtras     :: ShakeExtras-    ,shakeProfileDir :: Maybe FilePath+    ,shakeDatabaseProfile :: ShakeDatabase -> IO (Maybe FilePath)     ,stopProgressReporting :: IO ()     }    -- This is debugging code that generates a series of profiles, if the Boolean is true-shakeDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> IO (Maybe FilePath)-shakeDatabaseProfile mbProfileDir shakeDb =+shakeDatabaseProfileIO :: Maybe FilePath -> IO(ShakeDatabase -> IO (Maybe FilePath))+shakeDatabaseProfileIO mbProfileDir = do+    profileStartTime <- formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime+    profileCounter <- newVar (0::Int)+    return $ \shakeDb ->         for mbProfileDir $ \dir -> do                 count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)                 let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) <.> "html"                 shakeProfileDatabase shakeDb $ dir </> file                 return (dir </> file) -{-# NOINLINE profileStartTime #-}-profileStartTime :: String-profileStartTime = unsafePerformIO $ formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime--{-# NOINLINE profileCounter #-}-profileCounter :: Var Int-profileCounter = unsafePerformIO $ newVar 0- setValues :: IdeRule k v           => Var Values           -> k@@ -452,11 +444,7 @@     Failed _ -> b  -- | Open a 'IdeState', should be shut using 'shakeShut'.-shakeOpen :: IO LSP.LspId-          -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler-          -> WithProgressFunc-          -> WithIndefiniteProgressFunc-          -> ClientCapabilities+shakeOpen :: Maybe (LSP.LanguageContextEnv Config)           -> Logger           -> Debouncer NormalizedUri           -> Maybe FilePath@@ -468,8 +456,9 @@           -> ShakeOptions           -> Rules ()           -> IO IdeState-shakeOpen getLspId eventer withProgress withIndefiniteProgress clientCapabilities logger debouncer+shakeOpen lspEnv logger debouncer   shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) hiedb indexQueue vfs opts rules = mdo+     inProgress <- newVar HMap.empty     us <- mkSplitUniqSupply 'r'     ideNc <- newIORef (initNameCache us knownKeyNames)@@ -497,6 +486,8 @@          actionQueue <- newQueue +        let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv+         pure (ShakeExtras{..}, cancel progressAsync)     (shakeDbM, shakeClose) <-         shakeOpenDatabase@@ -505,6 +496,7 @@     shakeDb <- shakeDbM     initSession <- newSession shakeExtras shakeDb []     shakeSession <- newMVar initSession+    shakeDatabaseProfile <- shakeDatabaseProfileIO shakeProfileDir     let ideState = IdeState{..}      IdeOptions{ optOTMemoryProfiling = IdeOTMemoryProfiling otProfilingEnabled } <- getIdeOptionsIO shakeExtras@@ -526,7 +518,7 @@                     case v of                         KickCompleted -> STM.retry                         KickStarted -> return ()-                asyncReporter <- async lspShakeProgress+                asyncReporter <- async $ mRunLspT lspEnv lspShakeProgress                 progressLoopReporting asyncReporter             progressLoopReporting asyncReporter = do                 atomically $ do@@ -537,54 +529,55 @@                 cancel asyncReporter                 progressLoopIdle +            lspShakeProgress :: LSP.LspM config ()             lspShakeProgress = do                 -- first sleep a bit, so we only show progress messages if it's going to take                 -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)-                unless testing $ sleep 0.1-                lspId <- getLspId-                u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique-                eventer $ LSP.ReqWorkDoneProgressCreate $-                  LSP.fmServerWorkDoneProgressCreateRequest lspId $-                    LSP.WorkDoneProgressCreateParams { _token = u }-                bracket_ (start u) (stop u) (loop u Nothing)+                liftIO $ unless testing $ sleep 0.1+                u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique++                void $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate+                    LSP.WorkDoneProgressCreateParams { _token = u } $ const (pure ())++                bracket_+                  (start u)+                  (stop u)+                  (loop u Nothing)                 where-                    start id = eventer $ LSP.NotWorkDoneProgressBegin $-                      LSP.fmServerWorkDoneProgressBeginNotification+                    start id = LSP.sendNotification LSP.SProgress $                         LSP.ProgressParams                             { _token = id-                            , _value = WorkDoneProgressBeginParams+                            , _value = LSP.Begin $ WorkDoneProgressBeginParams                               { _title = "Processing"                               , _cancellable = Nothing                               , _message = Nothing                               , _percentage = Nothing                               }                             }-                    stop id = eventer $ LSP.NotWorkDoneProgressEnd $-                      LSP.fmServerWorkDoneProgressEndNotification+                    stop id = LSP.sendNotification LSP.SProgress                         LSP.ProgressParams                             { _token = id-                            , _value = WorkDoneProgressEndParams+                            , _value = LSP.End WorkDoneProgressEndParams                               { _message = Nothing                               }                             }                     sample = 0.1                     loop id prev = do-                        sleep sample-                        current <- readVar inProgress+                        liftIO $ sleep sample+                        current <- liftIO $ readVar inProgress                         let done = length $ filter (== 0) $ HMap.elems current                         let todo = HMap.size current                         let next = Just $ T.pack $ show done <> "/" <> show todo                         when (next /= prev) $-                            eventer $ LSP.NotWorkDoneProgressReport $-                              LSP.fmServerWorkDoneProgressReportNotification-                                LSP.ProgressParams-                                    { _token = id-                                    , _value = LSP.WorkDoneProgressReportParams-                                    { _cancellable = Nothing-                                    , _message = next-                                    , _percentage = Nothing-                                    }-                                    }+                          LSP.sendNotification LSP.SProgress $+                          LSP.ProgressParams+                              { _token = id+                              , _value = LSP.Report $ LSP.WorkDoneProgressReportParams+                                { _cancellable = Nothing+                                , _message = next+                                , _percentage = Nothing+                                }+                              }                         loop id next  shakeProfile :: IdeState -> FilePath -> IO ()@@ -630,7 +623,7 @@         shakeSession         (\runner -> do               (stopTime,()) <- duration (cancelShakeSession runner)-              res <- shakeDatabaseProfile shakeProfileDir shakeDb+              res <- shakeDatabaseProfile shakeDb               let profile = case res of                       Just fp -> ", profile saved at " <> fp                       _ -> ""@@ -648,9 +641,8 @@ notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO () notifyTestingLogMessage extras msg = do     (IdeTesting isTestMode) <- optTesting <$> getIdeOptionsIO extras-    let notif = LSP.NotLogMessage $ LSP.NotificationMessage "2.0" LSP.WindowLogMessage-                                  $ LSP.LogMessageParams LSP.MtLog msg-    when isTestMode $ eventer extras notif+    let notif = LSP.LogMessageParams LSP.MtLog msg+    when isTestMode $ mRunLspT (lspEnv extras) $ LSP.sendNotification LSP.SWindowLogMessage notif   -- | Enqueue an action in the existing 'ShakeSession'.@@ -742,6 +734,18 @@       d' = DelayedAction (Just u) s p a'   return (b, d') +mRunLspT :: Applicative m => Maybe (LSP.LanguageContextEnv c ) -> LSP.LspT c m () -> m ()+mRunLspT (Just lspEnv) f = LSP.runLspT lspEnv f+mRunLspT Nothing _ = pure ()++mRunLspTCallback :: Monad m+                 => Maybe (LSP.LanguageContextEnv c)+                 -> (LSP.LspT c m a -> LSP.LspT c m a)+                 -> m a+                 -> m a+mRunLspTCallback (Just lspEnv) f g = LSP.runLspT lspEnv $ f (lift g)+mRunLspTCallback Nothing _ g = g+ getDiagnostics :: IdeState -> IO [FileDiagnostic] getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do     val <- readVar diagnostics@@ -1027,7 +1031,7 @@   -> ShakeExtras   -> [(ShowDiagnostic,Diagnostic)] -- ^ current results   -> m ()-updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do+updateFileDiagnostics fp k ShakeExtras{logger, diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, lspEnv} current = liftIO $ do     modTime <- (currentValue . fst =<<) <$> getValues state GetModificationTime fp     let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current         uri = filePathToUri' fp@@ -1048,25 +1052,18 @@         registerEvent debouncer delay uri $ do              mask_ $ modifyVar_ publishedDiagnostics $ \published -> do                  let lastPublish = HMap.lookupDefault [] uri published-                 when (lastPublish /= newDiags) $-                     eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags+                 when (lastPublish /= newDiags) $ case lspEnv of+                   Nothing -> -- Print an LSP event.+                     logInfo logger $ showDiagnosticsColored $ map (fp,ShowDiag,) newDiags+                   Just env -> LSP.runLspT env $+                     LSP.sendNotification LSP.STextDocumentPublishDiagnostics $+                       LSP.PublishDiagnosticsParams (fromNormalizedUri uri) ver (List newDiags)                  pure $! HMap.insert uri newDiags published -publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage-publishDiagnosticsNotification uri diags =-    LSP.NotPublishDiagnostics $-    LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $-    LSP.PublishDiagnosticsParams uri (List diags)- newtype Priority = Priority Double  setPriority :: Priority -> Action () setPriority (Priority p) = reschedule p--sendEvent :: LSP.FromServerMessage -> Action ()-sendEvent e = do-    ShakeExtras{eventer} <- getShakeExtras-    liftIO $ eventer e  ideLogger :: IdeState -> Logger ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-} #include "ghc-api-version.h" module Development.IDE.Core.Tracing     ( otTracedHandler@@ -28,11 +27,11 @@                                                  GhcSessionIO (GhcSessionIO)) import           Development.IDE.Types.Logger   (logInfo, Logger, logDebug) import           Development.IDE.Types.Shake    (ValueWithDiagnostics(..), Key (..), Value, Values)-import           Development.Shake              (Action, actionBracket, liftIO)+import           Development.Shake              (Action, actionBracket) import           Ide.PluginUtils                (installSigUsr1Handler) import           Foreign.Storable               (Storable (sizeOf)) import           HeapSize                       (recursiveSize, runHeapsize)-import           Language.Haskell.LSP.Types     (NormalizedFilePath,+import           Language.LSP.Types             (NormalizedFilePath,                                                  fromNormalizedFilePath) import           Numeric.Natural                (Natural) import           OpenTelemetry.Eventlog         (SpanInFlight, Synchronicity(Asynchronous), Instrument, addEvent, beginSpan, endSpan,@@ -42,20 +41,24 @@ import Data.Text.Encoding (encodeUtf8) import Ide.Types (PluginId (..)) import Development.IDE.Types.Location (Uri (..))+import Control.Monad.IO.Unlift  -- | Trace a handler using OpenTelemetry. Adds various useful info into tags in the OpenTelemetry span. otTracedHandler-    :: String -- ^ Message type+    :: MonadUnliftIO m+    => String -- ^ Message type     -> String -- ^ Message label-    -> (SpanInFlight -> IO a)-    -> IO a+    -> (SpanInFlight -> m a)+    -> m a otTracedHandler requestType label act =   let !name =         if null label           then requestType           else requestType <> ":" <> show label    -- Add an event so all requests can be quickly seen in the viewer without searching-   in withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> act sp)+   in do+     runInIO <- askRunInIO+     liftIO $ withSpan (fromString name) (\sp -> addEvent sp "" (fromString $ name <> " received") >> runInIO (act sp))  otSetUri :: SpanInFlight -> Uri -> IO () otSetUri sp (Uri t) = setTag sp "uri" (encodeUtf8 t)@@ -81,14 +84,15 @@         return res)  #if MIN_GHC_API_VERSION(8,8,0)-otTracedProvider :: PluginId -> ByteString -> IO a -> IO a+otTracedProvider :: MonadUnliftIO m => PluginId -> ByteString -> m a -> m a #else-otTracedProvider :: PluginId -> String -> IO a -> IO a+otTracedProvider :: MonadUnliftIO m => PluginId -> String -> m a -> m a #endif-otTracedProvider (PluginId pluginName) provider act =-  withSpan (provider <> " provider") $ \sp -> do+otTracedProvider (PluginId pluginName) provider act = do+  runInIO <- askRunInIO+  liftIO $ withSpan (provider <> " provider") $ \sp -> do     setTag sp "plugin" (encodeUtf8 pluginName)-    act+    runInIO act  startTelemetry :: Bool -> Logger -> Var Values -> IO () startTelemetry allTheTime logger stateRef = do

@@ -1,19 +1,24 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP                #-} {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RankNTypes         #-}+{-# LANGUAGE TypeFamilies       #-} +{- HLINT ignore "Use zipFrom" -}+ module Development.IDE.GHC.ExactPrint     ( Graft(..),       graft,+      graftWithoutParentheses,       graftDecls,       graftDeclsWithM,       annotate,       hoistGraft,       graftWithM,       graftWithSmallestM,+      graftSmallestDecls,+      graftSmallestDeclsWithM,       transform,       transformM,       useAnnotatedSource,@@ -54,14 +59,22 @@ import Ide.PluginUtils import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers-import Language.Haskell.LSP.Types-import Language.Haskell.LSP.Types.Capabilities (ClientCapabilities)+import Language.LSP.Types+import Language.LSP.Types.Capabilities (ClientCapabilities) import Outputable (Outputable, ppr, showSDoc) import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, parseType) import Parser (parseIdentifier)+import Data.Traversable (for)+import Data.Foldable (Foldable(fold))+import Data.Bool (bool) #if __GLASGOW_HASKELL__ == 808 import Control.Arrow #endif+#if __GLASGOW_HASKELL__ > 808+import Bag (listToBag)+import ErrUtils (mkErrMsg)+import Outputable (text, neverQualify)+#endif   ------------------------------------------------------------------------------@@ -179,8 +192,18 @@     SrcSpan ->     Located ast ->     Graft (Either String) a-graft dst val = Graft $ \dflags a -> do-    (anns, val') <- annotate dflags $ maybeParensAST val+graft dst = graftWithoutParentheses dst . maybeParensAST++-- | Like 'graft', but trusts that you have correctly inserted the parentheses+-- yourself. If you haven't, the resulting AST will not be valid!+graftWithoutParentheses ::+    forall ast a.+    (Data a, ASTElement ast) =>+    SrcSpan ->+    Located ast ->+    Graft (Either String) a+graftWithoutParentheses dst val = Graft $ \dflags a -> do+    (anns, val') <- annotate dflags val     modifyAnnsT $ mappend anns     pure $         everywhere'@@ -191,6 +214,7 @@             )             a + ------------------------------------------------------------------------------  graftWithM ::@@ -260,6 +284,44 @@             | otherwise = DL.singleton (L src e) <> go rest     modifyDeclsT (pure . DL.toList . go) a +graftSmallestDecls ::+    forall a.+    (HasDecls a) =>+    SrcSpan ->+    [LHsDecl GhcPs] ->+    Graft (Either String) a+graftSmallestDecls dst decs0 = Graft $ \dflags a -> do+    decs <- forM decs0 $ \decl -> do+        (anns, decl') <- annotateDecl dflags decl+        modifyAnnsT $ mappend anns+        pure decl'+    let go [] = DL.empty+        go (L src e : rest)+            | dst `isSubspanOf` src = DL.fromList decs <> DL.fromList rest+            | otherwise = DL.singleton (L src e) <> go rest+    modifyDeclsT (pure . DL.toList . go) a++graftSmallestDeclsWithM ::+    forall a.+    (HasDecls a) =>+    SrcSpan ->+    (LHsDecl GhcPs -> TransformT (Either String) (Maybe [LHsDecl GhcPs])) ->+    Graft (Either String) a+graftSmallestDeclsWithM dst toDecls = Graft $ \dflags a -> do+    let go [] = pure DL.empty+        go (e@(L src _) : rest)+            | dst `isSubspanOf` src = toDecls e >>= \case+                Just decs0 -> do+                    decs <- forM decs0 $ \decl -> do+                        (anns, decl') <-+                            annotateDecl dflags decl+                        modifyAnnsT $ mappend anns+                        pure decl'+                    pure $ DL.fromList decs <> DL.fromList rest+                Nothing -> (DL.singleton e <>) <$> go rest+            | otherwise = (DL.singleton e <>) <$> go rest+    modifyDeclsT (fmap DL.toList . go) a+ graftDeclsWithM ::     forall a m.     (HasDecls a, Fail.MonadFail m) =>@@ -344,12 +406,37 @@  -- | Given an 'LHsDecl', compute its exactprint annotations. annotateDecl :: DynFlags -> LHsDecl GhcPs -> TransformT (Either String) (Anns, LHsDecl GhcPs)+-- The 'parseDecl' function fails to parse 'FunBind' 'ValD's which contain+-- multiple matches. To work around this, we split the single+-- 'FunBind'-of-multiple-'Match'es into multiple 'FunBind's-of-one-'Match',+-- and then merge them all back together.+annotateDecl dflags+            (L src (+                ValD ext fb@FunBind+                  { fun_matches = mg@MG { mg_alts = L alt_src alts@(_:_)}+                  })) = do+    let set_matches matches =+          ValD ext fb { fun_matches = mg { mg_alts = L alt_src matches }}++    (anns', alts') <- fmap unzip $ for (zip [0..] alts) $ \(ix :: Int, alt) -> do+      uniq <- show <$> uniqueSrcSpanT+      let rendered = render dflags $ set_matches [alt]+      lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case+        (ann, L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}}))+           -> pure (bool id (setPrecedingLines alt' 1 0) (ix /= 0) ann, alt')+        _ ->  lift $ Left "annotateDecl: didn't parse a single FunBind match"++    let expr' = L src $ set_matches alts'+        anns'' = setPrecedingLines expr' 1 0 $ fold anns'++    pure (anns'', expr') annotateDecl dflags ast = do     uniq <- show <$> uniqueSrcSpanT     let rendered = render dflags ast     (anns, expr') <- lift $ mapLeft show $ parseDecl dflags uniq rendered     let anns' = setPrecedingLines expr' 1 0 anns     pure (anns', expr')+ ------------------------------------------------------------------------------  -- | Print out something 'Outputable'.

@@ -1,5 +1,6 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0+{-# LANGUAGE ExplicitNamespaces #-}  module Development.IDE.GHC.Warnings(withWarnings) where @@ -12,7 +13,7 @@  import           Development.IDE.Types.Diagnostics import           Development.IDE.GHC.Error-import           Language.Haskell.LSP.Types (NumberOrString (StringValue))+import           Language.LSP.Types (type (|?)(..))   -- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some@@ -36,7 +37,7 @@   return (reverse $ concat warns, res)  attachReason :: WarnReason -> Diagnostic -> Diagnostic-attachReason wr d = d{_code = StringValue <$> showReason wr}+attachReason wr d = d{_code = InR <$> showReason wr}  where   showReason = \case     NoReason -> Nothing

@@ -46,8 +46,6 @@ import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as Set import GHC.Generics (Generic)  import Development.IDE.Types.Diagnostics@@ -55,15 +53,12 @@ import Development.IDE.Import.FindImports (ArtifactsLocation(..))  import GHC-import Module  -- | The imports for a given module.-data ModuleImports = ModuleImports-    { moduleImports :: ![(Located ModuleName, Maybe FilePathId)]+newtype ModuleImports = ModuleImports+    { moduleImports :: [(Located ModuleName, Maybe FilePathId)]     -- ^ Imports of a module in the current package and the file path of     -- that module on disk (if we found it)-    , packageImports :: !(Set InstalledUnitId)-    -- ^ Transitive package dependencies unioned for all imports.     } deriving Show  -- | For processing dependency information, we need lots of maps and sets of@@ -132,10 +127,6 @@     , rawBootMap :: !BootIdMap     } deriving Show -pkgDependencies :: RawDependencyInformation -> FilePathIdMap (Set InstalledUnitId)-pkgDependencies RawDependencyInformation{..} =-    IntMap.map (either (const Set.empty) packageImports) rawImports- data DependencyInformation =   DependencyInformation     { depErrorNodes :: !(FilePathIdMap (NonEmpty NodeError))@@ -146,8 +137,6 @@     -- in the same package.     , depReverseModuleDeps :: !(IntMap IntSet)     -- ^ Contains a reverse mapping from a module to all those that immediately depend on it.-    , depPkgDeps :: !(FilePathIdMap (Set InstalledUnitId))-    -- ^ For a non-error node, this contains the set of immediate pkg deps.     , depPathIdMap :: !PathIdMap     -- ^ Map from FilePath to FilePathId     , depBootMap :: !BootIdMap@@ -222,13 +211,12 @@    SuccessNode a <> SuccessNode _ = SuccessNode a  processDependencyInformation :: RawDependencyInformation -> DependencyInformation-processDependencyInformation rawDepInfo@RawDependencyInformation{..} =+processDependencyInformation RawDependencyInformation{..} =   DependencyInformation     { depErrorNodes = IntMap.fromList errorNodes     , depModuleDeps = moduleDeps     , depReverseModuleDeps = reverseModuleDeps     , depModuleNames = IntMap.fromList $ coerce moduleNames-    , depPkgDeps = pkgDependencies rawDepInfo     , depPathIdMap = rawPathIdMap     , depBootMap = rawBootMap     }@@ -248,8 +236,8 @@             successEdges         reverseModuleDeps =           foldr (\(p, cs) res ->-                                  let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs))-                                  in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges+            let new = IntMap.fromList (map (, IntSet.singleton (coerce p)) (coerce cs))+            in IntMap.unionWith IntSet.union new res ) IntMap.empty successEdges   -- | Given a dependency graph, buildResultGraph detects and propagates errors in that graph as follows:@@ -345,17 +333,8 @@       reachable g <$> toVertex (getFilePathId fileId)   let transitiveModuleDepIds =         filter (\v -> v `IntSet.member` reachableVs) $ map (fst3 . fromVertex) vs-  let transitivePkgDeps =-          Set.toList $ Set.unions $-          map (\f -> IntMap.findWithDefault Set.empty f depPkgDeps) $-          getFilePathId fileId : transitiveModuleDepIds   let transitiveModuleDeps =         map (idToPath depPathIdMap . FilePathId) transitiveModuleDepIds-  let transitiveNamedModuleDeps =-        [ NamedModuleDep (idToPath depPathIdMap (FilePathId fid)) mn artifactModLocation-        | (fid, ShowableModuleName mn) <- IntMap.toList depModuleNames-        , let ArtifactsLocation{artifactModLocation} = idToPathMap depPathIdMap IntMap.! fid-        ]   pure TransitiveDependencies {..}   where     (g, fromVertex, toVertex) = graphFromEdges edges@@ -369,15 +348,10 @@      vs = topSort g -data TransitiveDependencies = TransitiveDependencies+newtype TransitiveDependencies = TransitiveDependencies   { transitiveModuleDeps :: [NormalizedFilePath]   -- ^ Transitive module dependencies in topological order.   -- The module itself is not included.-  , transitiveNamedModuleDeps :: [NamedModuleDep]-  -- ^ Transitive module dependencies in topological order.-  -- The module itself is not included.-  , transitivePkgDeps :: [InstalledUnitId]-  -- ^ Transitive pkg dependencies in unspecified order.   } deriving (Eq, Show, Generic)  instance NFData TransitiveDependencies

@@ -37,7 +37,7 @@  data Import   = FileImport !ArtifactsLocation-  | PackageImport !M.InstalledUnitId+  | PackageImport   deriving (Show)  data ArtifactsLocation = ArtifactsLocation@@ -55,7 +55,7 @@  instance NFData Import where   rnf (FileImport x) = rnf x-  rnf (PackageImport x) = rnf x+  rnf PackageImport = ()  modSummaryToArtifactsLocation :: NormalizedFilePath -> Maybe ModSummary -> ArtifactsLocation modSummaryToArtifactsLocation nfp ms = ArtifactsLocation nfp (ms_location <$> ms) source@@ -137,7 +137,7 @@      lookupInPackageDB dfs =       case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of-        LookupFound _m pkgConfig -> return $ Right $ PackageImport $ unitId pkgConfig+        LookupFound _m _pkgConfig -> return $ Right PackageImport         reason -> return $ Left $ notFoundErr dfs modName reason  -- | Don't call this on a found module.

@@ -1,42 +1,39 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0-+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs      #-}  -- | Display information on hover. module Development.IDE.LSP.HoverDefinition-    ( setHandlersDefinition-    , setHandlersTypeDefinition-    , setHandlersDocHighlight-    , setHandlersReferences-    , setHandlersWsSymbols+    ( setIdeHandlers     -- * For haskell-language-server     , hover     , gotoDefinition     , gotoTypeDefinition     ) where +import Control.Monad.IO.Class import           Development.IDE.Core.Rules import           Development.IDE.Core.Shake import           Development.IDE.LSP.Server import           Development.IDE.Types.Location import           Development.IDE.Types.Logger-import qualified Language.Haskell.LSP.Core       as LSP-import           Language.Haskell.LSP.Messages-import           Language.Haskell.LSP.Types+import qualified Language.LSP.Server as LSP+import           Language.LSP.Types  import qualified Data.Text as T -gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)-hover          :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))-gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)-documentHighlight :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (List DocumentHighlight))-gotoDefinition = request "Definition" getDefinition (MultiLoc []) MultiLoc-gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (MultiLoc []) MultiLoc+gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentDefinition))+hover          :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Maybe Hover))+gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (ResponseResult TextDocumentTypeDefinition))+documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (List DocumentHighlight))+gotoDefinition = request "Definition" getDefinition (InR $ InL $ List []) (InR . InL . List)+gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InL $ List []) (InR . InL . List) hover          = request "Hover"      getAtPoint     Nothing      foundHover documentHighlight = request "DocumentHighlight" highlightAtPoint (List []) List -references :: IdeState -> ReferenceParams -> IO (Either ResponseError (List Location))-references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _) =+references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError (List Location))+references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO $   case uriToFilePath' uri of     Just path -> do       let filePath = toNormalizedFilePath' path@@ -46,8 +43,8 @@       Right . List <$> (runAction "references" ide $ refsAtPoint filePath pos)     Nothing -> pure $ Left $ ResponseError InvalidParams ("Invalid URI " <> T.pack (show uri)) Nothing -wsSymbols :: IdeState -> WorkspaceSymbolParams -> IO (Either ResponseError (List SymbolInformation))-wsSymbols ide (WorkspaceSymbolParams query _) = do+wsSymbols :: IdeState -> WorkspaceSymbolParams -> LSP.LspM c (Either ResponseError (List SymbolInformation))+wsSymbols ide (WorkspaceSymbolParams _ _ query) = liftIO $ do   logDebug (ideLogger ide) $ "Workspace symbols request: " <> query   runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ Right . maybe (List []) List <$> workspaceSymbols query @@ -55,18 +52,17 @@ foundHover (mbRange, contents) =   Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange -setHandlersDefinition, setHandlersTypeDefinition, setHandlersDocHighlight,-  setHandlersReferences, setHandlersWsSymbols :: PartialHandlers c-setHandlersDefinition = PartialHandlers $ \WithMessage{..} x ->-  return x{LSP.definitionHandler = withResponse RspDefinition $ const gotoDefinition}-setHandlersTypeDefinition = PartialHandlers $ \WithMessage{..} x ->-  return x {LSP.typeDefinitionHandler = withResponse RspDefinition $ const gotoTypeDefinition}-setHandlersDocHighlight = PartialHandlers $ \WithMessage{..} x ->-  return x{LSP.documentHighlightHandler = withResponse RspDocumentHighlights $ const documentHighlight}-setHandlersReferences = PartialHandlers $ \WithMessage{..} x ->-  return x{LSP.referencesHandler = withResponse RspFindReferences $ const references}-setHandlersWsSymbols = PartialHandlers $ \WithMessage{..} x ->-  return x{LSP.workspaceSymbolHandler = withResponse RspWorkspaceSymbols $ const wsSymbols}+setIdeHandlers :: LSP.Handlers (ServerM c)+setIdeHandlers = mconcat+  [ requestHandler STextDocumentDefinition $ \ide DefinitionParams{..} ->+      gotoDefinition ide TextDocumentPositionParams{..}+  , requestHandler STextDocumentTypeDefinition $ \ide TypeDefinitionParams{..} ->+      gotoTypeDefinition ide TextDocumentPositionParams{..}+  , requestHandler STextDocumentDocumentHighlight $ \ide DocumentHighlightParams{..} ->+      documentHighlight ide TextDocumentPositionParams{..}+  , requestHandler STextDocumentReferences references+  , requestHandler SWorkspaceSymbol wsSymbols+  ]  -- | Respond to and log a hover or go-to-definition request request@@ -76,8 +72,8 @@   -> (a -> b)   -> IdeState   -> TextDocumentPositionParams-  -> IO (Either ResponseError b)-request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do+  -> LSP.LspM c (Either ResponseError b)+request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do     mbResult <- case uriToFilePath' uri of         Just path -> logAndRunRequest label getResults ide pos path         Nothing   -> pure Nothing@@ -86,7 +82,7 @@ logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b logAndRunRequest label getResults ide pos path = do   let filePath = toNormalizedFilePath' path-  logInfo (ideLogger ide) $+  logDebug (ideLogger ide) $     label <> " request at position " <> T.pack (showPosition pos) <>     " in file: " <> T.pack path   runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos)

@@ -1,8 +1,10 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.+      -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0  {-# LANGUAGE ExistentialQuantification  #-}-{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}  -- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync -- This version removes the daml: handling@@ -10,46 +12,47 @@     ( runLanguageServer     ) where -import           Language.Haskell.LSP.Types-import           Language.Haskell.LSP.Types.Capabilities+import           Language.LSP.Types import           Development.IDE.LSP.Server import qualified Development.IDE.GHC.Util as Ghcide-import qualified Language.Haskell.LSP.Control as LSP-import qualified Language.Haskell.LSP.Core as LSP-import Control.Concurrent.Chan-import Control.Concurrent.Extra-import Control.Concurrent.Async+import qualified Language.LSP.Server as LSP+import Control.Concurrent.Extra (newBarrier, signalBarrier, waitBarrier) import Control.Concurrent.STM-import Control.Exception.Safe-import Data.Default import Data.Maybe+import Data.Aeson (Value) import qualified Data.Set as Set import qualified Data.Text as T import GHC.IO.Handle (hDuplicate) import System.IO import Control.Monad.Extra+import UnliftIO.Exception+import UnliftIO.Async+import UnliftIO.Concurrent+import UnliftIO.Directory+import Control.Monad.IO.Class+import Control.Monad.Reader+import Ide.Types (traceWithSpan)+import Development.IDE.Session (runWithDb)  import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake import Development.IDE.LSP.HoverDefinition import Development.IDE.LSP.Notifications-import Development.IDE.LSP.Outline import Development.IDE.Types.Logger import Development.IDE.Core.FileStore import Development.IDE.Core.Tracing-import Language.Haskell.LSP.Core (LspFuncs(..))-import Language.Haskell.LSP.Messages +import System.IO.Unsafe (unsafeInterleaveIO)+ runLanguageServer     :: forall config. (Show config)     => LSP.Options-    -> PartialHandlers config-    -> (InitializeRequest -> Either T.Text config)-    -> (DidChangeConfigurationNotification -> Either T.Text config)-    -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities-        -> WithProgressFunc -> WithIndefiniteProgressFunc -> IO (Maybe config) -> Maybe FilePath -> IO IdeState)+    -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project+    -> (IdeState -> Value -> IO (Either T.Text config))+    -> LSP.Handlers (ServerM config)+    -> (LSP.LanguageContextEnv config -> VFSHandle -> Maybe FilePath -> HieDb -> IndexQueue -> IO IdeState)     -> IO ()-runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do+runLanguageServer options getHieDbLoc onConfigurationChange userHandlers getIdeState = do     -- Move stdout to another file descriptor and duplicate stderr     -- to stdout. This guards against stray prints from corrupting the JSON-RPC     -- message stream.@@ -64,10 +67,6 @@     -- the language server tests without the redirection.     putStr " " >> hFlush stdout -    -- Send everything over a channel, since you need to wait until after initialise before-    -- LspFuncs is available-    clientMsgChan :: Chan (Message config) <- newChan-     -- These barriers are signaled when the threads reading from these chans exit.     -- This should not happen but if it does, we will make sure that the whole server     -- dies and can be restarted instead of losing threads silently.@@ -80,16 +79,6 @@     -- The set of requests that have been cancelled and are also in pendingRequests     cancelledRequests <- newTVarIO Set.empty -    let withResponse wrap f = Just $ \r@RequestMessage{_id, _method} -> do-            atomically $ modifyTVar pendingRequests (Set.insert _id)-            writeChan clientMsgChan $ Response r wrap f-    let withNotification old f = Just $ \r@NotificationMessage{_method} ->-            writeChan clientMsgChan $ Notification r (\lsp ide x -> f lsp ide x >> whenJust old ($ r))-    let withResponseAndRequest wrap wrapNewReq f = Just $ \r@RequestMessage{_id, _method} -> do-            atomically $ modifyTVar pendingRequests (Set.insert _id)-            writeChan clientMsgChan $ ResponseAndRequest r wrap wrapNewReq f-    let withInitialize f = Just $ \r ->-            writeChan clientMsgChan $ InitialParams r (\lsp ide x -> f lsp ide x)     let cancelRequest reqId = atomically $ do             queued <- readTVar pendingRequests             -- We want to avoid that the list of cancelled requests@@ -105,160 +94,117 @@     let waitForCancel reqId = atomically $ do             cancelled <- readTVar cancelledRequests             unless (reqId `Set.member` cancelled) retry-    let PartialHandlers parts =-            initializeRequestHandler <>-            setHandlersIgnore <> -- least important-            setHandlersDefinition <> setHandlersTypeDefinition <>-            setHandlersDocHighlight <> setHandlersReferences <> setHandlersWsSymbols <>-            setHandlersOutline <>-            userHandlers <>-            setHandlersNotifications <> -- absolutely critical, join them with user notifications-            cancelHandler cancelRequest <>-            exitHandler exit-            -- Cancel requests are special since they need to be handled-            -- out of order to be useful. Existing handlers are run afterwards.-    handlers <- parts WithMessage{withResponse, withNotification, withResponseAndRequest, withInitialize} def -    let initializeCallbacks = LSP.InitializeCallbacks-            { LSP.onInitialConfiguration = onInitialConfig-            , LSP.onConfigurationChange = onConfigChange-            , LSP.onStartup = handleInit exit clearReqId waitForCancel clientMsgChan+    let ideHandlers = mconcat+          [ setIdeHandlers+          , userHandlers+          , setHandlersNotifications -- absolutely critical, join them with user notifications+          ]++    -- Send everything over a channel, since you need to wait until after initialise before+    -- LspFuncs is available+    clientMsgChan :: Chan ReactorMessage <- newChan++    let asyncHandlers = mconcat+          [ ideHandlers+          , cancelHandler cancelRequest+          , exitHandler exit+          ]+          -- Cancel requests are special since they need to be handled+          -- out of order to be useful. Existing handlers are run afterwards.+++    let serverDefinition = LSP.ServerDefinition+            { LSP.onConfigurationChange = \v -> do+                (_chan, ide) <- ask+                liftIO $ onConfigurationChange ide v+            , LSP.doInitialize = handleInit exit clearReqId waitForCancel clientMsgChan+            , LSP.staticHandlers = asyncHandlers+            , LSP.interpretHandler = \(env, st) -> LSP.Iso (LSP.runLspT env . flip runReaderT (clientMsgChan,st)) liftIO+            , LSP.options = modifyOptions options             }      void $ waitAnyCancel =<< traverse async-        [ void $ LSP.runWithHandles+        [ void $ LSP.runServerWithHandles             stdin             newStdout-            initializeCallbacks-            handlers-            (modifyOptions options)-            Nothing+            serverDefinition         , void $ waitBarrier clientMsgBarrier         ]+     where-        handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan (Message config) -> LSP.LspFuncs config -> IO (Maybe err)-        handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do+        handleInit+          :: IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage+          -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))+        handleInit exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do+            traceWithSpan sp params+            let root = LSP.resRootPath env -            ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities-                               withProgress withIndefiniteProgress config rootPath+            dir <- getCurrentDirectory+            dbLoc <- getHieDbLoc dir -            _ <- flip forkFinally (const exitClientMsg) $ forever $ do+            -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference+            -- to 'getIdeState', so we use this dirty trick+            dbMVar <- newEmptyMVar+            ~(hiedb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar++            ide <- getIdeState env (makeLSPVFSHandle env) root hiedb hieChan++            let initConfig = parseConfiguration params+            logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig+            registerIdeConfiguration (shakeExtras ide) initConfig++            _ <- flip forkFinally (const exitClientMsg) $ runWithDb dbLoc $ \hiedb hieChan -> do+              putMVar dbMVar (hiedb,hieChan)+              forever $ do                 msg <- readChan clientMsgChan                 -- We dispatch notifications synchronously and requests asynchronously                 -- This is to ensure that all file edits and config changes are applied before a request is handled                 case msg of-                    Notification x@NotificationMessage{_params, _method} act ->-                        otTracedHandler "Notification" (show _method) $ \sp -> do-                          traceWithSpan sp _params-                          catch (act lspFuncs ide _params) $ \(e :: SomeException) ->-                            logError (ideLogger ide) $ T.pack $-                                "Unexpected exception on notification, please report!\n" ++-                                "Message: " ++ show x ++ "\n" ++-                                "Exception: " ++ show e-                    Response x@RequestMessage{_id, _method, _params} wrap act -> void $ async $-                        otTracedHandler "Request" (show _method) $ \sp -> do-                          traceWithSpan sp _params-                          checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $-                            \case-                              Left e  -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)-                              Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)-                    ResponseAndRequest x@RequestMessage{_id, _method, _params} wrap wrapNewReq act -> void $ async $-                        otTracedHandler "Request" (show _method) $ \sp -> do-                          traceWithSpan sp _params-                          checkCancelled ide clearReqId waitForCancel lspFuncs wrap act x _id _params $-                            \(res, newReq) -> do-                                case res of-                                    Left e  -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Left e)-                                    Right r -> sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Right r)-                                whenJust newReq $ \(rm, newReqParams) -> do-                                    reqId <- getNextReqId-                                    sendFunc $ wrapNewReq $ RequestMessage "2.0" reqId rm newReqParams-                    InitialParams x@RequestMessage{_id, _method, _params} act ->-                        otTracedHandler "Initialize" (show _method) $ \sp -> do-                          traceWithSpan sp _params-                          catch (act lspFuncs ide _params) $ \(e :: SomeException) ->-                            logError (ideLogger ide) $ T.pack $-                                "Unexpected exception on InitializeRequest handler, please report!\n" ++-                                "Message: " ++ show x ++ "\n" ++-                                "Exception: " ++ show e-            pure Nothing+                    ReactorNotification act -> do+                      catch act $ \(e :: SomeException) ->+                        logError (ideLogger ide) $ T.pack $+                          "Unexpected exception on notification, please report!\n" +++                          "Exception: " ++ show e+                    ReactorRequest _id act k -> void $ async $+                      checkCancelled ide clearReqId waitForCancel _id act k+            pure $ Right (env,ide) -        checkCancelled ide clearReqId waitForCancel lspFuncs@LSP.LspFuncs{..} wrap act msg _id _params k =+        checkCancelled+          :: IdeState -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> SomeLspId+          -> IO () -> (ResponseError -> IO ()) -> IO ()+        checkCancelled ide clearReqId waitForCancel _id act k =             flip finally (clearReqId _id) $                 catch (do                     -- We could optimize this by first checking if the id                     -- is in the cancelled set. However, this is unlikely to be a                     -- bottleneck and the additional check might hide                     -- issues with async exceptions that need to be fixed.-                    cancelOrRes <- race (waitForCancel _id) $ act lspFuncs ide _params+                    cancelOrRes <- race (waitForCancel _id) act                     case cancelOrRes of                         Left () -> do-                            logDebug (ideLogger ide) $ T.pack $-                                "Cancelled request " <> show _id-                            sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left-                                $ ResponseError RequestCancelled "" Nothing-                        Right res -> k res+                            logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id+                            k $ ResponseError RequestCancelled "" Nothing+                        Right res -> pure res                 ) $ \(e :: SomeException) -> do                     logError (ideLogger ide) $ T.pack $                         "Unexpected exception on request, please report!\n" ++-                        "Message: " ++ show msg ++ "\n" ++                         "Exception: " ++ show e-                    sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) $ Left-                        $ ResponseError InternalError (T.pack $ show e) Nothing+                    k $ ResponseError InternalError (T.pack $ show e) Nothing -initializeRequestHandler :: PartialHandlers config-initializeRequestHandler = PartialHandlers $ \WithMessage{..} x -> return x{-    LSP.initializeRequestHandler = withInitialize initHandler-    } -initHandler-    :: LSP.LspFuncs c-    -> IdeState-    -> InitializeParams-    -> IO ()-initHandler _ ide params = do-    let initConfig = parseConfiguration params-    logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig-    registerIdeConfiguration (shakeExtras ide) initConfig---- | Things that get sent to us, but we don't deal with.---   Set them to avoid a warning in VS Code output.-setHandlersIgnore :: PartialHandlers config-setHandlersIgnore = PartialHandlers $ \_ x -> return x-    {LSP.responseHandler = none-    }-    where none = Just $ const $ return ()--cancelHandler :: (LspId -> IO ()) -> PartialHandlers config-cancelHandler cancelRequest = PartialHandlers $ \_ x -> return x-    {LSP.cancelNotificationHandler = Just $ \msg@NotificationMessage {_params = CancelParams {_id}} -> do-            cancelRequest _id-            whenJust (LSP.cancelNotificationHandler x) ($ msg)-    }--exitHandler :: IO () -> PartialHandlers c-exitHandler exit = PartialHandlers $ \_ x -> return x-    {LSP.exitNotificationHandler = Just $ const exit}+cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c)+cancelHandler cancelRequest = LSP.notificationHandler SCancelRequest $ \NotificationMessage{_params=CancelParams{_id}} ->+  liftIO $ cancelRequest (SomeLspId _id) --- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety---   and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer)-data Message c-  = forall m req resp . (Show m, Show req, HasTracing req) =>-    Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp))-  | -- | Used for cases in which we need to send not only a response,-    --   but also an additional request to the client.-    --   For example, 'executeCommand' may generate an 'applyWorkspaceEdit' request.-    forall m rm req resp newReqParams newReqBody. (Show m, Show rm, Show req, HasTracing req) =>-    ResponseAndRequest (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (RequestMessage rm newReqParams newReqBody -> FromServerMessage) (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))-  | forall m req . (Show m, Show req, HasTracing req) =>-    Notification (NotificationMessage m req) (LSP.LspFuncs c -> IdeState -> req -> IO ())-  | -- | Used for the InitializeRequest only, where the response is generated by the LSP core handler.-    InitialParams InitializeRequest (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())+exitHandler :: IO () -> LSP.Handlers (ServerM c)+exitHandler exit = LSP.notificationHandler SExit (const $ liftIO exit)  modifyOptions :: LSP.Options -> LSP.Options modifyOptions x = x{ LSP.textDocumentSync   = Just $ tweakTDS origTDS                    }     where-        tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}+        tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ InR $ SaveOptions Nothing}         origTDS = fromMaybe tdsDefault $ LSP.textDocumentSync x         tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing+

@@ -3,27 +3,27 @@  {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE PolyKinds             #-}  module Development.IDE.LSP.Notifications     ( setHandlersNotifications     ) where -import           Development.IDE.LSP.Server-import qualified Language.Haskell.LSP.Core        as LSP-import           Language.Haskell.LSP.Types-import qualified Language.Haskell.LSP.Types       as LSP-import qualified Language.Haskell.LSP.Messages    as LSP-import qualified Language.Haskell.LSP.Types.Capabilities as LSP+import qualified Language.LSP.Server      as LSP+import           Language.LSP.Types+import qualified Language.LSP.Types       as LSP+import qualified Language.LSP.Types.Capabilities as LSP  import           Development.IDE.Core.IdeConfiguration import           Development.IDE.Core.Service+import           Development.IDE.LSP.Server import           Development.IDE.Core.Shake import           Development.IDE.Types.Location import           Development.IDE.Types.Logger import           Development.IDE.Types.Options  import           Control.Monad.Extra-import qualified Data.Aeson                       as A import           Data.Foldable                    as F import           Data.Maybe import qualified Data.HashMap.Strict              as M@@ -34,115 +34,111 @@ import           Development.IDE.Core.FileExists  (modifyFileExists, watchedGlobs) import           Development.IDE.Core.OfInterest import Ide.Plugin.Config (CheckParents(CheckOnClose))+import Control.Monad.IO.Class   whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFilePath' -setHandlersNotifications :: PartialHandlers c-setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x-    {LSP.didOpenTextDocumentNotificationHandler = withNotification (LSP.didOpenTextDocumentNotificationHandler x) $-        \_ ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> do-            updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List [])-            whenUriFile _uri $ \file -> do-                -- We don't know if the file actually exists, or if the contents match those on disk-                -- For example, vscode restores previously unsaved contents on open-                modifyFilesOfInterest ide (M.insert file Modified)-                setFileModified ide False file-                logInfo (ideLogger ide) $ "Opened text document: " <> getUri _uri--    ,LSP.didChangeTextDocumentNotificationHandler = withNotification (LSP.didChangeTextDocumentNotificationHandler x) $-        \_ ide (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> do-            updatePositionMapping ide identifier changes-            whenUriFile _uri $ \file -> do-              modifyFilesOfInterest ide (M.insert file Modified)-              setFileModified ide False file-            logInfo (ideLogger ide) $ "Modified text document: " <> getUri _uri+setHandlersNotifications :: LSP.Handlers (ServerM c)+setHandlersNotifications = mconcat+  [ notificationHandler LSP.STextDocumentDidOpen $+      \ide (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do+      updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List [])+      whenUriFile _uri $ \file -> do+          -- We don't know if the file actually exists, or if the contents match those on disk+          -- For example, vscode restores previously unsaved contents on open+          modifyFilesOfInterest ide (M.insert file Modified{firstOpen=True})+          setFileModified ide False file+          logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri -    ,LSP.didSaveTextDocumentNotificationHandler = withNotification (LSP.didSaveTextDocumentNotificationHandler x) $-        \_ ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri}) -> do-            whenUriFile _uri $ \file -> do-                modifyFilesOfInterest ide (M.insert file OnDisk)-                setFileModified ide True file-            logInfo (ideLogger ide) $ "Saved text document: " <> getUri _uri+  , notificationHandler LSP.STextDocumentDidChange $+      \ide (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do+        updatePositionMapping ide identifier changes+        whenUriFile _uri $ \file -> do+          modifyFilesOfInterest ide (M.insert file Modified{firstOpen=False})+          setFileModified ide False file+        logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri -    ,LSP.didCloseTextDocumentNotificationHandler = withNotification (LSP.didCloseTextDocumentNotificationHandler x) $-        \_ ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> do-            whenUriFile _uri $ \file -> do-                modifyFilesOfInterest ide (M.delete file)-                -- Refresh all the files that depended on this-                IdeOptions{optCheckParents} <- getIdeOptionsIO $ shakeExtras ide-                when (optCheckParents >= CheckOnClose) $ typecheckParents ide file-                logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri-    ,LSP.didChangeWatchedFilesNotificationHandler = withNotification (LSP.didChangeWatchedFilesNotificationHandler x) $-        \_ ide (DidChangeWatchedFilesParams fileEvents) -> do-            -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and-            -- what we do with them-            let events =-                    mapMaybe-                        (\(FileEvent uri ev) ->-                            (, ev /= FcDeleted) . toNormalizedFilePath'-                            <$> LSP.uriToFilePath uri-                        )-                        ( F.toList fileEvents )-            let msg = Text.pack $ show events-            logDebug (ideLogger ide) $ "Files created or deleted: " <> msg-            modifyFileExists ide events-            setSomethingModified ide+  , notificationHandler LSP.STextDocumentDidSave $+      \ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do+        whenUriFile _uri $ \file -> do+            modifyFilesOfInterest ide (M.insert file OnDisk)+            setFileModified ide True file+        logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri -    ,LSP.didChangeWorkspaceFoldersNotificationHandler = withNotification (LSP.didChangeWorkspaceFoldersNotificationHandler x) $-        \_ ide (DidChangeWorkspaceFoldersParams events) -> do-            let add       = S.union-                substract = flip S.difference-            modifyWorkspaceFolders ide-              $ add       (foldMap (S.singleton . parseWorkspaceFolder) (_added   events))-              . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events))+  , notificationHandler LSP.STextDocumentDidClose $+        \ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do+          whenUriFile _uri $ \file -> do+              modifyFilesOfInterest ide (M.delete file)+              -- Refresh all the files that depended on this+              checkParents <- optCheckParents =<< getIdeOptionsIO (shakeExtras ide)+              when (checkParents >= CheckOnClose) $ typecheckParents ide file+              logDebug (ideLogger ide) $ "Closed text document: " <> getUri _uri -    ,LSP.didChangeConfigurationParamsHandler = withNotification (LSP.didChangeConfigurationParamsHandler x) $-        \_ ide (DidChangeConfigurationParams cfg) -> do-            let msg = Text.pack $ show cfg-            logInfo (ideLogger ide) $ "Configuration changed: " <> msg-            modifyClientSettings ide (const $ Just cfg)-            setSomethingModified ide+  , notificationHandler LSP.SWorkspaceDidChangeWatchedFiles $+      \ide (DidChangeWatchedFilesParams fileEvents) -> liftIO $ do+        -- See Note [File existence cache and LSP file watchers] which explains why we get these notifications and+        -- what we do with them+        let events =+                mapMaybe+                    (\(FileEvent uri ev) ->+                        (, ev /= FcDeleted) . toNormalizedFilePath'+                        <$> LSP.uriToFilePath uri+                    )+                    ( F.toList fileEvents )+        let msg = Text.pack $ show events+        logDebug (ideLogger ide) $ "Files created or deleted: " <> msg+        modifyFileExists ide events+        setSomethingModified ide -    -- Initialized handler, good time to dynamically register capabilities-    ,LSP.initializedHandler = withNotification (LSP.initializedHandler x) $ \lsp@LSP.LspFuncs{..} ide _ -> do-        let watchSupported = case () of-              _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities-                , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace-                , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles-                , Just True <- _dynamicRegistration-                  -> True-                | otherwise -> False+  , notificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $+      \ide (DidChangeWorkspaceFoldersParams events) -> liftIO $ do+        let add       = S.union+            substract = flip S.difference+        modifyWorkspaceFolders ide+          $ add       (foldMap (S.singleton . parseWorkspaceFolder) (_added   events))+          . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) -        if watchSupported-        then registerWatcher lsp ide-        else logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"+  , notificationHandler LSP.SWorkspaceDidChangeConfiguration $+      \ide (DidChangeConfigurationParams cfg) -> liftIO $ do+        let msg = Text.pack $ show cfg+        logDebug (ideLogger ide) $ "Configuration changed: " <> msg+        modifyClientSettings ide (const $ Just cfg)+        setSomethingModified ide -    }-    where-        registerWatcher LSP.LspFuncs{..} ide = do-            lspId <- getNextReqId-            opts <- getIdeOptionsIO $ shakeExtras ide-            let-              req = RequestMessage "2.0" lspId ClientRegisterCapability regParams-              regParams    = RegistrationParams (List [registration])-              -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).-              -- We could also use something like a random UUID, as some other servers do, but this works for-              -- our purposes.-              registration = Registration "globalFileWatches"-                                          WorkspaceDidChangeWatchedFiles-                                          (Just (A.toJSON regOptions))-              regOptions =-                DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers }-              -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind-              watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True}-              -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is-              -- The patterns will be something like "**/.hs", i.e. "any number of directory segments,-              -- followed by a file with an extension 'hs'.-              watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind }-              -- We use multiple watchers instead of one using '{}' because lsp-test doesn't-              -- support that: https://github.com/bubba/lsp-test/issues/77-              watchers = [ watcher glob | glob <- watchedGlobs opts ]+  , notificationHandler LSP.SInitialized $ \ide _ -> do+      clientCapabilities <- LSP.getClientCapabilities+      let watchSupported = case () of+            _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities+              , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace+              , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles+              , Just True <- _dynamicRegistration+                -> True+              | otherwise -> False+      if watchSupported+      then do+        opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide+        let+          regParams    = RegistrationParams (List [SomeRegistration registration])+          -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).+          -- We could also use something like a random UUID, as some other servers do, but this works for+          -- our purposes.+          registration = Registration "globalFileWatches"+                                      SWorkspaceDidChangeWatchedFiles+                                      regOptions+          regOptions =+            DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers }+          -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind+          watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True}+          -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is+          -- The patterns will be something like "**/.hs", i.e. "any number of directory segments,+          -- followed by a file with an extension 'hs'.+          watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind }+          -- We use multiple watchers instead of one using '{}' because lsp-test doesn't+          -- support that: https://github.com/bubba/lsp-test/issues/77+          watchers = [ watcher (Text.pack glob) | glob <- watchedGlobs opts ] -            sendFunc $ LSP.ReqRegisterCapability req+        void $ LSP.sendRequest SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response+      else liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"+  ]

@@ -1,17 +1,18 @@ {-# LANGUAGE CPP #-}++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE DuplicateRecordFields #-} #include "ghc-api-version.h"  module Development.IDE.LSP.Outline-  ( setHandlersOutline-    -- * For haskell-language-server-  , moduleOutline+  ( moduleOutline   ) where -import qualified Language.Haskell.LSP.Core     as LSP-import           Language.Haskell.LSP.Messages-import           Language.Haskell.LSP.Types+import           Language.LSP.Types+import           Language.LSP.Server (LspM)+import           Control.Monad.IO.Class import           Data.Functor import           Data.Generics import           Data.Maybe@@ -23,26 +24,20 @@ import           Development.IDE.Core.Shake import           Development.IDE.GHC.Compat import           Development.IDE.GHC.Error      ( realSrcSpanToRange )-import           Development.IDE.LSP.Server import           Development.IDE.Types.Location import           Outputable                     ( Outputable                                                 , ppr                                                 , showSDocUnsafe                                                 ) -setHandlersOutline :: PartialHandlers c-setHandlersOutline = PartialHandlers $ \WithMessage {..} x -> return x-  { LSP.documentSymbolHandler = withResponse RspDocumentSymbols moduleOutline-  }- moduleOutline-  :: LSP.LspFuncs c -> IdeState -> DocumentSymbolParams -> IO (Either ResponseError DSResult)-moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }-  = case uriToFilePath uri of+  :: IdeState -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation))+moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri }+  = liftIO $ case uriToFilePath uri of     Just (toNormalizedFilePath' -> fp) -> do       mb_decls <- fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule fp)       pure $ Right $ case mb_decls of-        Nothing -> DSDocumentSymbols (List [])+        Nothing -> InL (List [])         Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } }           -> let                declSymbols  = mapMaybe documentSymbolForDecl hsmodDecls@@ -64,10 +59,10 @@                        }                    ]              in-               DSDocumentSymbols (List allSymbols)+               InL (List allSymbols)  -    Nothing -> pure $ Right $ DSDocumentSymbols (List [])+    Nothing -> pure $ Right $ InL (List [])  documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } }))

@@ -1,23 +0,0 @@--- Copyright (c) 2019 The DAML Authors. All rights reserved.--- SPDX-License-Identifier: Apache-2.0-{-# LANGUAGE PatternSynonyms #-}--module Development.IDE.LSP.Protocol-    ( pattern EventFileDiagnostics-    ) where--import Development.IDE.Types.Diagnostics-import Development.IDE.Types.Location-import Language.Haskell.LSP.Messages-import Language.Haskell.LSP.Types--------------------------------------------------------------------------------------------------------- Pretty printing--------------------------------------------------------------------------------------------------------- | Pattern synonym to make it a bit more convenient to match on diagnostics--- in things like damlc test.-pattern EventFileDiagnostics :: FilePath -> [Diagnostic] -> FromServerMessage-pattern EventFileDiagnostics fp diags <--    NotPublishDiagnostics-        (NotificationMessage _ _ (PublishDiagnosticsParams (uriToFilePath' -> Just fp) (List diags)))

@@ -5,81 +5,57 @@  {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GADTs #-} module Development.IDE.LSP.Server-  ( WithMessage(..)-  , PartialHandlers(..)-  , HasTracing(..)-  ,setUriAnd) where+  ( ReactorMessage(..)+  , ReactorChan+  , ServerM+  , requestHandler+  , notificationHandler+  ) where +import Language.LSP.Server (LspM, Handlers)+import Language.LSP.Types+import qualified Language.LSP.Server as LSP+import Development.IDE.Core.Shake+import UnliftIO.Chan+import Control.Monad.Reader+import Ide.Types (HasTracing, traceWithSpan)+import Development.IDE.Core.Tracing -import Control.Lens ((^.))-import Data.Default+data ReactorMessage+  = ReactorNotification (IO ())+  | ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ()) -import           Language.Haskell.LSP.Types-import qualified Language.Haskell.LSP.Core as LSP-import qualified Language.Haskell.LSP.Messages as LSP-import Language.Haskell.LSP.Types.Lens (HasTextDocument (textDocument), HasUri (uri))-import Development.IDE.Core.Service-import Data.Aeson (Value)-import Development.IDE.Core.Tracing (otSetUri)-import OpenTelemetry.Eventlog (SpanInFlight, setTag)-import Data.Text.Encoding (encodeUtf8)+type ReactorChan = Chan ReactorMessage+type ServerM c = ReaderT (ReactorChan, IdeState) (LspM c) -data WithMessage c = WithMessage-    {withResponse :: forall m req resp . (Show m, Show req, HasTracing req) =>-        (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response-        (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp)) -> -- actual work-        Maybe (LSP.Handler (RequestMessage m req resp))-    ,withNotification :: forall m req . (Show m, Show req, HasTracing req) =>-        Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler-        (LSP.LspFuncs c -> IdeState -> req -> IO ()) -> -- actual work-        Maybe (LSP.Handler (NotificationMessage m req))-    ,withResponseAndRequest :: forall m rm req resp newReqParams newReqBody .-        (Show m, Show rm, Show req, Show newReqParams, Show newReqBody, HasTracing req) =>-        (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response-        (RequestMessage rm newReqParams newReqBody -> LSP.FromServerMessage) -> -- how to wrap the additional req-        (LSP.LspFuncs c -> IdeState -> req -> IO (Either ResponseError resp, Maybe (rm, newReqParams))) -> -- actual work-        Maybe (LSP.Handler (RequestMessage m req resp))-    , withInitialize :: (LSP.LspFuncs c -> IdeState -> InitializeParams -> IO ())-                     -> Maybe (LSP.Handler InitializeRequest)-    }+requestHandler+  :: forall (m :: Method FromClient Request) c. (HasTracing (MessageParams m)) =>+     SMethod m+  -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (ResponseResult m)))+  -> Handlers (ServerM c)+requestHandler m k = LSP.requestHandler m $ \RequestMessage{_method,_id,_params} resp -> do+  st@(chan,ide) <- ask+  env <- LSP.getLspEnv+  let resp' = flip runReaderT st . resp+      trace x = otTracedHandler "Request" (show _method) $ \sp -> do+        traceWithSpan sp _params+        x+  writeChan chan $ ReactorRequest (SomeLspId _id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) -newtype PartialHandlers c = PartialHandlers (WithMessage c -> LSP.Handlers -> IO LSP.Handlers)+notificationHandler+  :: forall (m :: Method FromClient Notification) c. (HasTracing (MessageParams m)) =>+     SMethod m+  -> (IdeState -> MessageParams m -> LspM c ())+  -> Handlers (ServerM c)+notificationHandler m k = LSP.notificationHandler m $ \NotificationMessage{_params,_method}-> do+  (chan,ide) <- ask+  env <- LSP.getLspEnv+  let trace x = otTracedHandler "Notification" (show _method) $ \sp -> do+        traceWithSpan sp _params+        x+  writeChan chan $ ReactorNotification (trace $ LSP.runLspT env $ k ide _params) -instance Default (PartialHandlers c) where-    def = PartialHandlers $ \_ x -> pure x -instance Semigroup (PartialHandlers c) where-    PartialHandlers a <> PartialHandlers b = PartialHandlers $ \w x -> a w x >>= b w--instance Monoid (PartialHandlers c) where-    mempty = def--class HasTracing a where-  traceWithSpan :: SpanInFlight -> a -> IO ()-  traceWithSpan _ _ = pure ()--instance {-# OVERLAPPABLE #-} (HasTextDocument a doc, HasUri doc Uri) => HasTracing a where-  traceWithSpan sp a = otSetUri sp (a ^. textDocument . uri)--instance HasTracing Value-instance HasTracing ExecuteCommandParams-instance HasTracing DidChangeWatchedFilesParams-instance HasTracing DidChangeWorkspaceFoldersParams-instance HasTracing DidChangeConfigurationParams-instance HasTracing InitializeParams-instance HasTracing (Maybe InitializedParams)-instance HasTracing WorkspaceSymbolParams where-  traceWithSpan sp (WorkspaceSymbolParams query _) = setTag sp "query" (encodeUtf8 query)--setUriAnd ::-  (HasTextDocument params a, HasUri a Uri) =>-  (lspFuncs -> ide -> params -> IO res) ->-  lspFuncs ->-  SpanInFlight ->-  ide ->-  params ->-  IO res-setUriAnd k lf sp ide params = do-  otSetUri sp (params ^. textDocument . uri)-  k lf ide params

@@ -0,0 +1,224 @@+module Development.IDE.Main (Arguments(..), defaultMain) where+import Control.Concurrent.Extra (readVar)+import Control.Exception.Safe (+    Exception (displayException),+    catchAny,+ )+import Control.Monad.Extra (concatMapM, unless, when)+import Data.Default (Default (def))+import qualified Data.HashMap.Strict as HashMap+import Data.List.Extra (+    intercalate,+    isPrefixOf,+    nub,+    nubOrd,+    partition,+ )+import Data.Maybe (catMaybes, fromMaybe, isJust)+import qualified Data.Text as T+import Development.IDE (Action, Rules, noLogging)+import Development.IDE.Core.Debouncer (newAsyncDebouncer)+import Development.IDE.Core.FileStore (makeVFSHandle)+import Development.IDE.Core.OfInterest (+    FileOfInterestStatus (OnDisk),+    kick,+    setFilesOfInterest,+ )+import Development.IDE.Core.RuleTypes (+    GenerateCore (GenerateCore),+    GetHieAst (GetHieAst),+    GhcSession (GhcSession),+    GhcSessionDeps (GhcSessionDeps),+    TypeCheck (TypeCheck),+ )+import Development.IDE.Core.Rules (+    GhcSessionIO (GhcSessionIO),+    mainRule,+ )+import Development.IDE.Core.Service (initialise, runAction)+import Development.IDE.Core.Shake (+    IdeState (shakeExtras),+    ShakeExtras (state),+    uses,+ )+import Development.IDE.Core.Tracing (measureMemory)+import Development.IDE.LSP.LanguageServer (runLanguageServer)+import Development.IDE.Plugin (+    Plugin (pluginHandlers, pluginRules),+ )+import Development.IDE.Plugin.HLS (asGhcIdePlugin)+import Development.IDE.Session (SessionLoadingOptions, loadSessionWithOptions, setInitialDynFlags, getHieDbLoc, runWithDb)+import Development.IDE.Types.Location (toNormalizedFilePath')+import Development.IDE.Types.Logger (Logger)+import Development.IDE.Types.Options (+    IdeGhcSession,+    IdeOptions (optCheckParents, optCheckProject, optReportProgress),+    clientSupportsProgress,+    defaultIdeOptions,+ )+import Development.IDE.Types.Shake (Key (Key))+import Development.Shake (action)+import HIE.Bios.Cradle (findCradle)+import Ide.Plugin.Config (CheckParents (NeverCheck), Config, getConfigFromNotification)+import Ide.PluginUtils (allLspCmdIds', getProcessID, pluginDescToIdePlugins)+import Ide.Types (IdePlugins)+import qualified Language.LSP.Server as LSP+import qualified System.Directory.Extra as IO+import System.Exit (ExitCode (ExitFailure), exitWith)+import System.FilePath (takeExtension, takeFileName)+import System.IO (hPutStrLn, hSetEncoding, stderr, stdout, utf8)+import System.Time.Extra (offsetTime, showDuration)+import Text.Printf (printf)+import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide++data Arguments = Arguments+    { argsOTMemoryProfiling :: Bool+    , argFiles :: Maybe [FilePath]   -- ^ Nothing: lsp server ;  Just: typecheck and exit+    , argsLogger :: Logger+    , argsRules :: Rules ()+    , argsHlsPlugins :: IdePlugins IdeState+    , argsGhcidePlugin :: Plugin Config  -- ^ Deprecated+    , argsSessionLoadingOptions :: SessionLoadingOptions+    , argsIdeOptions :: Maybe Config -> Action IdeGhcSession -> IdeOptions+    , argsLspOptions :: LSP.Options+    , argsDefaultHlsConfig :: Config+    , argsGetHieDbLoc :: FilePath -> IO FilePath -- ^ Map project roots to the location of the hiedb for the project+    }++instance Default Arguments where+    def = Arguments+        { argsOTMemoryProfiling = False+        , argFiles = Nothing+        , argsLogger = noLogging+        , argsRules = mainRule >> action kick+        , argsGhcidePlugin = mempty+        , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors+        , argsSessionLoadingOptions = def+        , argsIdeOptions = const defaultIdeOptions+        , argsLspOptions = def {LSP.completionTriggerCharacters = Just "."}+        , argsDefaultHlsConfig = def+        , argsGetHieDbLoc = getHieDbLoc+        }++defaultMain :: Arguments -> IO ()+defaultMain Arguments{..} = do+    pid <- T.pack . show <$> getProcessID++    let hlsPlugin = asGhcIdePlugin argsHlsPlugins+        hlsCommands = allLspCmdIds' pid argsHlsPlugins+        plugins = hlsPlugin <> argsGhcidePlugin+        options = argsLspOptions { LSP.executeCommandCommands = Just hlsCommands }+        argsOnConfigChange _ide = pure . getConfigFromNotification argsDefaultHlsConfig+        rules = argsRules >> pluginRules plugins++    case argFiles of+        Nothing -> do+            t <- offsetTime+            hPutStrLn stderr "Starting LSP server..."+            hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"+            runLanguageServer options argsGetHieDbLoc argsOnConfigChange (pluginHandlers plugins) $ \env vfs rootPath hiedb hieChan -> do+                t <- t+                hPutStrLn stderr $ "Started LSP server in " ++ showDuration t++                dir <- IO.getCurrentDirectory++                -- We want to set the global DynFlags right now, so that we can use+                -- `unsafeGlobalDynFlags` even before the project is configured+                -- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath')+                -- before calling this function+                _mlibdir <-+                    setInitialDynFlags argsSessionLoadingOptions+                        `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)++                sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions $ fromMaybe dir rootPath+                config <- LSP.runLspT env LSP.getConfig+                let options = (argsIdeOptions config sessionLoader)+                            { optReportProgress = clientSupportsProgress caps+                            }+                    caps = LSP.resClientCapabilities env+                debouncer <- newAsyncDebouncer+                initialise+                    rules+                    (Just env)+                    argsLogger+                    debouncer+                    options+                    vfs+                    hiedb+                    hieChan+        Just argFiles -> do+          dir <- IO.getCurrentDirectory+          dbLoc <- getHieDbLoc dir+          runWithDb dbLoc $ \hiedb hieChan -> do+            -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error+            hSetEncoding stdout utf8+            hSetEncoding stderr utf8++            putStrLn $ "ghcide setup tester in " ++ dir ++ "."+            putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues"++            putStrLn $ "\nStep 1/4: Finding files to test in " ++ dir+            files <- expandFiles (argFiles ++ ["." | null argFiles])+            -- LSP works with absolute file paths, so try and behave similarly+            files <- nubOrd <$> mapM IO.canonicalizePath files+            putStrLn $ "Found " ++ show (length files) ++ " files"++            putStrLn "\nStep 2/4: Looking for hie.yaml files that control setup"+            cradles <- mapM findCradle files+            let ucradles = nubOrd cradles+            let n = length ucradles+            putStrLn $ "Found " ++ show n ++ " cradle" ++ ['s' | n /= 1]+            when (n > 0) $ putStrLn $ "  (" ++ intercalate ", " (catMaybes ucradles) ++ ")"+            putStrLn "\nStep 3/4: Initializing the IDE"+            vfs <- makeVFSHandle+            debouncer <- newAsyncDebouncer+            sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions dir+            let options = (argsIdeOptions Nothing sessionLoader)+                        { optCheckParents = pure NeverCheck+                        , optCheckProject = pure False+                        }+            ide <- initialise rules Nothing argsLogger debouncer options vfs hiedb hieChan++            putStrLn "\nStep 4/4: Type checking the files"+            setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') files+            results <- runAction "User TypeCheck" ide $ uses TypeCheck (map toNormalizedFilePath' files)+            _results <- runAction "GetHie" ide $ uses GetHieAst (map toNormalizedFilePath' files)+            _results <- runAction "GenerateCore" ide $ uses GenerateCore (map toNormalizedFilePath' files)+            let (worked, failed) = partition fst $ zip (map isJust results) files+            when (failed /= []) $+                putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed++            let nfiles xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"+            putStrLn $ "\nCompleted (" ++ nfiles worked ++ " worked, " ++ nfiles failed ++ " failed)"++            when argsOTMemoryProfiling $ do+                let valuesRef = state $ shakeExtras ide+                values <- readVar valuesRef+                let consoleObserver Nothing = return $ \size -> printf "Total: %.2fMB\n" (fromIntegral @Int @Double size / 1e6)+                    consoleObserver (Just k) = return $ \size -> printf "  - %s: %.2fKB\n" (show k) (fromIntegral @Int @Double size / 1e3)++                printf "# Shake value store contents(%d):\n" (length values)+                let keys =+                        nub $+                            Key GhcSession :+                            Key GhcSessionDeps :+                            [k | (_, k) <- HashMap.keys values, k /= Key GhcSessionIO]+                            ++ [Key GhcSessionIO]+                measureMemory argsLogger [keys] consoleObserver valuesRef++            unless (null failed) (exitWith $ ExitFailure (length failed))+{-# ANN defaultMain ("HLint: ignore Use nubOrd" :: String) #-}++expandFiles :: [FilePath] -> IO [FilePath]+expandFiles = concatMapM $ \x -> do+    b <- IO.doesFileExist x+    if b+        then return [x]+        else do+            let recurse "." = True+                recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc+                recurse x = takeFileName x `notElem` ["dist", "dist-newstyle"] -- cabal directories+            files <- filter (\x -> takeExtension x `elem` [".hs", ".lhs"]) <$> IO.listFilesInside (return . recurse) x+            when (null files) $+                fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x+            return files

@@ -1,22 +1,21 @@-module Development.IDE.Plugin-  ( Plugin(..)-  ) where+module Development.IDE.Plugin ( Plugin(..) ) where  import Data.Default import Development.Shake-import Development.IDE.LSP.Server +import Development.IDE.LSP.Server+import qualified Language.LSP.Server as LSP  data Plugin c = Plugin     {pluginRules :: Rules ()-    ,pluginHandler :: PartialHandlers c+    ,pluginHandlers :: LSP.Handlers (ServerM c)     }  instance Default (Plugin c) where-    def = Plugin mempty def+    def = Plugin mempty mempty  instance Semigroup (Plugin c) where-    Plugin x1 y1 <> Plugin x2 y2 = Plugin (x1<>x2) (y1<>y2)+    Plugin x1 h1 <> Plugin x2 h2 = Plugin (x1<>x2) (h1 <> h2)  instance Monoid (Plugin c) where     mempty = def

@@ -2,7 +2,9 @@ -- SPDX-License-Identifier: Apache-2.0  {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE CPP                   #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-} #include "ghc-api-version.h"  -- | Go to the definition of a variable.@@ -14,6 +16,7 @@     ) where  import Control.Monad (join, guard)+import Control.Monad.IO.Class import Development.IDE.GHC.Compat import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes@@ -29,9 +32,9 @@ import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified Data.HashMap.Strict as Map-import qualified Language.Haskell.LSP.Core as LSP-import Language.Haskell.LSP.VFS-import Language.Haskell.LSP.Types+import qualified Language.LSP.Server as LSP+import Language.LSP.VFS+import Language.LSP.Types import qualified Data.Rope.UTF16 as Rope import Data.Char import Data.Maybe@@ -58,42 +61,49 @@ import qualified GHC.LanguageExtensions as Lang import Control.Lens (alaf) import Data.Monoid (Ap(..))+import TcRnTypes (TcGblEnv(..), ImportAvails(..))+import HscTypes (ImportedModsVal(..), importedByUser)+import RdrName (GlobalRdrElt(..), lookupGlobalRdrEnv)+import SrcLoc (realSrcSpanStart)+import Module (moduleEnvElts)+import qualified Data.Map as M+import qualified Data.Set as S  descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId =   (defaultPluginDescriptor plId)     { pluginRules = mempty,-      pluginCodeActionProvider = Just codeAction+      pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction     }  -- | Generate code actions. codeAction-    :: LSP.LspFuncs c-    -> IdeState+    :: IdeState     -> PluginId-    -> TextDocumentIdentifier-    -> Range-    -> CodeActionContext-    -> IO (Either ResponseError (List CAResult))-codeAction lsp state _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do-    contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri+    -> CodeActionParams+    -> LSP.LspM c (Either ResponseError (List (Command |? CodeAction)))+codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs}) = do+  contents <- LSP.getVirtualFile $ toNormalizedUri uri+  liftIO $ do     let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents         mbFile = toNormalizedFilePath' <$> uriToFilePath uri     diag <- fmap (\(_, _, d) -> d) . filter (\(p, _, _) -> mbFile == Just p) <$> getDiagnostics state-    (ideOptions, join -> parsedModule, join -> env, join -> annotatedPS) <- runAction "CodeAction" state $-      (,,,) <$> getIdeOptions+    (ideOptions, join -> parsedModule, join -> env, join -> annotatedPS, join -> tcM, join -> har) <- runAction "CodeAction" state $+      (,,,,,) <$> getIdeOptions             <*> getParsedModule `traverse` mbFile             <*> use GhcSession `traverse` mbFile             <*> use GetAnnotatedParsedSource `traverse` mbFile+            <*> use TypeCheck `traverse` mbFile+            <*> use GetHieAst `traverse` mbFile     -- This is quite expensive 0.6-0.7s on GHC-    let pkgExports = envPackageExports <$> env+    pkgExports   <- maybe mempty envPackageExports env     localExports <- readVar (exportsMap $ shakeExtras state)     let-      exportsMap = localExports <> fromMaybe mempty pkgExports+      exportsMap = localExports <> pkgExports       df = ms_hspp_opts . pm_mod_summary <$> parsedModule       actions =         [ mkCA title  [x] edit-        | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS x+        | x <- xs, (title, tedit) <- suggestAction exportsMap ideOptions parsedModule text df annotatedPS tcM har x         , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing         ]       actions' = caRemoveRedundantImports parsedModule text diag xs uri@@ -101,9 +111,9 @@                <> caRemoveInvalidExports parsedModule text diag xs uri     pure $ Right $ List actions' -mkCA :: T.Text -> [Diagnostic] -> WorkspaceEdit -> CAResult+mkCA :: T.Text -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction) mkCA title diags edit =-  CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List diags) (Just edit) Nothing+  InR $ CodeAction title (Just CodeActionQuickFix) (Just $ List diags) Nothing Nothing (Just edit) Nothing  rewrite ::     Maybe DynFlags ->@@ -123,9 +133,11 @@   -> Maybe T.Text   -> Maybe DynFlags   -> Maybe (Annotated ParsedSource)+  -> Maybe TcModuleResult+  -> Maybe HieAstResult   -> Diagnostic   -> [(T.Text, [TextEdit])]-suggestAction packageExports ideOptions parsedModule text df annSource diag =+suggestAction packageExports ideOptions parsedModule text df annSource tcM har diag =     concat    -- Order these suggestions by priority     [ suggestSignature True diag@@ -140,6 +152,7 @@     , suggestAddTypeAnnotationToSatisfyContraints text diag     , rewrite df annSource $ \df ps -> suggestConstraint df ps diag     , rewrite df annSource $ \_ ps -> suggestImplicitParameter ps diag+    , rewrite df annSource $ \_ ps -> suggestHideShadow ps tcM har diag     ] ++ concat     [  suggestNewDefinition ideOptions pm text diag     ++ suggestNewImport packageExports pm diag@@ -169,9 +182,84 @@ findDeclContainingLoc :: Position -> [Located a] -> Maybe (Located a) findDeclContainingLoc loc = find (\(L l _) -> loc `isInsideSrcSpan` l) +-- Single:+-- This binding for ‘mod’ shadows the existing binding+--   imported from ‘Prelude’ at haskell-language-server/ghcide/src/Development/IDE/Plugin/CodeAction.hs:10:8-40+--   (and originally defined in ‘GHC.Real’)typecheck(-Wname-shadowing)+-- Multi:+--This binding for ‘pack’ shadows the existing bindings+--  imported from ‘Data.ByteString’ at B.hs:6:1-22+--  imported from ‘Data.ByteString.Lazy’ at B.hs:8:1-27+--  imported from ‘Data.Text’ at B.hs:7:1-16+suggestHideShadow :: ParsedSource -> Maybe TcModuleResult -> Maybe HieAstResult -> Diagnostic -> [(T.Text, [Rewrite])]+suggestHideShadow pm@(L _ HsModule {hsmodImports}) mTcM mHar Diagnostic {_message, _range}+  | Just [identifier, modName, s] <-+      matchRegexUnifySpaces+        _message+        "This binding for ‘([^`]+)’ shadows the existing binding imported from ‘([^`]+)’ at ([^ ]*)" =+    suggests identifier modName s+  | Just [identifier] <-+      matchRegexUnifySpaces+        _message+        "This binding for ‘([^`]+)’ shadows the existing bindings",+    Just matched <- allMatchRegexUnifySpaces _message "imported from ‘([^’]+)’ at ([^ ]*)",+    mods <- [(modName, s) | [_, modName, s] <- matched],+    result <- nubOrdBy (compare `on` fst) $ mods >>= uncurry (suggests identifier),+    hideAll <- ("Hide " <> identifier <> " from all occurence imports", concat $ snd <$> result) =+    result <> [hideAll]+  | otherwise = []+  where+    suggests identifier modName s+      | Just tcM <- mTcM,+        Just har <- mHar,+        [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s],+        isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s'),+        mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName,+        title <- "Hide " <> identifier <> " from " <> modName =+        if modName == "Prelude" && null mDecl+          then [(title, maybeToList $ hideImplicitPreludeSymbol (T.unpack identifier) pm)]+          else maybeToList $ (title,) . pure . hideSymbol (T.unpack identifier) <$> mDecl+      | otherwise = []++findImportDeclByModuleName :: [LImportDecl GhcPs] -> String -> Maybe (LImportDecl GhcPs)+findImportDeclByModuleName decls modName = flip find decls $ \case+  (L _ ImportDecl {..}) -> modName == moduleNameString (unLoc ideclName)+  _ -> error "impossible"++isTheSameLine :: SrcSpan -> SrcSpan -> Bool+isTheSameLine s1 s2+  | Just sl1 <- getStartLine s1,+    Just sl2 <- getStartLine s2 =+    sl1 == sl2+  | otherwise = False+  where+    getStartLine x = srcLocLine . realSrcSpanStart <$> realSpan x++isUnusedImportedId :: TcModuleResult -> HieAstResult -> String -> String -> SrcSpan -> Bool+isUnusedImportedId+  TcModuleResult {tmrTypechecked = TcGblEnv {tcg_imports = ImportAvails {imp_mods}}}+  HAR {refMap}+  identifier+  modName+  importSpan+    | occ <- mkVarOcc identifier,+      impModsVals <- importedByUser . concat $ moduleEnvElts imp_mods,+      Just rdrEnv <-+        listToMaybe+          [ imv_all_exports+            | ImportedModsVal {..} <- impModsVals,+              imv_name == mkModuleName modName,+              isTheSameLine imv_span importSpan+          ],+      [GRE {..}] <- lookupGlobalRdrEnv rdrEnv occ,+      importedIdentifier <- Right gre_name,+      refs <- M.lookup importedIdentifier refMap =+      maybe True (not . any (\(_, IdentifierDetails {..}) -> identInfo == S.singleton Use)) refs+    | otherwise = False+ suggestDisableWarning :: ParsedModule -> Maybe T.Text -> Diagnostic -> [(T.Text, [TextEdit])] suggestDisableWarning pm contents Diagnostic{..}-    | Just (StringValue (T.stripPrefix "-W" -> Just w)) <- _code =+    | Just (InR (T.stripPrefix "-W" -> Just w)) <- _code =         pure             ( "Disable \"" <> w <> "\" warnings"             , [TextEdit (endOfModuleHeader pm contents) $ "{-# OPTIONS_GHC -Wno-" <> w <> " #-}\n"]@@ -197,7 +285,7 @@         = [("Remove import", [TextEdit (extendToWholeLineIfPossible contents _range) ""])]     | otherwise = [] -caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [CAResult]+caRemoveRedundantImports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] caRemoveRedundantImports m contents digs ctxDigs uri   | Just pm <- m,     r <- join $ map (\d -> repeat d `zip` suggestRemoveRedundantImport pm contents d) digs,@@ -212,16 +300,18 @@     removeSingle title tedit diagnostic = mkCA title [diagnostic] WorkspaceEdit{..} where         _changes = Just $ Map.singleton uri $ List tedit         _documentChanges = Nothing-    removeAll tedit = CACodeAction CodeAction {..} where+    removeAll tedit = InR $ CodeAction{..} where         _changes = Just $ Map.singleton uri $ List tedit         _title = "Remove all redundant imports"         _kind = Just CodeActionQuickFix         _diagnostics = Nothing         _documentChanges = Nothing         _edit = Just WorkspaceEdit{..}+        _isPreferred = Nothing         _command = Nothing+        _disabled = Nothing -caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [CAResult]+caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] caRemoveInvalidExports m contents digs ctxDigs uri   | Just pm <- m,     Just txt <- contents,@@ -245,7 +335,7 @@       | otherwise = Nothing      removeSingle (_, _, []) = Nothing-    removeSingle (title, diagnostic, ranges) = Just $ CACodeAction CodeAction{..} where+    removeSingle (title, diagnostic, ranges) = Just $ InR $ CodeAction{..} where         tedit = concatMap (\r -> [TextEdit r ""]) $ nubOrd ranges         _changes = Just $ Map.singleton uri $ List tedit         _title = title@@ -254,8 +344,10 @@         _documentChanges = Nothing         _edit = Just WorkspaceEdit{..}         _command = Nothing+        _isPreferred = Nothing+        _disabled = Nothing     removeAll [] = Nothing-    removeAll ranges = Just $ CACodeAction CodeAction {..} where+    removeAll ranges = Just $ InR $ CodeAction{..} where         tedit = concatMap (\r -> [TextEdit r ""]) ranges         _changes = Just $ Map.singleton uri $ List tedit         _title = "Remove all redundant exports"@@ -264,6 +356,8 @@         _documentChanges = Nothing         _edit = Just WorkspaceEdit{..}         _command = Nothing+        _isPreferred = Nothing+        _disabled = Nothing  suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Range]) suggestRemoveRedundantExport ParsedModule{pm_parsed_source = L _ HsModule{..}} Diagnostic{..}@@ -614,7 +708,7 @@       Valid refinement hole fits include         fromMaybe (_ :: LSP.Handlers) (_ :: Maybe LSP.Handlers)         fromJust (_ :: Maybe LSP.Handlers)-        haskell-lsp-types-0.22.0.0:Language.Haskell.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams+        haskell-lsp-types-0.22.0.0:Language.LSP.Types.Window.$sel:_value:ProgressParams (_ :: ProgressParams                                                                                                         LSP.Handlers)         T.foldl (_ :: LSP.Handlers -> Char -> LSP.Handlers)                 (_ :: LSP.Handlers)

@@ -31,18 +31,18 @@ import Development.IDE.GHC.ExactPrint     ( Annotate, ASTElement(parseAST) ) import FieldLabel (flLabel)-import GhcPlugins (sigPrec)+import GhcPlugins (sigPrec, mkRealSrcLoc) import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), KeywordId (G), mkAnnKey)-import Language.Haskell.LSP.Types+import Language.LSP.Types import OccName import Outputable (ppr, showSDocUnsafe, showSDoc) import Retrie.GHC (rdrNameOcc, unpackFS, mkRealSrcSpan, realSrcSpanEnd) import Development.IDE.Spans.Common import Development.IDE.GHC.Error-import Safe (lastMay) import Data.Generics (listify) import GHC.Exts (IsList (fromList))+import Control.Monad.Extra (whenJust)  ------------------------------------------------------------------------------ @@ -205,6 +205,7 @@ -- extendImportTopLevel "foo" AST: -- -- import A --> Error+-- import A (foo) --> Error -- import A (bar) --> import A (bar, foo) extendImportTopLevel :: DynFlags -> String -> LImportDecl GhcPs -> TransformT (Either String) (LImportDecl GhcPs) extendImportTopLevel df idnetifier (L l it@ImportDecl {..})@@ -382,6 +383,8 @@         lidecl' = L l $ idecl             { ideclHiding = Just (False, edited)             }+    -- avoid import A (foo,)+    whenJust (lastMaybe deletedLies) removeTrailingCommaT     when (not (null lies) && null deletedLies) $ do         transferAnn llies edited id         addSimpleAnnT edited dp00@@ -408,13 +411,16 @@                   (filter ((/= symbol) . T.pack . unpackFS . flLabel . unLoc) flds)         killLie v = Just v +-- | Insert a import declaration hiding a symbole from Prelude hideImplicitPreludeSymbol     :: String -> ParsedSource -> Maybe Rewrite hideImplicitPreludeSymbol symbol (L _ HsModule{..}) = do-    existingImp <- lastMay hsmodImports-    exisImpSpan <- realSpan $ getLoc existingImp-    let indentation = srcSpanStartCol exisImpSpan-        beg = realSrcSpanEnd exisImpSpan+    let predLine old = mkRealSrcLoc (srcLocFile old) (srcLocLine old - 1) (srcLocCol old)+        existingImpSpan =  (fmap (id,) . realSpan . getLoc) =<< lastMaybe hsmodImports+        existingDeclSpan = (fmap (predLine, ) . realSpan . getLoc) =<< headMaybe hsmodDecls+    (f, s) <- existingImpSpan <|> existingDeclSpan+    let beg = f $ realSrcSpanEnd s+        indentation = srcSpanStartCol s         ran = RealSrcSpan $ mkRealSrcSpan beg beg     pure $ Rewrite ran $ \df -> do         let symOcc = mkVarOcc symbol@@ -424,6 +430,6 @@         -- Re-labeling is needed to reflect annotations correctly         L _ idecl0 <- liftParseAST @(ImportDecl GhcPs) df $ T.unpack impStmt         let idecl = L ran idecl0-        addSimpleAnnT idecl (DP (1,indentation - 1))+        addSimpleAnnT idecl (DP (1, indentation - 1))             [(G AnnImport, DP (1, indentation - 1))]         pure idecl

@@ -12,7 +12,7 @@  import           Data.Char import           Data.List-import           Language.Haskell.LSP.Types+import           Language.LSP.Types  type PositionIndexed a = [(Position, a)] 

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP          #-}+{-# LANGUAGE RankNTypes   #-} {-# LANGUAGE TypeFamilies #-} #include "ghc-api-version.h" @@ -7,16 +8,17 @@     , LocalCompletions(..)     , NonLocalCompletions(..)     ) where-import Language.Haskell.LSP.Types-import qualified Language.Haskell.LSP.Core as LSP-import qualified Language.Haskell.LSP.VFS as VFS  import Control.Monad+import Control.Monad.Extra import Control.Monad.Trans.Maybe import Data.Aeson import Data.List (find) import Data.Maybe import qualified Data.Text as T+import Language.LSP.Types+import qualified Language.LSP.Server as LSP+import qualified Language.LSP.VFS as VFS import Development.Shake.Classes import Development.Shake import GHC.Generics@@ -36,16 +38,16 @@ import Ide.Types import TcRnDriver (tcRnImportDecls) import Control.Concurrent.Async (concurrently)-#if defined(GHC_LIB)-import Development.IDE.Import.DependencyInformation-#endif+import GHC.Exts (toList)+import Development.IDE.GHC.Error (rangeToSrcSpan)+import Development.IDE.GHC.Util (prettyPrint)  descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId)-    { pluginRules = produceCompletions,-      pluginCompletionProvider = Just (getCompletionsLSP plId),-      pluginCommands = [extendImportCommand]-    }+  { pluginRules = produceCompletions+  , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP+  , pluginCommands = [extendImportCommand]+  }  produceCompletions :: Rules () produceCompletions = do@@ -64,15 +66,6 @@         ms <- fmap fst <$> useWithStale GetModSummaryWithoutTimestamps file         sess <- fmap fst <$> useWithStale GhcSessionDeps file --- When possible, rely on the haddocks embedded in our interface files--- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'-#if !defined(GHC_LIB)-        let parsedDeps = []-#else-        deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file-        parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)-#endif-         case (ms, sess) of             (Just (ms,imps), Just sess) -> do               let env = hscEnv sess@@ -81,7 +74,7 @@               case (global, inScope) of                   ((_, Just globalEnv), (_, Just inScopeEnv)) -> do                       let uri = fromNormalizedUri $ normalizedFilePathToUri file-                      cdata <- liftIO $ cacheDataProducer uri env (ms_mod ms) globalEnv inScopeEnv imps parsedDeps+                      cdata <- liftIO $ cacheDataProducer uri sess (ms_mod ms) globalEnv inScopeEnv imps                       return ([], Just cdata)                   (_diag, _) ->                       return ([], Nothing)@@ -115,20 +108,19 @@  -- | Generate code actions. getCompletionsLSP-    :: PluginId-    -> LSP.LspFuncs Config-    -> IdeState+    :: IdeState+    -> PluginId     -> CompletionParams-    -> IO (Either ResponseError CompletionResponseResult)-getCompletionsLSP plId lsp ide+    -> LSP.LspM Config (Either ResponseError (ResponseResult TextDocumentCompletion))+getCompletionsLSP ide plId   CompletionParams{_textDocument=TextDocumentIdentifier uri                   ,_position=position                   ,_context=completionContext} = do-    contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri+    contents <- LSP.getVirtualFile $ toNormalizedUri uri     fmap Right $ case (contents, uriToFilePath' uri) of       (Just cnts, Just path) -> do         let npath = toNormalizedFilePath' path-        (ideOpts, compls) <- runIdeAction "Completion" (shakeExtras ide) $ do+        (ideOpts, compls) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do             opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide             localCompls <- useWithStaleFast LocalCompletions npath             nonLocalCompls <- useWithStaleFast NonLocalCompletions npath@@ -140,16 +132,16 @@             pfix <- VFS.getCompletionPrefix position cnts             case (pfix, completionContext) of               (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})-                -> return (Completions $ List [])+                -> return (InL $ List [])               (Just pfix', _) -> do                 let clientCaps = clientCapabilities $ shakeExtras ide-                config <- getClientConfig lsp+                config <- getClientConfig                 let snippets = WithSnippets . completionSnippetsOn $ config-                allCompletions <- getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps snippets-                pure $ Completions (List allCompletions)-              _ -> return (Completions $ List [])-          _ -> return (Completions $ List [])-      _ -> return (Completions $ List [])+                allCompletions <- liftIO $ getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps snippets+                pure $ InL (List allCompletions)+              _ -> return (InL $ List [])+          _ -> return (InL $ List [])+      _ -> return (InL $ List [])  ---------------------------------------------------------------------------------------------------- @@ -158,16 +150,29 @@   PluginCommand (CommandId extendImportCommandId) "additional edits for a completion" extendImportHandler  extendImportHandler :: CommandFunction IdeState ExtendImport-extendImportHandler _lsp ideState edit = do-  res <- runMaybeT $ extendImportHandler' ideState edit-  return (Right Null, res)+extendImportHandler ideState edit@ExtendImport {..} = do+  res <- liftIO $ runMaybeT $ extendImportHandler' ideState edit+  whenJust res $ \(nfp, wedit@WorkspaceEdit {_changes}) -> do+    let (_, List (head -> TextEdit {_range})) = fromJust $ _changes >>= listToMaybe . toList+        srcSpan = rangeToSrcSpan nfp _range+    LSP.sendNotification SWindowShowMessage $+      ShowMessageParams MtInfo $+        "Import "+          <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent+          <> "’ from "+          <> importName+          <> " (at "+          <> T.pack (prettyPrint srcSpan)+          <> ")"+    void $ LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())+  return $ Right Null -extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (ServerMethod, ApplyWorkspaceEditParams)+extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit) extendImportHandler' ideState ExtendImport {..}   | Just fp <- uriToFilePath doc,     nfp <- toNormalizedFilePath' fp =     do-      (ms, ps, imps) <- MaybeT $+      (ms, ps, imps) <- MaybeT $ liftIO $         runAction "extend import" ideState $           runMaybeT $ do             -- We want accurate edits, so do not use stale data here@@ -178,11 +183,9 @@           wantedModule = mkModuleName (T.unpack importName)           wantedQual = mkModuleName . T.unpack <$> importQual       imp <- liftMaybe $ find (isWantedModule wantedModule wantedQual) imps-      wedit <--        liftEither $-          rewriteToWEdit df doc (annsA ps) $-            extendImport (T.unpack <$> thingParent) (T.unpack newThing) imp-      return (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit)+      fmap (nfp,) $ liftEither $+        rewriteToWEdit df doc (annsA ps) $+          extendImport (T.unpack <$> thingParent) (T.unpack newThing) imp   | otherwise =     mzero 

@@ -27,16 +27,15 @@ import Name import RdrName import Type-import Packages #if MIN_GHC_API_VERSION(8,10,0) import Predicate (isDictTy) import Pair import Coercion #endif -import Language.Haskell.LSP.Types-import Language.Haskell.LSP.Types.Capabilities-import qualified Language.Haskell.LSP.VFS as VFS+import Language.LSP.Types+import Language.LSP.Types.Capabilities+import qualified Language.LSP.VFS as VFS import Development.IDE.Core.Compile import Development.IDE.Core.PositionMapping import Development.IDE.Plugin.Completions.Types@@ -59,6 +58,7 @@ import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), PluginId, WithSnippets (..)) import Control.Monad+import Development.IDE.Types.HscEnvEq  -- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs @@ -203,16 +203,16 @@                         T.intercalate sectionSeparator docs'  mkAdditionalEditsCommand :: PluginId -> ExtendImport -> IO Command-mkAdditionalEditsCommand pId edits =+mkAdditionalEditsCommand pId edits = pure $   mkLspCommand pId (CommandId extendImportCommandId) "extend import" (Just [toJSON edits]) -mkNameCompItem :: Uri -> Maybe T.Text -> Name -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem+mkNameCompItem :: Uri -> Maybe T.Text -> OccName -> ModuleName -> Maybe Type -> Maybe Backtick -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem mkNameCompItem doc thingParent origName origMod thingType isInfix docs !imp = CI {..}   where-    compKind = occNameToComKind typeText $ occName origName+    compKind = occNameToComKind typeText origName     importedFrom = Right $ showModName origMod-    isTypeCompl = isTcOcc $ occName origName-    label = showGhc origName+    isTypeCompl = isTcOcc origName+    label = stripPrefix $ showGhc origName     insertText = case isInfix of             Nothing -> case getArgText <$> thingType of                             Nothing -> label@@ -294,9 +294,10 @@     Nothing Nothing Nothing Nothing Nothing  -cacheDataProducer :: Uri -> HscEnv -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> [ParsedModule] -> IO CachedCompletions-cacheDataProducer uri packageState curMod globalEnv inScopeEnv limports deps = do-  let dflags = hsc_dflags packageState+cacheDataProducer :: Uri -> HscEnvEq -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> IO CachedCompletions+cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do+  let+      packageState = hscEnv env       curModName = moduleName curMod        importMap = Map.fromList [ (getLoc imp, imp) | imp <- limports ]@@ -309,8 +310,6 @@       -- Full canonical names of imported modules       importDeclerations = map unLoc limports -      -- The list of all importable Modules from all packages-      moduleNames = map showModName (listVisibleModuleNames dflags)        -- The given namespaces for the imported modules (ie. full name, or alias if used)       allModNamesAsNS = map (showModName . asNamespace) importDeclerations@@ -344,11 +343,11 @@        toCompItem :: Parent -> Module -> ModuleName -> Name -> Maybe (LImportDecl GhcPs) -> IO [CompItem]       toCompItem par m mn n imp' = do-        docs <- getDocumentationTryGhc packageState curMod deps n-        let mbParent = case par of-                            NoParent -> Nothing-                            ParentIs n -> Just (showNameWithoutUniques n)-                            FldParent n _ -> Just (showNameWithoutUniques n)+        docs <- getDocumentationTryGhc packageState curMod n+        let (mbParent, originName) = case par of+                            NoParent -> (Nothing, nameOccName n)+                            ParentIs n' -> (Just $ showNameWithoutUniques n', nameOccName n)+                            FldParent n' lbl -> (Just $ showNameWithoutUniques n', maybe (nameOccName n) mkVarOccFS lbl)         tys <- catchSrcErrors (hsc_dflags packageState) "completion" $ do                 name' <- lookupName packageState m n                 return ( name' >>= safeTyThingType@@ -361,11 +360,14 @@                     [mkRecordSnippetCompItem uri mbParent  ctxStr flds (ppr mn) docs imp']                 _ -> [] -        return $ mkNameCompItem uri mbParent n mn ty Nothing docs imp'+        return $ mkNameCompItem uri mbParent originName mn ty Nothing docs imp'                : recordCompls    (unquals,quals) <- getCompls rdrElts +  -- The list of all importable Modules from all packages+  moduleNames <- maybe [] (map showModName) <$> envVisibleModuleNames env+   return $ CC     { allModNamesAsNS = allModNamesAsNS     , unqualCompls = unquals@@ -588,7 +590,7 @@     -> return $ filtPragmaCompls (pragmaSuffix fullLine)     | otherwise -> do         let uniqueFiltCompls = nubOrdOn insertText filtCompls-        compls <- mapM (mkCompl plId ideOpts . stripAutoGenerated) uniqueFiltCompls+        compls <- mapM (mkCompl plId ideOpts) uniqueFiltCompls         return $ filtModNameCompls               ++ filtKeywordCompls               ++ map ( toggleSnippets caps withSnippets) compls@@ -657,16 +659,11 @@  -- | Under certain circumstance GHC generates some extra stuff that we -- don't want in the autocompleted symbols-stripAutoGenerated :: CompItem -> CompItem-stripAutoGenerated ci =-    ci {label = stripPrefix (label ci)}     {- When e.g. DuplicateRecordFields is enabled, compiler generates     names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors     https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation     -}- -- TODO: Turn this into an alex lexer that discards prefixes as if they were whitespace.- stripPrefix :: T.Text -> T.Text stripPrefix name = T.takeWhile (/=':') $ go prefixes   where

@@ -13,7 +13,9 @@ import Data.Aeson (FromJSON, ToJSON) import Data.Text (Text) import GHC.Generics (Generic)-import Language.Haskell.LSP.Types (CompletionItemKind, Uri)+import Language.LSP.Types (CompletionItemKind, Uri)++-- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs  data Backtick = Surrounded | LeftSide   deriving (Eq, Ord, Show)

@@ -1,67 +1,55 @@-{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE GADTs #-}  module Development.IDE.Plugin.HLS     (       asGhcIdePlugin     ) where -import           Control.Exception(SomeException, catch)-import           Control.Lens ((^.))+import           Control.Exception(SomeException) import           Control.Monad import qualified Data.Aeson as J-import qualified Data.DList as DList import           Data.Either import qualified Data.List                     as List import qualified Data.Map  as Map-import           Data.Maybe import qualified Data.Text                     as T import           Development.IDE.Core.Shake import           Development.IDE.LSP.Server import           Development.IDE.Plugin-import           Development.IDE.Plugin.HLS.Formatter-import           GHC.Generics import           Ide.Plugin.Config import           Ide.Types as HLS-import qualified Language.Haskell.LSP.Core as LSP-import           Language.Haskell.LSP.Messages-import           Language.Haskell.LSP.Types-import qualified Language.Haskell.LSP.Types              as J-import qualified Language.Haskell.LSP.Types.Capabilities as C-import           Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting)-import qualified Language.Haskell.LSP.VFS                as VFS+import qualified Language.LSP.Server             as LSP+import qualified Language.LSP.Types              as J+import Language.LSP.Types import           Text.Regex.TDFA.Text() import Development.Shake (Rules)-import Ide.PluginUtils (getClientConfig, pluginEnabled, getPluginConfig, responseError, getProcessID)+import Ide.PluginUtils (getClientConfig) import Development.IDE.Core.Tracing-import Development.IDE.Types.Logger (logDebug)-import Control.Concurrent.Async (mapConcurrently)+import UnliftIO.Async (forConcurrently)+import UnliftIO.Exception (catchAny)+import           Data.Dependent.Map (DMap)+import qualified Data.Dependent.Map as DMap+import           Data.Dependent.Sum+import Data.List.NonEmpty (nonEmpty,NonEmpty,toList)+import UnliftIO (MonadUnliftIO)+import Data.String+import Data.Bifunctor  -- ---------------------------------------------------------------------+-- --- | Map a set of plugins to the underlying ghcide engine.  Main point is--- IdePlugins are arranged by kind of operation, 'Plugin' is arranged by message--- category ('Notifaction', 'Request' etc).+-- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: IdePlugins IdeState -> Plugin Config asGhcIdePlugin mp =-    mkPlugin rulesPlugins (Just . HLS.pluginRules) <>-    mkPlugin executeCommandPlugins (Just . pluginCommands) <>-    mkPlugin codeActionPlugins     pluginCodeActionProvider <>-    mkPlugin codeLensPlugins       pluginCodeLensProvider <>-    -- Note: diagnostics are provided via Rules from pluginDiagnosticProvider-    mkPlugin hoverPlugins          pluginHoverProvider <>-    mkPlugin symbolsPlugins        pluginSymbolsProvider <>-    mkPlugin formatterPlugins      pluginFormattingProvider <>-    mkPlugin completionsPlugins    pluginCompletionProvider <>-    mkPlugin renamePlugins         pluginRenameProvider+    mkPlugin rulesPlugins          HLS.pluginRules <>+    mkPlugin executeCommandPlugins HLS.pluginCommands <>+    mkPlugin extensiblePlugins     HLS.pluginHandlers     where-        justs (p, Just x)  = [(p, x)]-        justs (_, Nothing) = []-         ls = Map.toList (ipMap mp) -        mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> Maybe b) -> Plugin Config+        mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor IdeState -> b) -> Plugin Config         mkPlugin maker selector =-          case concatMap (\(pid, p) -> justs (pid, selector p)) ls of+          case map (second selector) 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@@ -75,418 +63,123 @@     where         rules = foldMap snd rs -codeActionPlugins :: [(PluginId, CodeActionProvider IdeState)] -> Plugin Config-codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas)--codeActionRules :: Rules ()-codeActionRules = mempty--codeActionHandlers :: [(PluginId, CodeActionProvider IdeState)] -> PartialHandlers Config-codeActionHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x-    { LSP.codeActionHandler-        = withResponse RspCodeAction (makeCodeAction cas)-    }--makeCodeAction :: [(PluginId, CodeActionProvider IdeState)]-      -> LSP.LspFuncs Config -> IdeState-      -> CodeActionParams-      -> IO (Either ResponseError (List CAResult))-makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do-    let caps = LSP.clientCapabilities lf-        unL (List ls) = ls-        makeAction (pid,provider) = do-          pluginConfig <- getPluginConfig lf pid-          if pluginEnabled pluginConfig plcCodeActionsOn-            then otTracedProvider pid "codeAction" $ provider lf ideState pid docId range context-            else return $ Right (List [])-    r <- mapConcurrently makeAction cas-    let actions = filter wasRequested . foldMap unL $ rights r-    res <- send caps actions-    return $ Right res-  where-    wasRequested :: CAResult -> Bool-    wasRequested (CACommand _) = True-    wasRequested (CACodeAction ca)-      | Nothing <- only context = True-      | Just (List allowed) <- only context-      , Just caKind <- ca ^. kind = caKind `elem` allowed-      | otherwise = False--    wrapCodeAction :: C.ClientCapabilities -> CAResult -> IO (Maybe CAResult)-    wrapCodeAction _ (CACommand cmd) = return $ Just (CACommand cmd)-    wrapCodeAction caps (CACodeAction action) = do--      let (C.ClientCapabilities _ textDocCaps _ _) = caps-      let literalSupport = textDocCaps >>= C._codeAction >>= C._codeActionLiteralSupport--      case literalSupport of-        Nothing -> do-            let cmdParams = [J.toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))]-            cmd <- mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams)-            return $ Just (CACommand cmd)-        Just _ -> return $ Just (CACodeAction action)--    send :: C.ClientCapabilities -> [CAResult] -> IO (List CAResult)-    send caps codeActions = List . catMaybes <$> mapM (wrapCodeAction caps) codeActions--data FallbackCodeActionParams =-  FallbackCodeActionParams-    { fallbackWorkspaceEdit :: Maybe WorkspaceEdit-    , fallbackCommand       :: Maybe Command-    }-  deriving (Generic, J.ToJSON, J.FromJSON)---- -------------------------------------------------------------codeLensPlugins :: [(PluginId, CodeLensProvider IdeState)] -> Plugin Config-codeLensPlugins cas = Plugin codeLensRules (codeLensHandlers cas)--codeLensRules :: Rules ()-codeLensRules = mempty--codeLensHandlers :: [(PluginId, CodeLensProvider IdeState)] -> PartialHandlers Config-codeLensHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x-    { LSP.codeLensHandler-        = withResponse RspCodeLens (makeCodeLens cas)-    }--makeCodeLens :: [(PluginId, CodeLensProvider IdeState)]-      -> LSP.LspFuncs Config-      -> IdeState-      -> CodeLensParams-      -> IO (Either ResponseError (List CodeLens))-makeCodeLens cas lf ideState params = do-    logDebug (ideLogger ideState) "Plugin.makeCodeLens (ideLogger)" -- AZ-    let-      makeLens (pid, provider) = do-          pluginConfig <- getPluginConfig lf pid-          r <- if pluginEnabled pluginConfig plcCodeLensOn-                 then otTracedProvider pid "codeLens" $ provider lf ideState pid params-                 else return $ Right (List [])-          return (pid, r)-      breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)])-      breakdown ls = (concatMap doOneLeft ls, concatMap doOneRight ls)-        where-          doOneLeft (pid, Left err) = [(pid,err)]-          doOneLeft (_, Right _) = []--          doOneRight (pid, Right a) = [(pid,a)]-          doOneRight (_, Left _) = []--    r <- mapConcurrently makeLens cas-    case breakdown r of-        ([],[]) -> return $ Right $ List []-        (es,[]) -> return $ Left $ ResponseError InternalError (T.pack $ "codeLens failed:" ++ show es) Nothing-        (_,rs) -> return $ Right $ List (concatMap (\(_,List cs) -> cs) rs)---- -----------------------------------------------------------+-- ---------------------------------------------------------------------  executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs) -executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> PartialHandlers Config-executeCommandHandlers ecs = PartialHandlers $ \WithMessage{..} x -> return x{-    LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit (makeExecuteCommands ecs)-    }--makeExecuteCommands :: [(PluginId, [PluginCommand IdeState])] -> LSP.LspFuncs Config -> ExecuteCommandProvider IdeState-makeExecuteCommands ecs lf ide = wrapUnhandledExceptions $ do-  let-      pluginMap = Map.fromList ecs-      parseCmdId :: T.Text -> Maybe (PluginId, CommandId)-      parseCmdId x = case T.splitOn ":" x of-        [plugin, command] -> Just (PluginId plugin, CommandId command)-        [_, plugin, command] -> Just (PluginId plugin, CommandId command)-        _ -> Nothing--      execCmd :: ExecuteCommandParams -> IO (Either ResponseError J.Value, Maybe (ServerMethod, ApplyWorkspaceEditParams))-      execCmd (ExecuteCommandParams cmdId args _) = do-        -- The parameters to the HIE command are always the first element-        let cmdParams :: J.Value-            cmdParams = case args of-             Just (J.List (x:_)) -> x-             _ -> J.Null--        case parseCmdId cmdId of-          -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions-          Just ("hls", "fallbackCodeAction") ->-            case J.fromJSON cmdParams of-              J.Success (FallbackCodeActionParams mEdit mCmd) -> do--                -- Send off the workspace request if it has one-                forM_ mEdit $ \edit -> do-                  let eParams = J.ApplyWorkspaceEditParams edit-                  reqId <- LSP.getNextReqId lf-                  LSP.sendFunc lf $ ReqApplyWorkspaceEdit $ RequestMessage "2.0" reqId WorkspaceApplyEdit eParams--                case mCmd of-                  -- If we have a command, continue to execute it-                  Just (J.Command _ innerCmdId innerArgs)-                      -> execCmd (ExecuteCommandParams innerCmdId innerArgs Nothing)-                  Nothing -> return (Right J.Null, Nothing)--              J.Error _str -> return (Right J.Null, Nothing)--          -- Just an ordinary HIE command-          Just (plugin, cmd) -> runPluginCommand pluginMap lf ide plugin cmd cmdParams+executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config)+executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd+  where+    pluginMap = Map.fromList ecs -          -- Couldn't parse the command identifier-          _ -> return (Left $ ResponseError InvalidParams "Invalid command identifier" Nothing, Nothing)+    parseCmdId :: T.Text -> Maybe (PluginId, CommandId)+    parseCmdId x = case T.splitOn ":" x of+      [plugin, command] -> Just (PluginId plugin, CommandId command)+      [_, plugin, command] -> Just (PluginId plugin, CommandId command)+      _ -> Nothing -  execCmd+    -- The parameters to the HLS command are always the first element +    execCmd ide (ExecuteCommandParams _ cmdId args) = do+      let cmdParams :: J.Value+          cmdParams = case args of+            Just (J.List (x:_)) -> x+            _ -> J.Null+      case parseCmdId cmdId of+        -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions+        Just ("hls", "fallbackCodeAction") ->+          case J.fromJSON cmdParams of+            J.Success (FallbackCodeActionParams mEdit mCmd) -> do --- ------------------------------------------------------------wrapUnhandledExceptions ::-    (a -> IO (Either ResponseError J.Value, Maybe b)) ->-       a -> IO (Either ResponseError J.Value, Maybe b)-wrapUnhandledExceptions action input =-    catch (action input) $ \(e::SomeException) -> do-        let resp = ResponseError InternalError (T.pack $ show e) Nothing-        return (Left resp, Nothing)+              -- Send off the workspace request if it has one+              forM_ mEdit $ \edit ->+                LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) +              case mCmd of+                -- If we have a command, continue to execute it+                Just (J.Command _ innerCmdId innerArgs)+                    -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs)+                Nothing -> return $ Right J.Null --- | Runs a plugin command given a PluginId, CommandId and--- arguments in the form of a JSON object.-runPluginCommand :: Map.Map PluginId [PluginCommand IdeState]-                 -> LSP.LspFuncs Config-                 -> IdeState-                 -> PluginId-                 -> CommandId-                 -> J.Value-                 -> IO (Either ResponseError J.Value,-                        Maybe (ServerMethod, ApplyWorkspaceEditParams))-runPluginCommand m lf ide  p@(PluginId p') com@(CommandId com') arg =-  case Map.lookup p m of-    Nothing -> return-      (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing, Nothing)-    Just xs -> case List.find ((com ==) . commandId) xs of-      Nothing -> return (Left $-        ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p'-                                      <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing, Nothing)-      Just (PluginCommand _ _ f) -> case J.fromJSON arg of-        J.Error err -> return (Left $-          ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p'-                                       <> ": " <> T.pack err-                                       <> "\narg = " <> T.pack (show arg)) Nothing, Nothing)-        J.Success a -> f lf ide a+            J.Error _str -> return $ Right J.Null --- -----------------------------------------------------------+        -- Just an ordinary HIE command+        Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams -mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command-mkLspCommand plid cn title args' = do-  pid <- T.pack . show <$> getProcessID-  let cmdId = mkLspCmdId pid plid cn-  let args = List <$> args'-  return $ Command title cmdId args+        -- Couldn't parse the command identifier+        _ -> return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing -mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text-mkLspCmdId pid (PluginId plid) (CommandId cid)-  = pid <> ":" <> plid <> ":" <> cid+    runPluginCommand ide p@(PluginId p') com@(CommandId com') arg =+      case Map.lookup p pluginMap  of+        Nothing -> return+          (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing)+        Just xs -> case List.find ((com ==) . commandId) xs of+          Nothing -> return $ Left $+            ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p'+                                          <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing+          Just (PluginCommand _ _ f) -> case J.fromJSON arg of+            J.Error err -> return $ Left $+              ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p'+                                           <> ": " <> T.pack err+                                           <> "\narg = " <> T.pack (show arg)) Nothing+            J.Success a -> f ide a  -- --------------------------------------------------------------------- -hoverPlugins :: [(PluginId, HoverProvider IdeState)] -> Plugin Config-hoverPlugins hs = Plugin hoverRules (hoverHandlers hs)--hoverRules :: Rules ()-hoverRules = mempty--hoverHandlers :: [(PluginId, HoverProvider IdeState)] -> PartialHandlers Config-hoverHandlers hps = PartialHandlers $ \WithMessage{..} x ->-  return x{LSP.hoverHandler = withResponse RspHover (makeHover hps)}--makeHover :: [(PluginId, HoverProvider IdeState)]-      -> LSP.LspFuncs Config -> IdeState-      -> TextDocumentPositionParams-      -> IO (Either ResponseError (Maybe Hover))-makeHover hps lf ideState params-  = do-      let-        makeHover(pid,p) = do-          pluginConfig <- getPluginConfig lf pid-          if pluginEnabled pluginConfig plcHoverOn-             then otTracedProvider pid "hover" $ p ideState params-             else return $ Right Nothing-      mhs <- mapConcurrently makeHover hps-      -- TODO: We should support ServerCapabilities and declare that-      -- we don't support hover requests during initialization if we-      -- don't have any hover providers-      -- TODO: maybe only have provider give MarkedString and-      -- work out range here?-      let hs = catMaybes (rights mhs)-          r = listToMaybe $ mapMaybe (^. range) hs-          h = case foldMap (^. contents) hs of-            HoverContentsMS (List []) -> Nothing-            hh                        -> Just $ Hover hh r-      return $ Right h---- ------------------------------------------------------------------------ -----------------------------------------------------------------------symbolsPlugins :: [(PluginId, SymbolsProvider IdeState)] -> Plugin Config-symbolsPlugins hs = Plugin symbolsRules (symbolsHandlers hs)--symbolsRules :: Rules ()-symbolsRules = mempty--symbolsHandlers :: [(PluginId, SymbolsProvider IdeState)] -> PartialHandlers Config-symbolsHandlers hps = PartialHandlers $ \WithMessage{..} x ->-  return x {LSP.documentSymbolHandler = withResponse RspDocumentSymbols (makeSymbols hps)}--makeSymbols :: [(PluginId, SymbolsProvider IdeState)]-      -> LSP.LspFuncs Config-      -> IdeState-      -> DocumentSymbolParams-      -> IO (Either ResponseError DSResult)-makeSymbols sps lf ideState params-  = do-      let uri' = params ^. textDocument . uri-          (C.ClientCapabilities _ tdc _ _) = LSP.clientCapabilities lf-          supportsHierarchy = Just True == (tdc >>= C._documentSymbol >>= C._hierarchicalDocumentSymbolSupport)-          convertSymbols :: [DocumentSymbol] -> DSResult-          convertSymbols symbs-            | supportsHierarchy = DSDocumentSymbols $ List symbs-            | otherwise = DSSymbolInformation (List $ concatMap (go Nothing) symbs)-            where-                go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation]-                go parent ds =-                  let children' :: [SymbolInformation]-                      children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children))-                      loc = Location uri' (ds ^. range)-                      name' = ds ^. name-                      si = SymbolInformation name' (ds ^. kind) (ds ^. deprecated) loc parent-                  in [si] <> children'--          makeSymbols (pid,p) = do-            pluginConfig <- getPluginConfig lf pid-            if pluginEnabled pluginConfig plcSymbolsOn-              then otTracedProvider pid "symbols" $ p lf ideState params-              else return $ Right []-      mhs <- mapConcurrently makeSymbols sps-      case rights mhs of-          [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs-          hs -> return $ Right $ convertSymbols $ concat hs----- ------------------------------------------------------------------------ -----------------------------------------------------------------------renamePlugins :: [(PluginId, RenameProvider IdeState)] -> Plugin Config-renamePlugins providers = Plugin rules handlers+extensiblePlugins :: [(PluginId, PluginHandlers IdeState)] -> Plugin Config+extensiblePlugins xs = Plugin mempty handlers   where-    rules = mempty-    handlers = PartialHandlers $ \WithMessage{..} x -> return x-      { LSP.renameHandler = withResponse RspRename (renameWith providers)}--renameWith ::-  [(PluginId, RenameProvider IdeState)] ->-  LSP.LspFuncs Config ->-  IdeState ->-  RenameParams ->-  IO (Either ResponseError WorkspaceEdit)-renameWith providers lspFuncs state params = do-    let-        makeAction (pid,p) = do-          pluginConfig <- getPluginConfig lspFuncs pid-          if pluginEnabled pluginConfig plcRenameOn-             then otTracedProvider pid "rename" $ p lspFuncs state params-             else return $ Right $ WorkspaceEdit Nothing Nothing-    -- TODO:AZ: we need to consider the right way to combine possible renamers-    results <- mapConcurrently makeAction providers-    case partitionEithers results of-        (errors, []) -> return $ Left $ responseError $ T.pack $ show errors-        (_, edits) -> return $ Right $ mconcat edits---- ------------------------------------------------------------------------ -----------------------------------------------------------------------formatterPlugins :: [(PluginId, FormattingProvider IdeState IO)] -> Plugin Config-formatterPlugins providers-    = Plugin formatterRules-             (formatterHandlers (Map.fromList (("none",noneProvider):providers)))--formatterRules :: Rules ()-formatterRules = mempty--formatterHandlers :: Map.Map PluginId (FormattingProvider IdeState IO) -> PartialHandlers Config-formatterHandlers providers = PartialHandlers $ \WithMessage{..} x -> return x-    { LSP.documentFormattingHandler-        = withResponse RspDocumentFormatting (formatting providers)-    , LSP.documentRangeFormattingHandler-        = withResponse RspDocumentRangeFormatting (rangeFormatting providers)-    }---- ------------------------------------------------------------------------ -----------------------------------------------------------------------completionsPlugins :: [(PluginId, CompletionProvider IdeState)] -> Plugin Config-completionsPlugins cs = Plugin completionsRules (completionsHandlers cs)--completionsRules :: Rules ()-completionsRules = mempty--completionsHandlers :: [(PluginId, CompletionProvider IdeState)] -> PartialHandlers Config-completionsHandlers cps = PartialHandlers $ \WithMessage{..} x ->-  return x {LSP.completionHandler = withResponse RspCompletion (makeCompletions cps)}--makeCompletions :: [(PluginId, CompletionProvider IdeState)]-      -> LSP.LspFuncs Config-      -> IdeState-      -> CompletionParams-      -> IO (Either ResponseError CompletionResponseResult)-makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier doc) pos _context _mt)-  = do-      mprefix <- getPrefixAtPos lf doc pos-      maxCompletions <- maxCompletions <$> getClientConfig lf--      let-          combine :: [CompletionResponseResult] -> CompletionResponseResult-          combine cs = go True mempty cs--          go !comp acc [] =-            CompletionList (CompletionListType comp (List $ DList.toList acc))-          go comp acc (Completions (List ls) : rest) =-            go comp (acc <> DList.fromList ls) rest-          go comp acc (CompletionList (CompletionListType comp' (List ls)) : rest) =-            go (comp && comp') (acc <> DList.fromList ls) rest+    IdeHandlers handlers' = foldMap bakePluginId xs+    bakePluginId :: (PluginId, PluginHandlers IdeState) -> IdeHandlers+    bakePluginId (pid,PluginHandlers hs) = IdeHandlers $ DMap.map+      (\(PluginHandler f) -> IdeHandler [(pid,f pid)])+      hs+    handlers = mconcat $ do+      (IdeMethod m :=> IdeHandler fs') <- DMap.assocs handlers'+      pure $ requestHandler m $ \ide params -> do+        config <- getClientConfig+        let fs = filter (\(pid,_) -> pluginEnabled m pid config) fs'+        case nonEmpty fs of+          Nothing -> pure $ Left $ ResponseError InvalidRequest+            ("No plugin enabled for " <> T.pack (show m) <> ", available: " <> T.pack (show $ map fst fs))+            Nothing+          Just fs -> do+            let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e)+            es <- runConcurrently msg (show m) fs ide params+            let (errs,succs) = partitionEithers $ toList es+            case nonEmpty succs of+              Nothing -> pure $ Left $ combineErrors errs+              Just xs -> do+                caps <- LSP.getClientCapabilities+                pure $ Right $ combineResponses m config caps params xs -          makeAction ::-            (PluginId, CompletionProvider IdeState) ->-            IO (Either ResponseError CompletionResponseResult)-          makeAction (pid, p) = do-            pluginConfig <- getPluginConfig lf pid-            if pluginEnabled pluginConfig plcCompletionOn-               then otTracedProvider pid "completions" $ p lf ideState params-               else return $ Right $ Completions $ List []+runConcurrently+  :: MonadUnliftIO m+  => (SomeException -> PluginId -> T.Text)+  -> String -- ^ label+  -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d)))+  -> a+  -> b+  -> m (NonEmpty (Either ResponseError d))+runConcurrently msg method fs a b = fmap join $ forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do+  f a b+    `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing) -      case mprefix of-          Nothing -> return $ Right $ Completions $ List []-          Just _prefix -> do-            mhs <- mapConcurrently makeAction sps-            case rights mhs of-                [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs-                hs -> return $ Right $ snd $ consumeCompletionResponse maxCompletions $ combine hs+combineErrors :: [ResponseError] -> ResponseError+combineErrors [x] = x+combineErrors xs = ResponseError InternalError (T.pack (show xs)) Nothing --- | Crops a completion response. Returns the final number of completions and the cropped response-consumeCompletionResponse :: Int -> CompletionResponseResult -> (Int, CompletionResponseResult)-consumeCompletionResponse limit it@(CompletionList (CompletionListType _ (List xx))) =-  case splitAt limit xx of-    -- consumed all the items, return the result as is-    (_, []) -> (limit - length xx, it)-    -- need to crop the response, set the 'isIncomplete' flag-    (xx', _) -> (0, CompletionList (CompletionListType isIncompleteResponse (List xx')))-consumeCompletionResponse n (Completions (List xx)) =-  consumeCompletionResponse n (CompletionList (CompletionListType isCompleteResponse (List xx)))+-- | Combine the 'PluginHandler' for all plugins+newtype IdeHandler (m :: J.Method FromClient Request)+  = IdeHandler [(PluginId,IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))] --- boolean disambiguators-isCompleteResponse, isIncompleteResponse :: Bool-isIncompleteResponse = True-isCompleteResponse = False+-- | Combine the 'PluginHandlers' for all plugins+newtype IdeHandlers = IdeHandlers (DMap IdeMethod IdeHandler) -getPrefixAtPos :: LSP.LspFuncs Config -> Uri -> Position -> IO (Maybe VFS.PosPrefixInfo)-getPrefixAtPos lf uri pos = do-  mvf <-  LSP.getVirtualFileFunc lf (J.toNormalizedUri uri)-  case mvf of-    Just vf -> VFS.getCompletionPrefix pos vf-    Nothing -> return Nothing+instance Semigroup IdeHandlers where+  (IdeHandlers a) <> (IdeHandlers b) = IdeHandlers $ DMap.unionWithKey go a b+    where+      go _ (IdeHandler a) (IdeHandler b) = IdeHandler (a ++ b)+instance Monoid IdeHandlers where+  mempty = IdeHandlers mempty

@@ -1,70 +0,0 @@--module Development.IDE.Plugin.HLS.Formatter-  (-    formatting-  , rangeFormatting-  )-where--import qualified Data.Map  as Map-import qualified Data.Text as T-import           Development.IDE-import           Ide.PluginUtils-import           Ide.Types-import           Ide.Plugin.Config-import qualified Language.Haskell.LSP.Core as LSP-import           Language.Haskell.LSP.Types-import           Text.Regex.TDFA.Text()---- -----------------------------------------------------------------------formatting :: Map.Map PluginId (FormattingProvider IdeState IO)-           -> LSP.LspFuncs Config -> IdeState -> DocumentFormattingParams-           -> IO (Either ResponseError (List TextEdit))-formatting providers lf ideState-    (DocumentFormattingParams (TextDocumentIdentifier uri) params _mprogress)-  = doFormatting lf providers ideState FormatText uri params---- -----------------------------------------------------------------------rangeFormatting :: Map.Map PluginId (FormattingProvider IdeState IO)-                -> LSP.LspFuncs Config -> IdeState -> DocumentRangeFormattingParams-                -> IO (Either ResponseError (List TextEdit))-rangeFormatting providers lf ideState-    (DocumentRangeFormattingParams (TextDocumentIdentifier uri) range params _mprogress)-  = doFormatting lf providers ideState (FormatRange range) uri params---- -----------------------------------------------------------------------doFormatting :: LSP.LspFuncs Config -> Map.Map PluginId (FormattingProvider IdeState IO)-             -> IdeState -> FormattingType -> Uri -> FormattingOptions-             -> IO (Either ResponseError (List TextEdit))-doFormatting lf providers ideState ft uri params = do-  mc <- LSP.config lf-  let mf = maybe "none" formattingProvider mc-  case Map.lookup (PluginId mf) providers of-      Just provider ->-        case uriToFilePath uri of-          Just (toNormalizedFilePath -> fp) -> do-            (_, mb_contents) <- runAction "Formatter" ideState $ getFileContents fp-            case mb_contents of-              Just contents -> do-                  logDebug (ideLogger ideState) $ T.pack $-                      "Formatter.doFormatting: contents=" ++ show contents -- AZ-                  provider lf ideState ft contents fp params-              Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri-          Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri-      Nothing -> return $ Left $ responseError $ mconcat-        [ "Formatter plugin: no formatter found for:["-        , mf-        , "]"-        , if mf == "brittany"-          then T.unlines-            [ "\nThe haskell-language-server must be compiled with the agpl flag to provide Brittany."-            , "Stack users add 'agpl: true' in the flags section of the 'stack.yaml' file."-            , "The 'haskell-language-server.cabal' file already has this flag enabled by default."-            , "For more information see: https://github.com/haskell/haskell-language-server/issues/269"-            ]-          else ""-        ]-

@@ -9,13 +9,14 @@ import Development.IDE import Development.IDE.LSP.HoverDefinition import Development.IDE.LSP.Outline-import Ide.PluginUtils import Ide.Types-import Language.Haskell.LSP.Types+import Language.LSP.Types+import Language.LSP.Server (LspM) import Text.Regex.TDFA.Text() import qualified Development.IDE.Plugin.CodeAction as CodeAction import qualified Development.IDE.Plugin.Completions as Completions import qualified Development.IDE.Plugin.TypeLenses as TypeLenses+import Control.Monad.IO.Class  descriptors :: [PluginDescriptor IdeState] descriptors =@@ -29,25 +30,19 @@  descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId)-  { pluginHoverProvider      = Just hover'-  , pluginSymbolsProvider    = Just symbolsProvider+  { pluginHandlers = mkPluginHandler STextDocumentHover hover'+                  <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider   }  -- --------------------------------------------------------------------- -hover' :: HoverProvider IdeState-hover' ideState params = do-    logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ-    hover ideState params+hover' :: IdeState -> PluginId -> HoverParams  -> LspM c (Either ResponseError (Maybe Hover))+hover' ideState _ HoverParams{..} = do+    liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ+    hover ideState TextDocumentPositionParams{..}  -- ----------------------------------------------------------------------symbolsProvider :: SymbolsProvider IdeState-symbolsProvider ls ide params = do-    ds <- moduleOutline ls ide params-    case ds of-        Right (DSDocumentSymbols (List ls)) -> return $ Right ls-        Right (DSSymbolInformation (List _si)) ->-            return $ Left $ responseError "GhcIde.symbolsProvider: DSSymbolInformation deprecated"-        Left err -> return $ Left err+symbolsProvider :: IdeState -> PluginId -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation))+symbolsProvider ide _ params = moduleOutline ide params  -- ---------------------------------------------------------------------

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE DerivingStrategies #-} -- | A plugin that adds custom messages for use in tests module Development.IDE.Plugin.Test@@ -10,6 +11,7 @@   ) where  import Control.Monad.STM+import Control.Monad.IO.Class import Data.Aeson import Data.Aeson.Types import Data.CaseInsensitive (CI, original)@@ -17,14 +19,12 @@ import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.Types.HscEnvEq (HscEnvEq(hscEnv))-import Development.IDE.LSP.Server import Development.IDE.Plugin+import Development.IDE.LSP.Server import Development.IDE.Types.Action import GHC.Generics (Generic) import GhcPlugins (HscEnv(hsc_dflags))-import Language.Haskell.LSP.Core-import Language.Haskell.LSP.Messages-import Language.Haskell.LSP.Types+import Language.LSP.Types import System.Time.Extra import Development.IDE.Core.RuleTypes import Control.Monad@@ -36,7 +36,7 @@ import Development.IDE.Types.Location (fromUri) import Control.Concurrent (threadDelay) import Ide.Types-import qualified Language.Haskell.LSP.Core as LSP+import qualified Language.LSP.Server as LSP  data TestRequest     = BlockSeconds Seconds           -- ^ :: Null@@ -53,42 +53,39 @@ plugin :: Plugin c plugin = Plugin {     pluginRules = return (),-    pluginHandler = PartialHandlers $ \WithMessage{..} x -> return x {-        customRequestHandler = withResponse RspCustomServer requestHandler'-    }+    pluginHandlers = requestHandler (SCustomMethod "test") testRequestHandler' }   where-      requestHandler' lsp ide req+      testRequestHandler' ide req         | Just customReq <- parseMaybe parseJSON req-        = requestHandler lsp ide customReq+        = testRequestHandler ide customReq         | otherwise         = return $ Left         $ ResponseError InvalidRequest "Cannot parse request" Nothing -requestHandler :: LspFuncs c-                -> IdeState++testRequestHandler ::  IdeState                 -> TestRequest-                -> IO (Either ResponseError Value)-requestHandler lsp _ (BlockSeconds secs) = do-    sendFunc lsp $ NotCustomServer $-        NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/request") $-        toJSON secs-    sleep secs+                -> LSP.LspM c (Either ResponseError Value)+testRequestHandler _ (BlockSeconds secs) = do+    LSP.sendNotification (SCustomMethod "ghcide/blocking/request") $+      toJSON secs+    liftIO $ sleep secs     return (Right Null)-requestHandler _ s (GetInterfaceFilesDir fp) = do+testRequestHandler s (GetInterfaceFilesDir fp) = liftIO $ do     let nfp = toNormalizedFilePath fp     sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp     let hiPath = hiDir $ hsc_dflags $ hscEnv sess     return $ Right (toJSON hiPath)-requestHandler _ s GetShakeSessionQueueCount = do+testRequestHandler s GetShakeSessionQueueCount = liftIO $ do     n <- atomically $ countQueue $ actionQueue $ shakeExtras s     return $ Right (toJSON n)-requestHandler _ s WaitForShakeQueue = do+testRequestHandler s WaitForShakeQueue = liftIO $ do     atomically $ do         n <- countQueue $ actionQueue $ shakeExtras s         when (n>0) retry     return $ Right Null-requestHandler _ s (WaitForIdeRule k file) = do+testRequestHandler s (WaitForIdeRule k file) = liftIO $ do     let nfp = fromUri $ toNormalizedUri file     success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp     let res = WaitForIdeRuleResult <$> success@@ -120,9 +117,7 @@ }  blockCommandHandler :: CommandFunction state ExecuteCommandParams-blockCommandHandler lsp _ideState _params-    = do-        LSP.sendFunc lsp $ NotCustomServer $-            NotificationMessage "2.0" (CustomServerMethod "ghcide/blocking/command") Null-        threadDelay maxBound-        return (Right Null, Nothing)+blockCommandHandler _ideState _params = do+  LSP.sendNotification (SCustomMethod "ghcide/blocking/command") Null+  liftIO $ threadDelay maxBound+  return (Right Null)

@@ -6,6 +6,7 @@   ) where +import Control.Monad.IO.Class import Data.Aeson.Types (Value (..), toJSON) import qualified Data.HashMap.Strict as Map import qualified Data.Text as T@@ -24,22 +25,23 @@   ( CommandFunction,     CommandId (CommandId),     PluginCommand (PluginCommand),-    PluginDescriptor (pluginCodeLensProvider, pluginCommands),+    PluginDescriptor(..),     PluginId,     defaultPluginDescriptor,+    mkPluginHandler   )-import qualified Language.Haskell.LSP.Core as LSP-import Language.Haskell.LSP.Types+import qualified Language.LSP.Server as LSP+import Language.LSP.Types   ( ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),     CodeLens (CodeLens),     CodeLensParams (CodeLensParams, _textDocument),     Diagnostic (..),     List (..),     ResponseError,-    ServerMethod (WorkspaceApplyEdit),     TextDocumentIdentifier (TextDocumentIdentifier),     TextEdit (TextEdit),     WorkspaceEdit (WorkspaceEdit),+    SMethod(..)   ) import Text.Regex.TDFA ((=~)) @@ -49,19 +51,18 @@ descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId =   (defaultPluginDescriptor plId)-    { pluginCodeLensProvider = Just codeLensProvider,+    { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider,       pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler]     }  codeLensProvider ::-  LSP.LspFuncs c ->   IdeState ->   PluginId ->   CodeLensParams ->-  IO (Either ResponseError (List CodeLens))-codeLensProvider _lsp ideState pId CodeLensParams {_textDocument = TextDocumentIdentifier uri} = do+  LSP.LspM c (Either ResponseError (List CodeLens))+codeLensProvider ideState pId CodeLensParams {_textDocument = TextDocumentIdentifier uri} = do   fmap (Right . List) $ case uriToFilePath' uri of-    Just (toNormalizedFilePath' -> filePath) -> do+    Just (toNormalizedFilePath' -> filePath) -> liftIO $ do       _ <- runAction "codeLens" ideState (use TypeCheck filePath)       diag <- getDiagnostics ideState       hDiag <- getHiddenDiagnostics ideState@@ -76,12 +77,13 @@  generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> IO CodeLens generateLens pId _range title edit = do-  cId <- mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit])+  let cId = mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit])   return $ CodeLens _range (Just cId) Nothing  commandHandler :: CommandFunction IdeState WorkspaceEdit-commandHandler _lsp _ideState wedit =-    return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit))+commandHandler _ideState wedit = do+  _ <- LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ())+  return $ Right Null  suggestSignature :: Bool -> Diagnostic -> [(T.Text, [TextEdit])] suggestSignature isQuickFix Diagnostic {_range = _range@Range {..}, ..}

@@ -22,7 +22,7 @@ import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans() import Development.IDE.Types.Location-import Language.Haskell.LSP.Types+import           Language.LSP.Types  -- compiler and infrastructure import Development.IDE.GHC.Compat@@ -318,7 +318,15 @@       mod <- MaybeT $ return $ nameModule_maybe name       erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod)       case erow of-        [] -> MaybeT $ pure Nothing+        [] -> do+          -- If the lookup failed, try again without specifying a unit-id.+          -- This is a hack to make find definition work better with ghcide's nascent multi-component support,+          -- where names from a component that has been indexed in a previous session but not loaded in this+          -- session may end up with different unit ids+          erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) Nothing+          case erow of+            [] -> MaybeT $ pure Nothing+            xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs         xs -> lift $ mapMaybeM (runMaybeT . defRowToLocation lookupModule) xs  defRowToLocation :: Monad m => LookupModule m -> Res DefRow -> MaybeT m Location

@@ -35,7 +35,7 @@ import           GhcMonad import           Packages import           Name-import           Language.Haskell.LSP.Types (getUri, filePathToUri)+import           Language.LSP.Types (getUri, filePathToUri) import           TcRnTypes import           ExtractDocs import           NameEnv@@ -43,11 +43,10 @@  mkDocMap   :: HscEnv-  -> [ParsedModule]   -> RefMap a   -> TcGblEnv   -> IO DocAndKindMap-mkDocMap env sources rm this_mod =+mkDocMap env rm this_mod =   do let (_ , DeclDocMap this_docs, _) = extractDocs this_mod      d <- foldrM getDocs (mkNameEnv $ M.toList $ fmap (`SpanDocString` SpanDocUris Nothing Nothing) this_docs) names      k <- foldrM getType (tcg_type_env this_mod) names@@ -56,7 +55,7 @@     getDocs n map       | maybe True (mod ==) $ nameModule_maybe n = pure map -- we already have the docs in this_docs, or they do not exist       | otherwise = do-      doc <- getDocumentationTryGhc env mod sources n+      doc <- getDocumentationTryGhc env mod n       pure $ extendNameEnv map n doc     getType n map       | isTcOcc $ occName n = do@@ -71,23 +70,21 @@ lookupKind env mod =     fmap (fromRight Nothing) . catchSrcErrors (hsc_dflags env) "span" . lookupName env mod -getDocumentationTryGhc :: HscEnv -> Module -> [ParsedModule] -> Name -> IO SpanDoc-getDocumentationTryGhc env mod deps n = head <$> getDocumentationsTryGhc env mod deps [n]+getDocumentationTryGhc :: HscEnv -> Module -> Name -> IO SpanDoc+getDocumentationTryGhc env mod n = head <$> getDocumentationsTryGhc env mod [n] -getDocumentationsTryGhc :: HscEnv -> Module -> [ParsedModule] -> [Name] -> IO [SpanDoc]--- Interfaces are only generated for GHC >= 8.6.--- In older versions, interface files do not embed Haddocks anyway-getDocumentationsTryGhc env mod sources names = do+getDocumentationsTryGhc :: HscEnv -> Module -> [Name] -> IO [SpanDoc]+getDocumentationsTryGhc env mod names = do   res <- catchSrcErrors (hsc_dflags env) "docs" $ getDocsBatch env mod names   case res of-      Left _ -> mapM mkSpanDocText names+      Left _ -> return []       Right res -> zipWithM unwrap res names   where     unwrap (Right (Just docs, _)) n = SpanDocString docs <$> getUris n     unwrap _ n = mkSpanDocText n      mkSpanDocText name =-      SpanDocText (getDocumentation sources name) <$> getUris name+      SpanDocText [] <$> getUris name      -- Get the uris to the documentation and source html pages if they exist     getUris name = do@@ -212,8 +209,8 @@     go pkgDocDir = map (mkDocPath pkgDocDir) mns     ui = moduleUnitId m     -- try to locate html file from most to least specific name e.g.-    --  first Language.Haskell.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html-    --  then Language.Haskell.LSP.Types.html and Language-Haskell-LSP-Types.html etc.+    --  first Language.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html+    --  then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc.     mns = do       chunks <- (reverse . drop1 . inits . splitOn ".") $ (moduleNameString . moduleName) m       -- The file might use "." or "-" as separator

@@ -20,12 +20,12 @@ import Data.Maybe as Maybe import qualified Data.Text as T import Data.Text.Prettyprint.Doc-import Language.Haskell.LSP.Types as LSP (DiagnosticSource,+import Language.LSP.Types as LSP (DiagnosticSource,     DiagnosticSeverity(..)   , Diagnostic(..)   , List(..)   )-import Language.Haskell.LSP.Diagnostics+import Language.LSP.Diagnostics import Data.Text.Prettyprint.Doc.Render.Text import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal import Data.Text.Prettyprint.Doc.Render.Terminal (Color(..), color)

@@ -6,6 +6,7 @@     newHscEnvEqWithImportPaths,     envImportPaths,     envPackageExports,+    envVisibleModuleNames,     deps ) where @@ -16,7 +17,7 @@ import Module (InstalledUnitId) import System.Directory (canonicalizePath) import Development.IDE.GHC.Compat-import GhcPlugins(HscEnv (hsc_dflags), PackageState (explicitPackages), InstalledPackageInfo (exposedModules), Module(..), packageConfigId)+import GhcPlugins(HscEnv (hsc_dflags), PackageState (explicitPackages), InstalledPackageInfo (exposedModules), Module(..), packageConfigId, listVisibleModuleNames) import System.FilePath import Development.IDE.GHC.Util (lookupPackageConfig) import Control.Monad.IO.Class@@ -24,8 +25,13 @@ import LoadIface (loadInterface) import qualified Maybes import OpenTelemetry.Eventlog (withSpan)-import System.IO.Unsafe (unsafePerformIO)-import Control.Monad.Extra (mapMaybeM)+import Control.Monad.Extra (mapMaybeM, join, eitherM)+import Control.Concurrent.Extra (newVar, modifyVar)+import Control.Concurrent.Async (Async, async, waitCatch)+import Control.Exception (throwIO, mask, evaluate)+import Development.IDE.GHC.Error (catchSrcErrors)+import Control.DeepSeq (force)+import Data.Either (fromRight)  -- | An 'HscEnv' with equality. Two values are considered equal --   if they are created with the same call to 'newHscEnvEq'.@@ -39,7 +45,12 @@     , envImportPaths :: Maybe [String]         -- ^ If Just, import dirs originally configured in this env         --   If Nothing, the env import dirs are unaltered-    , envPackageExports :: ExportsMap+    , envPackageExports :: IO ExportsMap+    , envVisibleModuleNames :: IO (Maybe [ModuleName])+        -- ^ 'listVisibleModuleNames' is a pure function,+        -- but it could panic due to a ghc bug: https://github.com/haskell/haskell-language-server/issues/1365+        -- So it's wrapped in IO here for error handling+        -- If Nothing, 'listVisibleModuleNames' panic     }  -- | Wrap an 'HscEnv' into an 'HscEnvEq'.@@ -56,13 +67,15 @@  newHscEnvEqWithImportPaths :: Maybe [String] -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do++    let dflags = hsc_dflags hscEnv+     envUnique <- newUnique -    let-    -- evaluate lazily, using unsafePerformIO for a pure API-      envPackageExports = unsafePerformIO $ withSpan "Package Exports" $ \_sp -> do+    -- it's very important to delay the package exports computation+    envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do         -- compute the package imports-        let pkgst   = pkgState (hsc_dflags hscEnv)+        let pkgst   = pkgState dflags             depends = explicitPackages pkgst             targets =                 [ (pkg, mn)@@ -81,6 +94,15 @@                     Maybes.Succeeded mi -> Just mi         modIfaces <- mapMaybeM doOne targets         return $ createExportsMap modIfaces++    -- similar to envPackageExports, evaluated lazily+    envVisibleModuleNames <- onceAsync $+      fromRight Nothing+        <$> catchSrcErrors+          dflags+          "listVisibleModuleNames"+          (evaluate . force . Just $ listVisibleModuleNames dflags)+     return HscEnvEq{..}  -- | Wrap an 'HscEnv' into an 'HscEnvEq'.@@ -107,8 +129,8 @@   a == b = envUnique a == envUnique b  instance NFData HscEnvEq where-  rnf (HscEnvEq a b c d _) =-      -- deliberately skip the package exports map+  rnf (HscEnvEq a b c d _ _) =+      -- deliberately skip the package exports map and visible module names       rnf (hashUnique a) `seq` b `seq` c `seq` rnf d  instance Hashable HscEnvEq where@@ -119,3 +141,19 @@ instance Binary HscEnvEq where   put _ = error "not really"   get = error "not really"++-- | Given an action, produce a wrapped action that runs at most once.+--   The action is run in an async so it won't be killed by async exceptions+--   If the function raises an exception, the same exception will be reraised each time.+onceAsync :: IO a -> IO (IO a)+onceAsync act = do+    var <- newVar OncePending+    let run as = eitherM throwIO pure (waitCatch as)+    pure $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of+        OnceRunning x -> pure (v, unmask $ run x)+        OncePending -> do+            x <- async (unmask act)+            pure (OnceRunning x, unmask $ run x)++data Once a = OncePending | OnceRunning (Async a)+

@@ -26,12 +26,12 @@     ) where  import Control.Applicative-import Language.Haskell.LSP.Types (Location(..), Range(..), Position(..))+import Language.LSP.Types (Location(..), Range(..), Position(..)) import Control.Monad import Data.Hashable (Hashable(hash)) import Data.String import FastString-import qualified Language.Haskell.LSP.Types as LSP+import qualified Language.LSP.Types as LSP import SrcLoc as GHC import Text.ParserCombinators.ReadP as ReadP import Data.Maybe (fromMaybe)

@@ -17,12 +17,11 @@   , OptHaddockParse(..)   ,optShakeFiles) where -import Data.Default import Development.Shake import Development.IDE.Types.HscEnvEq (HscEnvEq) import           GHC hiding (parseModule, typecheckModule) import           GhcPlugins                     as GHC hiding (fst3, (<>))-import qualified Language.Haskell.LSP.Types.Capabilities as LSP+import qualified Language.LSP.Types.Capabilities as LSP import qualified Data.Text as T import Development.IDE.Types.Diagnostics import Control.DeepSeq (NFData(..))@@ -72,9 +71,9 @@     --   features such as diagnostics and go-to-definition, in     --   situations in which they would become unavailable because of     --   the presence of type errors, holes or unbound variables.-  , optCheckProject :: !Bool+  , optCheckProject :: IO Bool     -- ^ Whether to typecheck the entire project on load-  , optCheckParents :: CheckParents+  , optCheckParents :: IO CheckParents     -- ^ When to typecheck reverse dependencies of a file   , optHaddockParse :: OptHaddockParse     -- ^ Whether to return result of parsing module with Opt_Haddock.@@ -133,8 +132,8 @@     ,optKeywords = haskellKeywords     ,optDefer = IdeDefer True     ,optTesting = IdeTesting False-    ,optCheckProject = checkProject def-    ,optCheckParents = checkParents def+    ,optCheckProject = pure True+    ,optCheckParents = pure CheckOnSaveAndClose     ,optHaddockParse = HaddockParse     ,optCustomDynFlags = id     }

@@ -28,7 +28,7 @@ import Development.Shake (RuleResult, ShakeException (shakeExceptionInner)) import Development.Shake.Classes import GHC.Generics-import Language.Haskell.LSP.Types+import Language.LSP.Types import Development.IDE.Core.PositionMapping  data Value v

@@ -5,7 +5,12 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ImplicitParams  #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} #include "ghc-api-version.h"  module Main (main) where@@ -15,7 +20,7 @@ import qualified Control.Lens as Lens import Control.Monad import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Aeson (FromJSON, Value, toJSON,fromJSON)+import Data.Aeson (toJSON,fromJSON) import qualified Data.Aeson as A import qualified Data.Binary as Binary import Data.Default@@ -29,7 +34,6 @@ import Development.IDE.Core.Shake (Q(..)) import Development.IDE.GHC.Util import qualified Data.Text as T-import Data.Typeable import Development.IDE.Plugin.Completions.Types (extendImportCommandId) import Development.IDE.Plugin.TypeLenses (typeLensCommandId) import Development.IDE.Spans.Common@@ -50,12 +54,11 @@ import Development.Shake (getDirectoryFilesIO) import Ide.Plugin.Config import qualified Experiments as Bench-import Language.Haskell.LSP.Test-import Language.Haskell.LSP.Messages-import Language.Haskell.LSP.Types-import Language.Haskell.LSP.Types.Capabilities-import qualified Language.Haskell.LSP.Types.Lens as Lsp (diagnostics, params, message)-import Language.Haskell.LSP.VFS (applyChange)+import Language.LSP.Test+import Language.LSP.Types hiding (mkRange)+import Language.LSP.Types.Capabilities+import qualified Language.LSP.Types.Lens as Lsp (diagnostics, params, message)+import Language.LSP.VFS (applyChange) import Network.URI import System.Environment.Blank (unsetEnv, getEnv, setEnv) import System.FilePath@@ -66,7 +69,7 @@ import System.Process.Extra (readCreateProcessWithExitCode, CreateProcess(cwd), proc) import System.Info.Extra (isWindows) import Test.QuickCheck-import Test.QuickCheck.Instances ()+-- import Test.QuickCheck.Instances () import Test.Tasty import Test.Tasty.ExpectedFailure import Test.Tasty.Ingredients.Rerun@@ -76,21 +79,31 @@ import Development.IDE.Plugin.CodeAction (matchRegExMultipleImports) import Development.IDE.Plugin.Test (TestRequest (BlockSeconds, GetInterfaceFilesDir), WaitForIdeRuleResult (..), blockCommandId) import Control.Monad.Extra (whenJust)-import qualified Language.Haskell.LSP.Types.Lens as L+import qualified Language.LSP.Types.Lens as L import Control.Lens ((^.)) import Data.Functor import Data.Tuple.Extra +waitForProgressBegin :: Session ()+waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case+  FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Begin _))) -> Just ()+  _ -> Nothing++waitForProgressDone :: Session ()+waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case+  FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just ()+  _ -> Nothing+ main :: IO () main = do   -- We mess with env vars so run single-threaded.   defaultMainWithRerun $ testGroup "ghcide"     [ testSession "open close" $ do         doc <- createDoc "Testing.hs" "haskell" ""-        void (skipManyTill anyMessage message :: Session WorkDoneProgressCreateRequest)-        void (skipManyTill anyMessage message :: Session WorkDoneProgressBeginNotification)+        void (skipManyTill anyMessage $ message SWindowWorkDoneProgressCreate)+        waitForProgressBegin         closeDoc doc-        void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)+        waitForProgressDone     , initializeResponseTests     , completionTests     , cppTests@@ -130,50 +143,50 @@   -- response. Currently the server advertises almost no capabilities   -- at all, in some cases failing to announce capabilities that it   -- actually does provide! Hopefully this will change ...-  tests :: IO InitializeResponse -> TestTree+  tests :: IO (ResponseMessage Initialize) -> TestTree   tests getInitializeResponse =     testGroup "initialize response capabilities"     [ chk "   text doc sync"             _textDocumentSync  tds-    , chk "   hover"                         _hoverProvider (Just True)-    , chk "   completion"               _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing)-    , chk "NO signature help"        _signatureHelpProvider  Nothing-    , chk "   goto definition"          _definitionProvider (Just True)-    , chk "   goto type definition" _typeDefinitionProvider (Just $ GotoOptionsStatic True)+    , chk "   hover"                         _hoverProvider (Just $ InL True)+    , chk "   completion"               _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just False))+    , chk "NO signature help"        _signatureHelpProvider Nothing+    , chk "   goto definition"          _definitionProvider (Just $ InL True)+    , chk "   goto type definition" _typeDefinitionProvider (Just $ InL True)     -- BUG in lsp-test, this test fails, just change the accepted response     -- for now-    , chk "NO goto implementation"  _implementationProvider (Just $ GotoOptionsStatic True)-    , chk "   find references"          _referencesProvider  (Just True)-    , chk "   doc highlight"     _documentHighlightProvider  (Just True)-    , chk "   doc symbol"           _documentSymbolProvider  (Just True)-    , chk "   workspace symbol"    _workspaceSymbolProvider  (Just True)-    , chk "   code action"             _codeActionProvider $ Just $ CodeActionOptionsStatic True-    , chk "   code lens"                 _codeLensProvider $ Just $ CodeLensOptions Nothing-    , chk "NO doc formatting"   _documentFormattingProvider  Nothing+    , chk "NO goto implementation"  _implementationProvider (Just $ InL False)+    , chk "   find references"          _referencesProvider (Just $ InL True)+    , chk "   doc highlight"     _documentHighlightProvider (Just $ InL True)+    , chk "   doc symbol"           _documentSymbolProvider (Just $ InL True)+    , chk "   workspace symbol"    _workspaceSymbolProvider (Just True)+    , chk "   code action"             _codeActionProvider  (Just $ InL True)+    , chk "   code lens"                 _codeLensProvider  (Just $ CodeLensOptions (Just False) (Just False))+    , chk "NO doc formatting"   _documentFormattingProvider (Just $ InL False)     , chk "NO doc range formatting"-                           _documentRangeFormattingProvider  Nothing+                           _documentRangeFormattingProvider (Just $ InL False)     , chk "NO doc formatting on typing"-                          _documentOnTypeFormattingProvider  Nothing-    , chk "NO renaming"                     _renameProvider (Just $ RenameOptionsStatic False)-    , chk "NO doc link"               _documentLinkProvider  Nothing-    , chk "NO color"                         _colorProvider (Just $ ColorOptionsStatic False)-    , chk "NO folding range"          _foldingRangeProvider (Just $ FoldingRangeOptionsStatic False)+                          _documentOnTypeFormattingProvider Nothing+    , chk "NO renaming"                     _renameProvider (Just $ InL False)+    , 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]-    , chk "   workspace"                         _workspace (Just $ WorkspaceOptions (Just WorkspaceFolderOptions{_supported = Just True, _changeNotifications = Just ( WorkspaceFolderChangeNotificationsBool True )}))-    , chk "NO experimental"                   _experimental  Nothing+    , chk "   workspace"                         _workspace (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )}))+    , chk "NO experimental"                   _experimental Nothing     ] where -      tds = Just (TDSOptions (TextDocumentSyncOptions+      tds = Just (InL (TextDocumentSyncOptions                               { _openClose = Just True                               , _change    = Just TdSyncIncremental                               , _willSave  = Nothing                               , _willSaveWaitUntil = Nothing-                              , _save = Just (SaveOptions {_includeText = Nothing})}))+                              , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) -      chk :: (Eq a, Show a) => TestName -> (InitializeResponseCapabilitiesInner -> a) -> a -> TestTree+      chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree       chk title getActual expected =         testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir -      che :: TestName -> (InitializeResponseCapabilitiesInner -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree+      che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree       che title getActual expected = testCase title doTest         where             doTest = do@@ -181,15 +194,14 @@                 let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir                 zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) expected commands --  innerCaps :: InitializeResponse -> InitializeResponseCapabilitiesInner-  innerCaps (ResponseMessage _ _ (Right (InitializeResponseCapabilities c))) = c-  innerCaps  _ = error "this test only expects inner capabilities"+  innerCaps :: ResponseMessage Initialize -> ServerCapabilities+  innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c+  innerCaps (ResponseMessage _ _ (Left _)) = error "Initialization error" -  acquire :: IO InitializeResponse+  acquire :: IO (ResponseMessage Initialize)   acquire = run initializeResponse -  release :: InitializeResponse -> IO ()+  release :: ResponseMessage Initialize -> IO ()   release = const $ pure ()  @@ -209,8 +221,8 @@   , testSessionWait "introduce syntax error" $ do       let content = T.unlines [ "module Testing where" ]       doc <- createDoc "Testing.hs" "haskell" content-      void $ skipManyTill anyMessage (message :: Session WorkDoneProgressCreateRequest)-      void $ skipManyTill anyMessage (message :: Session WorkDoneProgressBeginNotification)+      void $ skipManyTill anyMessage (message SWindowWorkDoneProgressCreate)+      waitForProgressBegin       let change = TextDocumentContentChangeEvent             { _range = Just (Range (Position 0 15) (Position 0 18))             , _rangeLength = Nothing@@ -488,9 +500,8 @@               in filePathToUri (joinDrive (lower drive) suffix)           let itemA = TextDocumentItem uriA "haskell" 0 aContent           let a = TextDocumentIdentifier uriA-          sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)-          diagsNot <- skipManyTill anyMessage diagnostic-          let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)+          sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams itemA)+          NotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic           -- Check that if we put a lower-case drive in for A.A           -- the diagnostics for A.B will also be lower-case.           liftIO $ fileUri @?= uriB@@ -693,6 +704,7 @@   , removeImportTests   , extendImportTests   , suggestImportTests+  , suggestHideShadowTests   , suggestImportDisambiguationTests   , disableWarningTests   , fixConstructorImportTests@@ -727,7 +739,7 @@   [ testSession' "workspace files" $ \sessionDir -> do       liftIO $ writeFile (sessionDir </> "hie.yaml") "cradle: {direct: {arguments: [\"-isrc\", \"A\", \"WatchedFilesMissingModule\"]}}"       _doc <- createDoc "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"-      watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification+      watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics        -- Expect 1 subscription: we only ever send one       liftIO $ length watchedFileRegs @?= 1@@ -736,7 +748,7 @@       tmpDir <- liftIO getTemporaryDirectory       liftIO $ writeFile (sessionDir </> "hie.yaml") ("cradle: {direct: {arguments: [\"-i" <> tmpDir <> "\", \"A\", \"WatchedFilesMissingModule\"]}}")       _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"-      watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification+      watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics        -- Expect 1 subscription: we only ever send one       liftIO $ length watchedFileRegs @?= 1@@ -803,7 +815,7 @@       doc <- createDoc "Testing.hs" "haskell" content       _ <- waitForDiagnostics       actionsOrCommands <- getCodeActions doc (Range (Position 3 12) (Position 3 20))-      [fixTypo] <- pure [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]+      [fixTypo] <- pure [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, "monus" `T.isInfixOf` actionTitle ]       executeCodeAction fixTypo       contentAfterAction <- documentContents doc       let expectedContentAfterAction = T.unlines@@ -826,7 +838,7 @@       doc <- createDoc "Testing.hs" "haskell" content       _ <- waitForDiagnostics       actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))-      let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands+      let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands                                    , "Use type signature" `T.isInfixOf` actionTitle                            ]       executeCodeAction addSignature@@ -846,7 +858,7 @@       doc <- createDoc "Testing.hs" "haskell" content       _ <- waitForDiagnostics       actionsOrCommands <- getCodeActions doc (Range (Position 2 1) (Position 2 10))-      let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands+      let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands                                     , "Use type signature" `T.isInfixOf` actionTitle                               ]       executeCodeAction addSignature@@ -869,7 +881,7 @@       doc <- createDoc "Testing.hs" "haskell" content       _ <- waitForDiagnostics       actionsOrCommands <- getCodeActions doc (Range (Position 4 1) (Position 4 10))-      let [addSignature] = [action | CACodeAction action@CodeAction { _title = actionTitle } <- actionsOrCommands+      let [addSignature] = [action | InR action@CodeAction { _title = actionTitle } <- actionsOrCommands                                     , "Use type signature" `T.isInfixOf` actionTitle                               ]       executeCodeAction addSignature@@ -1101,7 +1113,7 @@   ]   where     caWithTitle t = \case-      CACodeAction a@CodeAction{_title} -> guard (_title == t) >> Just a+      InR  a@CodeAction{_title} -> guard (_title == t) >> Just a       _ -> Nothing  extendImportTests :: TestTree@@ -1357,7 +1369,7 @@         codeActionTitle CodeAction{_title=x} = x          template setUpModules moduleUnderTest range expectedTitles expectedContentB = do-            sendNotification WorkspaceDidChangeConfiguration+            sendNotification SWorkspaceDidChangeConfiguration                 (DidChangeConfigurationParams $ toJSON                   def{checkProject = overrideCheckProject}) @@ -1365,12 +1377,12 @@             mapM_ (\x -> createDoc (fst x) "haskell" (snd x)) setUpModules             docB <- createDoc (fst moduleUnderTest) "haskell" (snd moduleUnderTest)             _  <- waitForDiagnostics-            void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)+            waitForProgressDone             actionsOrCommands <- getCodeActions docB range             let codeActions =                   filter                     (T.isPrefixOf "Add" . codeActionTitle)-                    [ca | CACodeAction ca <- actionsOrCommands]+                    [ca | InR ca <- actionsOrCommands]                 actualTitles = codeActionTitle <$> codeActions             -- Note that we are not testing the order of the actions, as the             -- order of the expected actions indicates which one we'll execute@@ -1460,7 +1472,7 @@           cradle = "cradle: {direct: {arguments: [-hide-all-packages, -package, base, -package, text, -package-env, -, A, Bar, Foo]}}"       liftIO $ writeFileUTF8 (dir </> "hie.yaml") cradle       doc <- createDoc "Test.hs" "haskell" before-      void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)+      waitForProgressDone       _diags <- waitForDiagnostics       -- there isn't a good way to wait until the whole project is checked atm       when waitForCheckProject $ liftIO $ sleep 0.5@@ -1474,7 +1486,7 @@              contentAfterAction <- documentContents doc              liftIO $ after @=? contentAfterAction           else-              liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == newImp ] @?= []+              liftIO $ [_title | InR CodeAction{_title} <- actions, _title == newImp ] @?= []  suggestImportDisambiguationTests :: TestTree suggestImportDisambiguationTests = testGroup "suggest import disambiguation actions"@@ -1524,13 +1536,13 @@             assertBool "EVec.fromList must not be suggested" $                 "Replace with qualified: EVec.fromList" `notElem`                 [ actionTitle-                | CACodeAction CodeAction { _title = actionTitle } <- actions+                | InR CodeAction { _title = actionTitle } <- actions                 ]         liftIO $             assertBool "EVec.++ must not be suggested" $                 "Replace with qualified: EVec.++" `notElem`                 [ actionTitle-                | CACodeAction CodeAction { _title = actionTitle } <- actions+                | InR CodeAction { _title = actionTitle } <- actions                 ]     , testGroup "fromList"         [ testCase "EVec" $@@ -1577,8 +1589,7 @@         liftIO $ mapM_ (\fp -> copyFile (hidingDir </> fp) $ dir </> fp)             $ file : auxFiles         doc <- openDoc file "haskell"-        void (skipManyTill anyMessage message-            :: Session WorkDoneProgressEndNotification)+        waitForProgressDone         void $ expectDiagnostics [(file, [(DsError, loc, "Ambiguous occurrence") | loc <- locs])]         contents <- documentContents doc         let range = Range (Position 0 0) (Position (length $ T.lines contents) 0)@@ -1586,6 +1597,193 @@         k doc actions     withHideFunction = withTarget ("HideFunction" <.> "hs") +suggestHideShadowTests :: TestTree+suggestHideShadowTests =+  testGroup+    "suggest hide shadow"+    [ testGroup+        "single"+        [ testOneCodeAction+            "hide unsued"+            "Hide on from Data.Function"+            (1, 2)+            (1, 4)+            [ "import Data.Function"+            , "f on = on"+            , "g on = on"+            ]+            [ "import Data.Function hiding (on)"+            , "f on = on"+            , "g on = on"+            ]+        , testOneCodeAction+            "extend hiding unsued"+            "Hide on from Data.Function"+            (1, 2)+            (1, 4)+            [ "import Data.Function hiding ((&))"+            , "f on = on"+            ]+            [ "import Data.Function hiding (on, (&))"+            , "f on = on"+            ]+        , testOneCodeAction+            "delete unsued"+            "Hide on from Data.Function"+            (1, 2)+            (1, 4)+            [ "import Data.Function ((&), on)"+            , "f on = on"+            ]+            [ "import Data.Function ((&))"+            , "f on = on"+            ]+        , testOneCodeAction+            "hide operator"+            "Hide & from Data.Function"+            (1, 2)+            (1, 5)+            [ "import Data.Function"+            , "f (&) = (&)"+            ]+            [ "import Data.Function hiding ((&))"+            , "f (&) = (&)"+            ]+        , testOneCodeAction+            "remove operator"+            "Hide & from Data.Function"+            (1, 2)+            (1, 5)+            [ "import Data.Function ((&), on)"+            , "f (&) = (&)"+            ]+            [ "import Data.Function ( on)"+            , "f (&) = (&)"+            ]+        , noCodeAction+            "don't remove already used"+            (2, 2)+            (2, 4)+            [ "import Data.Function"+            , "g = on"+            , "f on = on"+            ]+        ]+    , testGroup+        "multi"+        [ testOneCodeAction+            "hide from B"+            "Hide ++ from B"+            (2, 2)+            (2, 6)+            [ "import B"+            , "import C"+            , "f (++) = (++)"+            ]+            [ "import B hiding ((++))"+            , "import C"+            , "f (++) = (++)"+            ]+        , testOneCodeAction+            "hide from C"+            "Hide ++ from C"+            (2, 2)+            (2, 6)+            [ "import B"+            , "import C"+            , "f (++) = (++)"+            ]+            [ "import B"+            , "import C hiding ((++))"+            , "f (++) = (++)"+            ]+        , testOneCodeAction+            "hide from Prelude"+            "Hide ++ from Prelude"+            (2, 2)+            (2, 6)+            [ "import B"+            , "import C"+            , "f (++) = (++)"+            ]+            [ "import B"+            , "import C"+            , "import Prelude hiding ((++))"+            , "f (++) = (++)"+            ]+        , testMultiCodeActions+            "manual hide all"+            [ "Hide ++ from Prelude"+            , "Hide ++ from C"+            , "Hide ++ from B"+            ]+            (2, 2)+            (2, 6)+            [ "import B"+            , "import C"+            , "f (++) = (++)"+            ]+            [ "import B hiding ((++))"+            , "import C hiding ((++))"+            , "import Prelude hiding ((++))"+            , "f (++) = (++)"+            ]+        , testOneCodeAction+            "auto hide all"+            "Hide ++ from all occurence imports"+            (2, 2)+            (2, 6)+            [ "import B"+            , "import C"+            , "f (++) = (++)"+            ]+            [ "import B hiding ((++))"+            , "import C hiding ((++))"+            , "import Prelude hiding ((++))"+            , "f (++) = (++)"+            ]+        ]+    ]+ where+  testOneCodeAction testName actionName start end origin expected =+    helper testName start end origin expected $ \cas -> do+      action <- liftIO $ pickActionWithTitle actionName cas+      executeCodeAction action+  noCodeAction testName start end origin =+    helper testName start end origin origin $ \cas -> do+      liftIO $ cas @?= []+  testMultiCodeActions testName actionNames start end origin expected =+    helper testName start end origin expected $ \cas -> do+      let r = [ca | (InR ca) <- cas, ca ^. L.title `elem` actionNames]+      liftIO $+        (length r == length actionNames)+          @? "Expected " <> show actionNames <> ", but got " <> show cas <> " which is not its superset"+      forM_ r executeCodeAction+  helper testName (line1, col1) (line2, col2) origin expected k = testSession testName $ do+    void $ createDoc "B.hs" "haskell" $ T.unlines docB+    void $ createDoc "C.hs" "haskell" $ T.unlines docC+    doc <- createDoc "A.hs" "haskell" $ T.unlines (header <> origin)+    void waitForDiagnostics+    waitForProgressDone+    cas <- getCodeActions doc (Range (Position (line1 + length header) col1) (Position (line2 + length header) col2))+    void $ k [x | x@(InR ca) <- cas, "Hide" `T.isPrefixOf` (ca ^. L.title)]+    contentAfter <- documentContents doc+    liftIO $ contentAfter @?= T.unlines (header <> expected)+  header =+    [ "{-# OPTIONS_GHC -Wname-shadowing #-}"+    , "module A where"+    , ""+    ]+  -- for multi group+  docB =+    [ "module B where"+    , "(++) = id"+    ]+  docC =+    [ "module C where"+    , "(++) = id"+    ]+ disableWarningTests :: TestTree disableWarningTests =   testGroup "disable warnings" $@@ -1634,8 +1832,8 @@             liftIO $ expectedContent @=? contentAfterAction  where   caResultToCodeAct = \case-    CACommand _ -> Nothing-    CACodeAction c -> Just c+    InL _ -> Nothing+    InR c -> Just c  insertNewDefinitionTests :: TestTree insertNewDefinitionTests = testGroup "insert new definition actions"@@ -1651,8 +1849,8 @@             ]       docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')       _ <- waitForDiagnostics-      CACodeAction action@CodeAction { _title = actionTitle } : _-                  <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>+      InR action@CodeAction { _title = actionTitle } : _+                  <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>                      getCodeActions docB (R 1 0 1 50)       liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"       executeCodeAction action@@ -1675,8 +1873,8 @@             ]       docB <- createDoc "ModuleB.hs" "haskell" (T.unlines $ txtB ++ txtB')       _ <- waitForDiagnostics-      CACodeAction action@CodeAction { _title = actionTitle } : _-                  <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>+      InR action@CodeAction { _title = actionTitle } : _+                  <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>                      getCodeActions docB (R 1 0 1 50)       liftIO $ actionTitle @?= "Define select :: [Bool] -> Bool"       executeCodeAction action@@ -1993,8 +2191,8 @@       _docA <- createDoc "ModuleA.hs" "haskell" contentA       docB  <- createDoc "ModuleB.hs" "haskell" contentB       _diags <- waitForDiagnostics-      CACodeAction action@CodeAction { _title = actionTitle } : _-                  <- sortOn (\(CACodeAction CodeAction{_title=x}) -> x) <$>+      InR action@CodeAction { _title = actionTitle } : _+                  <- sortOn (\(InR CodeAction{_title=x}) -> x) <$>                      getCodeActions docB range       liftIO $ expectedAction @=? actionTitle       executeCodeAction action@@ -2013,7 +2211,7 @@       doc <- createDoc "Testing.hs" "haskell" content       _ <- waitForDiagnostics       actionsOrCommands <- getCodeActions doc (Range (Position 2 8) (Position 2 16))-      let [changeToMap] = [action | CACodeAction action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]+      let [changeToMap] = [action | InR action@CodeAction{ _title = actionTitle } <- actionsOrCommands, ("Data." <> modname) `T.isInfixOf` actionTitle ]       executeCodeAction changeToMap       contentAfterAction <- documentContents doc       let expectedContentAfterAction = T.unlines@@ -2392,7 +2590,7 @@       $ all isDisableWarningAction actionsOrCommands     where       isDisableWarningAction = \case-        CACodeAction CodeAction{_title} -> "Disable" `T.isPrefixOf` _title && "warnings" `T.isSuffixOf` _title+        InR CodeAction{_title} -> "Disable" `T.isPrefixOf` _title && "warnings" `T.isSuffixOf` _title         _ -> False    in testGroup "remove redundant function constraints"@@ -2723,7 +2921,7 @@       contentAfterAction <- documentContents doc       liftIO $ content @=? contentAfterAction     Nothing ->-      liftIO $ [_title | CACodeAction CodeAction{_title} <- actions, _title == expectedAction ] @?= []+      liftIO $ [_title | InR CodeAction{_title} <- actions, _title == expectedAction ] @?= []  removeExportTests :: TestTree removeExportTests = testGroup "remove export actions"@@ -2917,7 +3115,7 @@     doc <- createDoc "Sigs.hs" "haskell" originalCode     [CodeLens {_command = Just c}] <- getCodeLenses doc     executeCommand c-    modifiedCode <- getDocumentEdit doc+    modifiedCode <- skipManyTill anyMessage (getDocumentEdit doc)     liftIO $ expectedCode @=? modifiedCode   in   testGroup "add signature"@@ -2937,9 +3135,11 @@         ]     ] -checkDefs :: [Location] -> Session [Expect] -> Session ()-checkDefs defs mkExpectations = traverse_ check =<< mkExpectations where+linkToLocation :: [LocationLink] -> [Location]+linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange) +checkDefs :: [Location] |? [LocationLink] -> Session [Expect] -> Session ()+checkDefs (either id linkToLocation . toEither -> defs) mkExpectations = traverse_ check =<< mkExpectations where   check (ExpectRange expectedRange) = do     assertNDefinitionsFound 1 defs     assertRangeCorrect (head defs) expectedRange@@ -2966,6 +3166,7 @@ findDefinitionAndHoverTests :: TestTree findDefinitionAndHoverTests = let +  tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> Session [Expect] -> String -> TestTree   tst (get, check) pos targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do      -- Dirty the cache to check that definitions work even in the presence of iface files@@ -2977,7 +3178,7 @@       closeDoc fooDoc      doc <- openTestDataDoc (dir </> sourceFilePath)-    void (skipManyTill anyMessage message :: Session WorkDoneProgressEndNotification)+    waitForProgressDone     found <- get doc pos     check found targetRange @@ -3148,7 +3349,6 @@  pluginSimpleTests :: TestTree pluginSimpleTests =-  ignoreTest8101 "GHC #18070" $   ignoreInWindowsForGHC88And810 $   testSessionWithExtraFiles "plugin" "simple plugin" $ \dir -> do     _ <- openDoc (dir </> "KnownNat.hs") "haskell"@@ -3163,7 +3363,6 @@  pluginParsedResultTests :: TestTree pluginParsedResultTests =-  ignoreTest8101 "GHC #18070" $   ignoreInWindowsForGHC88And810 $   testSessionWithExtraFiles "plugin" "parsedResultAction plugin" $ \dir -> do     _ <- openDoc (dir</> "RecordDot.hs") "haskell"@@ -3436,7 +3635,7 @@ completionCommandTest name src pos wanted expected = testSession name $ do   docId <- createDoc "A.hs" "haskell" (T.unlines src)   _ <- waitForDiagnostics-  compls <- getCompletions docId pos+  compls <- skipManyTill anyMessage (getCompletions docId pos)   let wantedC = find ( \case             CompletionItem {_insertText = Just x} -> wanted `T.isPrefixOf` x             _ -> False@@ -3449,10 +3648,11 @@       executeCommand c       if src /= expected           then do-            modifiedCode <- getDocumentEdit docId+            void $ skipManyTill anyMessage loggingNotification+            modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId)             liftIO $ modifiedCode @?= T.unlines expected           else do-            expectMessages @ApplyWorkspaceEditRequest 1 $ \edit ->+            expectMessages SWorkspaceApplyEdit 1 $ \edit ->               liftIO $ assertFailure $ "Expected no edit but got: " <> show edit  completionNoCommandTest ::@@ -3762,6 +3962,27 @@       (Position 3 11)       [("Integer", CiStruct, "Integer ", True, True, Nothing)], +    testSession "duplicate record fields" $ do+      void $+        createDoc "B.hs" "haskell" $+          T.unlines+            [ "{-# LANGUAGE DuplicateRecordFields #-}",+              "module B where",+              "newtype Foo = Foo { member :: () }",+              "newtype Bar = Bar { member :: () }"+            ]+      docA <-+        createDoc "A.hs" "haskell" $+          T.unlines+            [ "module A where",+              "import B",+              "memb"+            ]+      _ <- waitForDiagnostics+      compls <- getCompletions docA $ Position 2 4+      let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"]+      liftIO $ compls' @?= ["member ${1:Foo}", "member ${1:Bar}"],+     testSessionWait "maxCompletions" $ do         doc <- createDoc "A.hs" "haskell" $ T.unlines             [ "{-# OPTIONS_GHC -Wunused-binds #-}",@@ -3779,7 +4000,7 @@     doc <- createDoc "A.hs" "haskell" source     _ <- waitForDiagnostics     highlights <- getHighlights doc (Position 3 2)-    liftIO $ highlights @?=+    liftIO $ highlights @?= List             [ DocumentHighlight (R 2 0 2 3) (Just HkRead)             , DocumentHighlight (R 3 0 3 3) (Just HkWrite)             , DocumentHighlight (R 4 6 4 9) (Just HkRead)@@ -3789,7 +4010,7 @@     doc <- createDoc "A.hs" "haskell" source     _ <- waitForDiagnostics     highlights <- getHighlights doc (Position 2 8)-    liftIO $ highlights @?=+    liftIO $ highlights @?= List             [ DocumentHighlight (R 2 7 2 10) (Just HkRead)             , DocumentHighlight (R 3 11 3 14) (Just HkRead)             ]@@ -3797,7 +4018,7 @@     doc <- createDoc "A.hs" "haskell" source     _ <- waitForDiagnostics     highlights <- getHighlights doc (Position 6 5)-    liftIO $ highlights @?=+    liftIO $ highlights @?= List             [ DocumentHighlight (R 6 4 6 7) (Just HkWrite)             , DocumentHighlight (R 6 10 6 13) (Just HkRead)             , DocumentHighlight (R 7 12 7 15) (Just HkRead)@@ -3806,7 +4027,7 @@     doc <- createDoc "A.hs" "haskell" recsource     _ <- waitForDiagnostics     highlights <- getHighlights doc (Position 4 15)-    liftIO $ highlights @?=+    liftIO $ highlights @?= List       -- Span is just the .. on 8.10, but Rec{..} before #if MIN_GHC_API_VERSION(8,10,0)             [ DocumentHighlight (R 4 8 4 10) (Just HkWrite)@@ -3816,7 +4037,7 @@             , DocumentHighlight (R 4 14 4 20) (Just HkRead)             ]     highlights <- getHighlights doc (Position 3 17)-    liftIO $ highlights @?=+    liftIO $ highlights @?= List             [ DocumentHighlight (R 3 17 3 23) (Just HkWrite)       -- Span is just the .. on 8.10, but Rec{..} before #if MIN_GHC_API_VERSION(8,10,0)@@ -4026,11 +4247,6 @@ xfail :: TestTree -> String -> TestTree xfail = flip expectFailBecause -ignoreTest8101 :: String -> TestTree -> TestTree-ignoreTest8101-  | GHC_API_VERSION == ("8.10.1" :: String) = ignoreTestBecause-  | otherwise = const id- ignoreInWindowsBecause :: String -> TestTree -> TestTree ignoreInWindowsBecause = if isWindows then ignoreTestBecause else (\_ x -> x) @@ -4128,7 +4344,7 @@     [testGroup "dependencies" [sessionDepsArePickedUp]     ,testGroup "ignore-fatal" [ignoreFatalWarning]     ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle]-    ,testGroup "multi"   [simpleMultiTest, simpleMultiTest2]+    ,testGroup "multi"   [simpleMultiTest, simpleMultiTest2, simpleMultiDefTest]     ,testGroup "sub-directory"   [simpleSubDirectoryTest]     ] @@ -4145,13 +4361,13 @@         implicit dir = test dir         test _dir = do             doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo"-            msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))+            msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics))             liftIO $ length msgs @?= 1             changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"]-            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))+            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics))             liftIO $ length msgs @?= 0             _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar"-            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message @PublishDiagnosticsNotification))+            msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics))             liftIO $ length msgs @?= 0  retryFailedCradle :: TestTree@@ -4230,7 +4446,7 @@  cradleLoadedMessage :: Session FromServerMessage cradleLoadedMessage = satisfy $ \case-        NotCustomServer (NotificationMessage _ (CustomServerMethod m) _) -> m == cradleLoadedMethod+        FromServerMess (SCustomMethod m) (NotMess _) -> m == cradleLoadedMethod         _ -> False  cradleLoadedMethod :: T.Text@@ -4288,6 +4504,28 @@     checkDefs locs (pure [fooL])     expectNoMoreDiagnostics 0.5 +-- Like simpleMultiTest but open the files in component 'a' in a seperate session+simpleMultiDefTest :: TestTree+simpleMultiDefTest = testCase "simple-multi-def-test" $ runWithExtraFiles "multi" $ \dir -> do+    let aPath = dir </> "a/A.hs"+        bPath = dir </> "b/B.hs"+    adoc <- liftIO $ runInDir dir $ do+      aSource <- liftIO $ readFileUtf8 aPath+      adoc <- createDoc aPath "haskell" aSource+      ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case+        FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do+          A.Success fp' <- pure $ fromJSON fp+          if equalFilePath fp' aPath then pure () else Nothing+        _ -> Nothing+      closeDoc adoc+      pure adoc+    bSource <- liftIO $ readFileUtf8 bPath+    bdoc <- createDoc bPath "haskell" bSource+    locs <- getDefinitions bdoc (Position 2 7)+    let fooL = mkL (adoc ^. L.uri) 2 0 2 3+    checkDefs locs (pure [fooL])+    expectNoMoreDiagnostics 0.5+ ifaceTests :: TestTree ifaceTests = testGroup "Interface loading tests"     [ -- https://github.com/haskell/ghcide/pull/645/@@ -4351,7 +4589,7 @@     -- Change y from Int to B     changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]]     -- save so that we can that the error propogates to A-    sendNotification TextDocumentDidSave (DidSaveTextDocumentParams bdoc)+    sendNotification STextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing)      -- Check that the error propogates to A     expectDiagnostics@@ -4359,10 +4597,11 @@       -- Check that we wrote the interfaces for B when we saved-    lid <- sendRequest (CustomClientMethod "hidir") $ GetInterfaceFilesDir bPath-    res <- skipManyTill anyMessage $ responseForId lid+    let m = SCustomMethod "test"+    lid <- sendRequest m $ toJSON $ GetInterfaceFilesDir bPath+    res <- skipManyTill anyMessage $ responseForId m lid     liftIO $ case res of-      ResponseMessage{_result=Right hidir} -> do+      ResponseMessage{_result=Right (A.fromJSON -> A.Success hidir)} -> do         hi_exists <- doesFileExist $ hidir </> "B.hi"         assertBool ("Couldn't find B.hi in " ++ hidir) hi_exists       _ -> assertFailure $ "Got malformed response for CustomMessage hidir: " ++ show res@@ -4505,6 +4744,8 @@         assertBool "did not successfully complete 5 repetitions" $ Bench.success res         | e <- Bench.experiments         , Bench.name e /= "edit" -- the edit experiment does not ever fail+        -- the cradle experiments are way too slow+        , not ("cradle" `isInfixOf` Bench.name e)     ]  -- | checks if we use InitializeParams.rootUri for loading session@@ -4526,8 +4767,8 @@     [       testSession "command" $ do             -- Execute a command that will block forever-            let req = ExecuteCommandParams blockCommandId Nothing Nothing-            void $ sendRequest WorkspaceExecuteCommand req+            let req = ExecuteCommandParams Nothing blockCommandId Nothing+            void $ sendRequest SWorkspaceExecuteCommand req             -- Load a file and check for code actions. Will only work if the command is run asynchronously             doc <- createDoc "A.hs" "haskell" $ T.unlines               [ "{-# OPTIONS -Wmissing-signatures #-}"@@ -4535,13 +4776,13 @@               ]             void waitForDiagnostics             actions <- getCodeActions doc (Range (Position 1 0) (Position 1 0))-            liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=?+            liftIO $ [ _title | InR CodeAction{_title} <- actions] @=?               [ "add signature: foo :: a -> a"               , "Disable \"missing-signatures\" warnings"               ]     , testSession "request" $ do             -- Execute a custom request that will block for 1000 seconds-            void $ sendRequest (CustomClientMethod "test") $ BlockSeconds 1000+            void $ sendRequest (SCustomMethod "test") $ toJSON $ BlockSeconds 1000             -- Load a file and check for code actions. Will only work if the request is run asynchronously             doc <- createDoc "A.hs" "haskell" $ T.unlines               [ "{-# OPTIONS -Wmissing-signatures #-}"@@ -4549,7 +4790,7 @@               ]             void waitForDiagnostics             actions <- getCodeActions doc (Range (Position 0 0) (Position 0 0))-            liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=?+            liftIO $ [ _title | InR CodeAction{_title} <- actions] @=?               [ "add signature: foo :: a -> a"               , "Disable \"missing-signatures\" warnings"               ]@@ -4558,19 +4799,15 @@  clientSettingsTest :: TestTree clientSettingsTest = testGroup "client settings handling"-    [-        testSession "ghcide does not support update config" $ do-            sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String)))-            logNot <- skipManyTill anyMessage loggingNotification-            isMessagePresent "Updating Not supported" [getLogMessage logNot]-    ,   testSession "ghcide restarts shake session on config changes" $ do-            void $ skipManyTill anyMessage $ message @RegisterCapabilityRequest-            sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String)))+    [ testSession "ghcide restarts shake session on config changes" $ do+            void $ skipManyTill anyMessage $ message SClientRegisterCapability+            sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String)))             nots <- skipManyTill anyMessage $ count 3 loggingNotification             isMessagePresent "Restarting build session" (map getLogMessage nots)      ]-  where getLogMessage (NotLogMessage (NotificationMessage _ _ (LogMessageParams _ msg))) = msg+  where getLogMessage :: FromServerMessage -> T.Text+        getLogMessage (FromServerMess SWindowLogMessage (NotificationMessage _ _ (LogMessageParams _ msg))) = msg         getLogMessage _ = ""          isMessagePresent expectedMsg actualMsgs = liftIO $@@ -4698,7 +4935,7 @@     YesIncludeDeclaration     | NoExcludeDeclaration -getReferences' :: SymbolLocation -> IncludeDeclaration -> Session [Location]+getReferences' :: SymbolLocation -> IncludeDeclaration -> Session (List Location) getReferences' (file, l, c) includeDeclaration = do     doc <- openDoc file "haskell"     getReferences doc (Position l c) $ toBool includeDeclaration@@ -4711,10 +4948,11 @@   -- Initial Index   docid <- openDoc thisDoc "haskell"   let+    loop :: [FilePath] -> Session ()     loop [] = pure ()     loop docs = do       doc <- skipManyTill anyMessage $ satisfyMaybe $ \case-          NotCustomServer (NotificationMessage _ (CustomServerMethod "ghcide/reference/ready") fp) -> do+          FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params = fp}) -> do             A.Success fp' <- pure $ fromJSON fp             find (fp' ==) docs           _ -> Nothing@@ -4728,7 +4966,7 @@ referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree referenceTest name loc includeDeclaration expected =     referenceTestSession name (fst3 loc) docs $ \dir -> do-        actual <- getReferences' loc includeDeclaration+        List actual <- getReferences' loc includeDeclaration         liftIO $ actual `expectSameLocations` map (first3 (dir </>)) expected   where     docs = map fst3 expected@@ -4771,18 +5009,18 @@       -- Experimentally, 0.5s seems to be long enough to wait for any final diagnostics to appear.       ( >> expectNoMoreDiagnostics 0.5) -pickActionWithTitle :: T.Text -> [CAResult] -> IO CodeAction+pickActionWithTitle :: T.Text -> [Command |? CodeAction] -> IO CodeAction pickActionWithTitle title actions = do   assertBool ("Found no matching actions for " <> show title <> " in " <> show titles) (not $ null matches)   return $ head matches   where     titles =         [ actionTitle-        | CACodeAction CodeAction { _title = actionTitle } <- actions+        | InR CodeAction { _title = actionTitle } <- actions         ]     matches =         [ action-        | CACodeAction action@CodeAction { _title = actionTitle } <- actions+        | InR action@CodeAction { _title = actionTitle } <- actions         , title == actionTitle         ] @@ -4864,12 +5102,12 @@   let matches = sequence         [ listToMaybe           [ action-          | CACodeAction action@CodeAction { _title = actionTitle } <- actions+          | InR action@CodeAction { _title = actionTitle } <- actions           , expectedTitle `op` actionTitle]         | expectedTitle <- expectedTitles]   let msg = show             [ actionTitle-            | CACodeAction CodeAction { _title = actionTitle } <- actions+            | InR CodeAction { _title = actionTitle } <- actions             ]             ++ " " <> errMsg <> " "             ++ show expectedTitles@@ -5085,13 +5323,13 @@     | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)     | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r -getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]-getWatchedFilesSubscriptionsUntil = do-      msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)+getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions]+getWatchedFilesSubscriptionsUntil m = do+      msgs <- manyTill (Just <$> message SClientRegisterCapability <|> Nothing <$ anyMessage) (message m)       return             [ args             | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs-            , Registration _id WorkspaceDidChangeWatchedFiles args <- regs+            , SomeRegistration (Registration _id SWorkspaceDidChangeWatchedFiles args) <- regs             ]  -- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path

@@ -2,6 +2,8 @@ -- SPDX-License-Identifier: Apache-2.0  {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}  module Development.IDE.Test   ( Cursor@@ -20,6 +22,7 @@   , waitForAction   ) where +import qualified Data.Aeson as A import Control.Applicative.Combinators import Control.Lens hiding (List) import Control.Monad@@ -27,18 +30,15 @@ import Data.Bifunctor (second) import qualified Data.Map.Strict as Map import qualified Data.Text as T-import Language.Haskell.LSP.Test hiding (message)-import qualified Language.Haskell.LSP.Test as LspTest-import Language.Haskell.LSP.Types-import Language.Haskell.LSP.Types.Lens as Lsp+import Language.LSP.Test hiding (message)+import qualified Language.LSP.Test as LspTest+import Language.LSP.Types+import Language.LSP.Types.Lens as Lsp import System.Time.Extra import Test.Tasty.HUnit import System.Directory (canonicalizePath) import Data.Maybe (fromJust)-import Development.IDE.Plugin.Test (WaitForIdeRuleResult, TestRequest(WaitForIdeRule))-import Data.Aeson (FromJSON)-import Data.Typeable (Typeable)-+import Development.IDE.Plugin.Test (WaitForIdeRuleResult, TestRequest(..))  -- | (0-based line number, 0-based column number) type Cursor = (Int, Int)@@ -70,7 +70,7 @@ -- if any diagnostic messages arrive in that period expectNoMoreDiagnostics :: Seconds -> Session () expectNoMoreDiagnostics timeout =-  expectMessages @PublishDiagnosticsNotification timeout $ \diagsNot -> do+  expectMessages STextDocumentPublishDiagnostics timeout $ \diagsNot -> do     let fileUri = diagsNot ^. params . uri         actual = diagsNot ^. params . diagnostics     liftIO $@@ -79,31 +79,29 @@           <> " got "           <> show actual -expectMessages :: (FromJSON msg, Typeable msg) => Seconds -> (msg -> Session ()) -> Session ()-expectMessages timeout handle = do+expectMessages :: SMethod m -> Seconds -> (ServerMessage m -> Session ()) -> Session ()+expectMessages m timeout handle = do     -- Give any further diagnostic messages time to arrive.     liftIO $ sleep timeout     -- Send a dummy message to provoke a response from the server.     -- This guarantees that we have at least one message to     -- process, so message won't block or timeout.-    void $ sendRequest (CustomClientMethod "non-existent-method") ()-    handleMessages+    let cm = SCustomMethod "test"+    i <- sendRequest cm $ A.toJSON GetShakeSessionQueueCount+    go cm i   where-    handleMessages = (LspTest.message >>= handle) <|> handleCustomMethodResponse <|> ignoreOthers-    ignoreOthers = void anyMessage >> handleMessages--handleCustomMethodResponse :: Session ()-handleCustomMethodResponse =-    -- the CustomClientMethod triggers a RspCustomServer-    -- handle that and then exit-    void (LspTest.message :: Session CustomResponse)+    go cm i = handleMessages+      where+        handleMessages = (LspTest.message m >>= handle) <|> (void $ responseForId cm i) <|> ignoreOthers+        ignoreOthers = void anyMessage >> handleMessages  flushMessages :: Session () flushMessages = do-    void $ sendRequest (CustomClientMethod "non-existent-method") ()-    handleCustomMethodResponse <|> ignoreOthers+    let cm = SCustomMethod "non-existent-method"+    i <- sendRequest cm A.Null+    void (responseForId cm i) <|> ignoreOthers cm i     where-        ignoreOthers = void anyMessage >> flushMessages+        ignoreOthers cm i = skipManyTill anyMessage (responseForId cm i) >> flushMessages  -- | It is not possible to use 'expectDiagnostics []' to assert the absence of diagnostics, --   only that existing diagnostics have been cleared.@@ -115,7 +113,7 @@   = expectDiagnosticsWithTags   . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) -unwrapDiagnostic :: PublishDiagnosticsNotification -> (Uri, List Diagnostic)+unwrapDiagnostic :: NotificationMessage TextDocumentPublishDiagnostics  -> (Uri, List Diagnostic) unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics)  expectDiagnosticsWithTags :: [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session ()@@ -180,8 +178,8 @@ canonicalizeUri :: Uri -> IO Uri canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri)) -diagnostic :: Session PublishDiagnosticsNotification-diagnostic = LspTest.message+diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics)+diagnostic = LspTest.message STextDocumentPublishDiagnostics  standardizeQuotes :: T.Text -> T.Text standardizeQuotes msg = let@@ -193,6 +191,11 @@  waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) waitForAction key TextDocumentIdentifier{_uri} = do-    waitId <- sendRequest (CustomClientMethod "test") (WaitForIdeRule key _uri)-    ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId waitId-    return _result+    let cm = SCustomMethod "test"+    waitId <- sendRequest cm (A.toJSON $ WaitForIdeRule key _uri)+    ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId+    return $ do+      e <- _result+      case A.fromJSON e of+        A.Error e -> Left $ ResponseError InternalError (T.pack e) Nothing+        A.Success a -> pure a