diff --git a/cabal.project b/cabal.project index e5f7be6b40..c8d824062e 100644 --- a/cabal.project +++ b/cabal.project @@ -56,7 +56,7 @@ package * write-ghc-environment-files: never -index-state: 2023-05-13T12:00:00Z +index-state: 2023-06-17T12:00:00Z constraints: -- For GHC 9.4, older versions of entropy fail to build on Windows diff --git a/configuration-ghc-90.nix b/configuration-ghc-90.nix index 56fd8edab0..e14705093c 100644 --- a/configuration-ghc-90.nix +++ b/configuration-ghc-90.nix @@ -24,6 +24,10 @@ let ghc-lib-parser = hself.callCabal2nix "ghc-lib-parser" inputs.ghc-lib-parser-94 {}; + lsp = hself.callCabal2nix "lsp" inputs.lsp {}; + lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {}; + lsp-test = hself.callCabal2nix "lsp-test" inputs.lsp-test {}; + hlint = appendConfigureFlag (hself.callCabal2nix "hlint" inputs.hlint-35 {}) "-fghc-lib"; hls-hlint-plugin = hself.callCabal2nixWithOptions "hls-hlint-plugin" diff --git a/configuration-ghc-92.nix b/configuration-ghc-92.nix index 77483ff1b9..e7dd2e384e 100644 --- a/configuration-ghc-92.nix +++ b/configuration-ghc-92.nix @@ -41,6 +41,10 @@ let implicit-hie-cradle = hself.callCabal2nix "implicit-hie-cradle" inputs.haskell-implicit-hie-cradle { }; + lsp = hself.callCabal2nix "lsp" inputs.lsp {}; + lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {}; + lsp-test = hself.callCabal2nix "lsp-test" inputs.lsp-test {}; + # Re-generate HLS drv excluding some plugins haskell-language-server = hself.callCabal2nixWithOptions "haskell-language-server" ./. diff --git a/configuration-ghc-94.nix b/configuration-ghc-94.nix index 2d183c9050..c53cc16ce7 100644 --- a/configuration-ghc-94.nix +++ b/configuration-ghc-94.nix @@ -17,6 +17,10 @@ let stylish-haskell = appendConfigureFlag hsuper.stylish-haskell "-fghc-lib"; + lsp = hself.callCabal2nix "lsp" inputs.lsp {}; + lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {}; + lsp-test = hself.callCabal2nix "lsp-test" inputs.lsp-test {}; + # Re-generate HLS drv excluding some plugins haskell-language-server = hself.callCabal2nixWithOptions "haskell-language-server" ./. diff --git a/configuration-ghc-96.nix b/configuration-ghc-96.nix index 4ddc27ac51..7dad1a944c 100644 --- a/configuration-ghc-96.nix +++ b/configuration-ghc-96.nix @@ -54,6 +54,10 @@ let stylish-haskell = appendConfigureFlag hsuper.stylish-haskell "-fghc-lib"; + lsp = hself.callCabal2nix "lsp" inputs.lsp {}; + lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {}; + lsp-test = hself.callCabal2nix "lsp-test" inputs.lsp-test {}; + # Re-generate HLS drv excluding some plugins haskell-language-server = hself.callCabal2nixWithOptions "haskell-language-server" ./. diff --git a/exe/Main.hs b/exe/Main.hs index f688fc6e6b..d0597e02ee 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -4,33 +4,33 @@ {-# LANGUAGE OverloadedStrings #-} module Main(main) where -import Control.Arrow ((&&&)) -import Control.Monad.IO.Class (liftIO) -import Data.Function ((&)) -import Data.Text (Text) -import qualified Development.IDE.Main as GhcideMain -import Development.IDE.Types.Logger (Doc, Priority (Error, Info), - WithPriority (WithPriority, priority), - cfilter, cmapWithPrio, - defaultLayoutOptions, - layoutPretty, - makeDefaultStderrRecorder, - payload, renderStrict, - withDefaultRecorder) -import qualified Development.IDE.Types.Logger as Logger -import qualified HlsPlugins as Plugins -import Ide.Arguments (Arguments (..), - GhcideArguments (..), - getArguments) -import Ide.Main (defaultMain) -import qualified Ide.Main as IdeMain -import Ide.PluginUtils (pluginDescToIdePlugins) -import Ide.Types (PluginDescriptor (pluginNotificationHandlers), - defaultPluginDescriptor, - mkPluginNotificationHandler) -import Language.LSP.Server as LSP -import Language.LSP.Types as LSP -import Prettyprinter (Pretty (pretty), vsep) +import Control.Arrow ((&&&)) +import Control.Monad.IO.Class (liftIO) +import Data.Function ((&)) +import Data.Text (Text) +import qualified Development.IDE.Main as GhcideMain +import Development.IDE.Types.Logger (Doc, Priority (Error, Info), + WithPriority (WithPriority, priority), + cfilter, cmapWithPrio, + defaultLayoutOptions, + layoutPretty, + makeDefaultStderrRecorder, + payload, renderStrict, + withDefaultRecorder) +import qualified Development.IDE.Types.Logger as Logger +import qualified HlsPlugins as Plugins +import Ide.Arguments (Arguments (..), + GhcideArguments (..), + getArguments) +import Ide.Main (defaultMain) +import qualified Ide.Main as IdeMain +import Ide.PluginUtils (pluginDescToIdePlugins) +import Ide.Types (PluginDescriptor (pluginNotificationHandlers), + defaultPluginDescriptor, + mkPluginNotificationHandler) +import Language.LSP.Protocol.Message as LSP +import Language.LSP.Server as LSP +import Prettyprinter (Pretty (pretty), vsep) data Log = LogIdeMain IdeMain.Log @@ -53,7 +53,7 @@ main = do -- This plugin just installs a handler for the `initialized` notification, which then -- picks up the LSP environment and feeds it to our recorders let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback") - { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SInitialized $ \_ _ _ _ -> do + { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SMethod_Initialized $ \_ _ _ _ -> do env <- LSP.getLspEnv liftIO $ (cb1 <> cb2) env } diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 80a5a8d1d5..6bebc98923 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -55,15 +55,16 @@ import Development.IDE.Types.Logger (Doc, Logger (Logger), import GHC.Stack.Types (emptyCallStack) import Ide.Plugin.Config (Config) import Ide.Types (IdePlugins (IdePlugins)) +import Language.LSP.Protocol.Message (Method (Method_Initialize), + ResponseError, + SMethod (SMethod_Exit, SMethod_WindowShowMessageRequest), + TRequestMessage) +import Language.LSP.Protocol.Types (MessageActionItem (MessageActionItem), + MessageType (MessageType_Error), + ShowMessageRequestParams (ShowMessageRequestParams), + type (|?) (InL)) import Language.LSP.Server (LspM) import qualified Language.LSP.Server as LSP -import Language.LSP.Types (MessageActionItem (MessageActionItem), - MessageType (MtError), - Method (Initialize), - RequestMessage, - ResponseError, - SMethod (SExit, SWindowShowMessageRequest), - ShowMessageRequestParams (ShowMessageRequestParams)) -- --------------------------------------------------------------------- @@ -288,12 +289,12 @@ launchErrorLSP recorder errorMsg = do -- Forcefully exit let exit = void $ tryPutMVar clientMsgVar () - let doInitialize :: LSP.LanguageContextEnv Config -> RequestMessage Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv Config, ())) + let doInitialize :: LSP.LanguageContextEnv Config -> TRequestMessage Method_Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv Config, ())) doInitialize env _ = do let restartTitle = "Try to restart" - void $ LSP.runLspT env $ LSP.sendRequest SWindowShowMessageRequest (ShowMessageRequestParams MtError errorMsg (Just [MessageActionItem restartTitle])) $ \case - Right (Just (MessageActionItem title)) + void $ LSP.runLspT env $ LSP.sendRequest SMethod_WindowShowMessageRequest (ShowMessageRequestParams MessageType_Error errorMsg (Just [MessageActionItem restartTitle])) $ \case + Right (InL (MessageActionItem title)) | title == restartTitle -> liftIO exit _ -> pure () @@ -314,4 +315,4 @@ launchErrorLSP recorder errorMsg = do setup exitHandler :: IO () -> LSP.Handlers (ErrorLSPM c) -exitHandler exit = LSP.notificationHandler SExit $ const $ liftIO exit +exitHandler exit = LSP.notificationHandler SMethod_Exit $ const $ liftIO exit diff --git a/flake.lock b/flake.lock index df70e769ad..8b15b2f87d 100644 --- a/flake.lock +++ b/flake.lock @@ -82,11 +82,11 @@ "haskell-hie-bios": { "flake": false, "locked": { - "lastModified": 1683794382, - "narHash": "sha256-GCf5yVZWphqyMiVvnrGUo5baUCcQz2oo3nL/ahTYVmc=", + "lastModified": 1686930638, + "narHash": "sha256-gfcxxHtZ2jUsiKNn/O4jEkfWF/2H04aTnaIvPDbtNlQ=", "owner": "haskell", "repo": "hie-bios", - "rev": "57db96016f0b9084e3fc530fd4a0708efc98a6a3", + "rev": "3d4fadfb0dc44cb287db9897ecfb503899d33513", "type": "github" }, "original": { @@ -157,13 +157,49 @@ "url": "https://hackage.haskell.org/package/hlint-3.5/hlint-3.5.tar.gz" } }, + "lsp": { + "flake": false, + "locked": { + "narHash": "sha256-H0qJbQQufOOWovqqdJv6GUaL49o7tET8yTkdLKH1qoE=", + "type": "tarball", + "url": "https://hackage.haskell.org/package/lsp-2.0.0.0/lsp-2.0.0.0.tar.gz" + }, + "original": { + "type": "tarball", + "url": "https://hackage.haskell.org/package/lsp-2.0.0.0/lsp-2.0.0.0.tar.gz" + } + }, + "lsp-test": { + "flake": false, + "locked": { + "narHash": "sha256-ac9G/i9JfFKfX7gI57fVirBgW+Np+GDlZ3/4Eb8r6Gc=", + "type": "tarball", + "url": "https://hackage.haskell.org/package/lsp-test-0.15.0.0/lsp-test-0.15.0.0.tar.gz" + }, + "original": { + "type": "tarball", + "url": "https://hackage.haskell.org/package/lsp-test-0.15.0.0/lsp-test-0.15.0.0.tar.gz" + } + }, + "lsp-types": { + "flake": false, + "locked": { + "narHash": "sha256-ISvkr2CQWWbxcGm62IK+NIVfq6CEzXQhov47f9YdHW4=", + "type": "tarball", + "url": "https://hackage.haskell.org/package/lsp-types-2.0.0.1/lsp-types-2.0.0.1.tar.gz" + }, + "original": { + "type": "tarball", + "url": "https://hackage.haskell.org/package/lsp-types-2.0.0.1/lsp-types-2.0.0.1.tar.gz" + } + }, "nixpkgs": { "locked": { - "lastModified": 1686355959, - "narHash": "sha256-w+6cxJ3dmDAURDvIKec11Ht12vWk2nEznWZEYlcEor0=", + "lastModified": 1686874404, + "narHash": "sha256-u2Ss8z+sGaVlKtq7sCovQ8WvXY+OoXJmY1zmyxITiaY=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "35885ddb2374c090aa6d98ea97e469e269e27d60", + "rev": "efc10371d5c5b8d2d58bab6c1100753efacfe550", "type": "github" }, "original": { @@ -209,6 +245,9 @@ "haskell-implicit-hie-cradle": "haskell-implicit-hie-cradle", "haskell-unix-compat": "haskell-unix-compat", "hlint-35": "hlint-35", + "lsp": "lsp", + "lsp-test": "lsp-test", + "lsp-types": "lsp-types", "nixpkgs": "nixpkgs", "ormolu-052": "ormolu-052", "ptr-poker": "ptr-poker", diff --git a/flake.nix b/flake.nix index d6ecb14712..1ba231f939 100644 --- a/flake.nix +++ b/flake.nix @@ -41,6 +41,20 @@ flake = false; }; + # not sure if this is the correct way to get lsp* packages in + lsp = { + url = "https://hackage.haskell.org/package/lsp-2.0.0.0/lsp-2.0.0.0.tar.gz"; + flake = false; + }; + lsp-types = { + url = "https://hackage.haskell.org/package/lsp-types-2.0.0.1/lsp-types-2.0.0.1.tar.gz"; + flake = false; + }; + lsp-test = { + url = "https://hackage.haskell.org/package/lsp-test-0.15.0.0/lsp-test-0.15.0.0.tar.gz"; + flake = false; + }; + haskell-unix-compat = { url = "github:jacobstanley/unix-compat/3f6bd688cb56224955e77245a2649ba99ea32fff"; flake = false; diff --git a/ghcide-bench/ghcide-bench.cabal b/ghcide-bench/ghcide-bench.cabal index ddc6d59e06..d4e89061f8 100644 --- a/ghcide-bench/ghcide-bench.cabal +++ b/ghcide-bench/ghcide-bench.cabal @@ -2,7 +2,7 @@ cabal-version: 3.0 build-type: Simple category: Development name: ghcide-bench -version: 2.0.0.0 +version: 2.1.0.0 license: Apache-2.0 license-file: LICENSE author: The Haskell IDE team @@ -89,6 +89,7 @@ library safe-exceptions, shake, text, + row-types default-extensions: BangPatterns DeriveFunctor @@ -118,7 +119,7 @@ test-suite test base, extra, ghcide-bench, - lsp-test ^>= 0.14, + lsp-test ^>= 0.15, tasty, tasty-hunit >= 0.10, tasty-rerun, diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index b6ab82226d..33e420962a 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -1,8 +1,10 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} @@ -23,53 +25,59 @@ module Experiments , runBench , exampleToOptions ) where -import Control.Applicative.Combinators (skipManyTill) -import Control.Concurrent.Async (withAsync) -import Control.Exception.Safe (IOException, handleAny, try) -import Control.Monad.Extra (allM, forM, forM_, forever, - unless, void, when, whenJust, - (&&^)) -import Control.Monad.Fail (MonadFail) +import Control.Applicative.Combinators (skipManyTill) +import Control.Concurrent.Async (withAsync) +import Control.Exception.Safe (IOException, handleAny, + try) +import Control.Lens ((^.)) +import Control.Lens.Extras (is) +import Control.Monad.Extra (allM, forM, forM_, forever, + unless, void, when, + whenJust, (&&^)) +import Control.Monad.Fail (MonadFail) import Control.Monad.IO.Class -import Data.Aeson (Value (Null), - eitherDecodeStrict', toJSON) -import qualified Data.Aeson as A -import qualified Data.ByteString as BS -import Data.Either (fromRight) +import Data.Aeson (Value (Null), + eitherDecodeStrict', + toJSON) +import qualified Data.Aeson as A +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Either (fromRight) import Data.List import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T +import Data.Proxy +import Data.Row hiding (switch) +import Data.Text (Text) +import qualified Data.Text as T import Data.Version import Development.IDE.Plugin.Test import Development.IDE.Test.Diagnostic -import Development.Shake (CmdOption (Cwd, FileStdout), - cmd_) +import Development.Shake (CmdOption (Cwd, FileStdout), + cmd_) import Experiments.Types +import Language.LSP.Protocol.Capabilities +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (Null, + SemanticTokenAbsolute (..)) +import qualified Language.LSP.Protocol.Types as LSP import Language.LSP.Test -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import Language.LSP.Types.Capabilities import Numeric.Natural import Options.Applicative import System.Directory -import System.Environment.Blank (getEnv) -import System.FilePath ((<.>), ()) +import System.Environment.Blank (getEnv) +import System.FilePath ((<.>), ()) import System.IO import System.Process import System.Time.Extra -import Text.ParserCombinators.ReadP (readP_to_S) +import Text.ParserCombinators.ReadP (readP_to_S) import Text.Printf charEdit :: Position -> TextDocumentContentChangeEvent charEdit p = - TextDocumentContentChangeEvent - { _range = Just (Range p p), - _rangeLength = Nothing, - _text = "a" - } + TextDocumentContentChangeEvent $ InL $ #range .== Range p p + .+ #rangeLength .== Nothing + .+ #text .== "a" data DocumentPositions = DocumentPositions { -- | A position that can be used to generate non null goto-def and completion responses @@ -111,13 +119,13 @@ experiments = isJust <$> getHover doc (fromJust identifierP), --------------------------------------------------------------------------------------- bench "getDefinition" $ allWithIdentifierPos $ \DocumentPositions{..} -> - either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP), + hasDefinitions <$> getDefinitions doc (fromJust identifierP), --------------------------------------------------------------------------------------- bench "getDefinition after edit" $ \docs -> do forM_ docs $ \DocumentPositions{..} -> changeDoc doc [charEdit stringLiteralP] flip allWithIdentifierPos docs $ \DocumentPositions{..} -> - either (not . null) (not . null) . toEither <$> getDefinitions doc (fromJust identifierP), + hasDefinitions <$> getDefinitions doc (fromJust identifierP), --------------------------------------------------------------------------------------- bench "documentSymbols" $ allM $ \DocumentPositions{..} -> do fmap (either (not . null) (not . null)) . getDocumentSymbols $ doc, @@ -183,8 +191,8 @@ experiments = ( \docs -> do hieYamlUri <- getDocUri "hie.yaml" liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n" - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [ FileEvent hieYamlUri FcChanged ] + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + [ FileEvent hieYamlUri FileChangeType_Changed ] waitForProgressStart waitForProgressStart waitForProgressStart -- the Session logic restarts a second time @@ -199,17 +207,17 @@ experiments = (\docs -> do hieYamlUri <- getDocUri "hie.yaml" liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n" - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [ FileEvent hieYamlUri FcChanged ] + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + [ FileEvent hieYamlUri FileChangeType_Changed ] flip allWithIdentifierPos docs $ \DocumentPositions{..} -> isJust <$> getHover doc (fromJust identifierP) ), --------------------------------------------------------------------------------------- benchWithSetup "hole fit suggestions" ( mapM_ $ \DocumentPositions{..} -> do - let edit :: TextDocumentContentChangeEvent =TextDocumentContentChangeEvent - { _range = Just Range {_start = bottom, _end = bottom} - , _rangeLength = Nothing, _text = t} + let edit =TextDocumentContentChangeEvent $ InL $ #range .== Range bottom bottom + .+ #rangeLength .== Nothing + .+ #text .== t bottom = Position maxBound 0 t = T.unlines ["" @@ -229,12 +237,15 @@ experiments = flip allM docs $ \DocumentPositions{..} -> do bottom <- pred . length . T.lines <$> documentContents doc diags <- getCurrentDiagnostics doc - case requireDiagnostic diags (DsError, (fromIntegral bottom, 8), "Found hole", Nothing) of + case requireDiagnostic diags (DiagnosticSeverity_Error, (fromIntegral bottom, 8), "Found hole", Nothing) of Nothing -> pure True Just _err -> pure False ) ] - + where hasDefinitions (InL (Definition (InL _))) = True + hasDefinitions (InL (Definition (InR ls))) = not $ null ls + hasDefinitions (InR (InL ds)) = not $ null ds + hasDefinitions (InR (InR LSP.Null)) = False --------------------------------------------------------------------------------------------- examplesPath :: FilePath @@ -481,7 +492,7 @@ badRun = BenchRun 0 0 0 0 0 0 0 0 0 0 0 0 0 False waitForProgressStart :: Session () waitForProgressStart = void $ do skipManyTill anyMessage $ satisfy $ \case - FromServerMess SWindowWorkDoneProgressCreate _ -> True + FromServerMess SMethod_WindowWorkDoneProgressCreate _ -> True _ -> False -- | Wait for all progress to be done @@ -491,7 +502,7 @@ waitForProgressDone = loop where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | is _workDoneProgressEnd v -> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop @@ -499,13 +510,13 @@ waitForProgressDone = loop -- | Wait for the build queue to be empty waitForBuildQueue :: Session Seconds waitForBuildQueue = do - let m = SCustomMethod "test" + let m = SMethod_CustomMethod (Proxy @"test") waitId <- sendRequest m (toJSON WaitForShakeQueue) (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId case resp of - ResponseMessage{_result=Right Null} -> return td + TResponseMessage{_result=Right Null} -> return td -- assume a ghcide binary lacking the WaitForShakeQueue method - _ -> return 0 + _ -> return 0 runBench :: HasConfig => @@ -636,11 +647,10 @@ setupDocumentContents config = -- Setup the special positions used by the experiments lastLine <- fromIntegral . length . T.lines <$> documentContents doc - changeDoc doc [TextDocumentContentChangeEvent - { _range = Just (Range (Position lastLine 0) (Position lastLine 0)) - , _rangeLength = Nothing - , _text = T.unlines [ "_hygienic = \"hygienic\"" ] - }] + changeDoc doc [TextDocumentContentChangeEvent $ InL + $ #range .== Range (Position lastLine 0) (Position lastLine 0) + .+ #rangeLength .== Nothing + .+ #text .== T.unlines [ "_hygienic = \"hygienic\"" ]] let -- Points to a string in the target file, -- convenient for hygienic edits @@ -649,19 +659,19 @@ setupDocumentContents config = -- Find an identifier defined in another file in this project symbols <- getDocumentSymbols doc let endOfImports = case symbols of - Left symbols | Just x <- findEndOfImports symbols -> x + Right 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} : _) = +findEndOfImports (DocumentSymbol{_kind = SymbolKind_Module, _name = "imports", _range} : _) = Just $ Position (succ $ _line $ _end _range) 4 -findEndOfImports [DocumentSymbol{_kind = SkFile, _children = Just (List cc)}] = +findEndOfImports [DocumentSymbol{_kind = SymbolKind_File, _children = Just (cc)}] = findEndOfImports cc findEndOfImports (DocumentSymbol{_range} : _) = - Just $ _start _range + Just $ _range ^. L.start findEndOfImports _ = Nothing -------------------------------------------------------------------------------------------- @@ -678,11 +688,11 @@ searchSymbol :: TextDocumentIdentifier -> T.Text -> Position -> Session (Maybe P searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do -- this search is expensive, so we cache the result on disk let cachedPath = fromJust (uriToFilePath _uri) <.> "identifierPosition" - cachedRes <- liftIO $ try @_ @IOException $ read <$> readFile cachedPath + cachedRes <- liftIO $ try @_ @IOException $ A.decode . BSL.fromStrict <$> BS.readFile cachedPath case cachedRes of Left _ -> do result <- loop pos - liftIO $ writeFile cachedPath $ show result + liftIO $ BS.writeFile cachedPath $ BSL.toStrict $ A.encode result return result Right res -> return res @@ -708,8 +718,8 @@ searchSymbol doc@TextDocumentIdentifier{_uri} fileContents pos = do checkDefinitions pos = do defs <- getDefinitions doc pos case defs of - (InL [Location uri _]) -> return $ uri /= _uri - _ -> return False + (InL (Definition (InR [Location uri _]))) -> return $ uri /= _uri + _ -> return False checkCompletions pos = not . null <$> getCompletions doc pos @@ -736,9 +746,9 @@ getStoredKeys = callTestPlugin GetStoredKeys -- Copy&paste from ghcide/test/Development.IDE.Test tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) tryCallTestPlugin cmd = do - let cm = SCustomMethod "test" + let cm = SMethod_CustomMethod (Proxy @"test") waitId <- sendRequest cm (A.toJSON cmd) - ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId + TResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId return $ case _result of Left e -> Left e Right json -> case A.fromJSON json of diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 4191f6d9f2..ec72d277b6 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -41,8 +41,8 @@ import Ide.PluginUtils (pluginDescToIdePlugin import Ide.Types (PluginDescriptor (pluginNotificationHandlers), defaultPluginDescriptor, mkPluginNotificationHandler) +import Language.LSP.Protocol.Message as LSP import Language.LSP.Server as LSP -import Language.LSP.Types as LSP import Paths_ghcide (version) import qualified System.Directory.Extra as IO import System.Environment (getExecutablePath) @@ -101,7 +101,7 @@ main = withTelemetryLogger $ \telemetryLogger -> do -- This plugin just installs a handler for the `initialized` notification, which then -- picks up the LSP environment and feeds it to our recorders let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback") - { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SInitialized $ \_ _ _ _ -> do + { pluginNotificationHandlers = mkPluginNotificationHandler LSP.SMethod_Initialized $ \_ _ _ _ -> do env <- LSP.getLspEnv liftIO $ (cb1 <> cb2) env } diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 3999846837..9ba17e756a 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -2,7 +2,7 @@ cabal-version: 3.0 build-type: Simple category: Development name: ghcide -version: 2.0.0.0 +version: 2.1.0.0 license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors @@ -65,12 +65,12 @@ library haddock-library >= 1.8 && < 1.12, hashable, hie-compat ^>= 0.3.0.0, - hls-plugin-api == 2.0.0.0, + hls-plugin-api == 2.1.0.0, lens, list-t, hiedb == 0.4.3.*, - lsp-types ^>= 1.6.0.0, - lsp ^>= 1.6.0.0 , + lsp-types ^>= 2.0.0.1, + lsp ^>= 2.0.0.0 , mtl, optparse-applicative, parallel, @@ -78,9 +78,10 @@ library prettyprinter >= 1.7, random, regex-tdfa >= 1.3.1.0, + row-types, text-rope, safe-exceptions, - hls-graph == 2.0.0.0, + hls-graph == 2.1.0.0, sorted-list, sqlite-simple, stm, @@ -345,7 +346,7 @@ test-suite ghcide-tests hls-plugin-api, lens, list-t, - lsp-test ^>= 0.14, + lsp-test ^>= 0.15, monoid-subclasses, network-uri, QuickCheck, @@ -363,6 +364,7 @@ test-suite ghcide-tests text, text-rope, unordered-containers, + row-types if impl(ghc < 9.2) build-depends: record-dot-preprocessor, diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 89855b5293..cfc9796c33 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -43,6 +43,7 @@ import Data.IORef import Data.List import qualified Data.Map.Strict as Map import Data.Maybe +import Data.Proxy import qualified Data.Text as T import Data.Time.Clock import Data.Version @@ -78,8 +79,8 @@ import HIE.Bios.Environment hiding (getCacheDir) import HIE.Bios.Types hiding (Log) import qualified HIE.Bios.Types as HieBios import Hie.Implicit.Cradle (loadImplicitHieCradle) +import Language.LSP.Protocol.Message import Language.LSP.Server -import Language.LSP.Types import System.Directory import qualified System.Directory.Extra as IO import System.FilePath @@ -632,7 +633,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do lfp <- flip makeRelative cfp <$> getCurrentDirectory when optTesting $ mRunLspT lspEnv $ - sendNotification (SCustomMethod "ghcide/cradle/loaded") (toJSON cfp) + sendNotification (SMethod_CustomMethod (Proxy @"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)) @@ -906,7 +907,7 @@ setCacheDirs recorder CacheDirs{..} dflags = do renderCradleError :: NormalizedFilePath -> CradleError -> FileDiagnostic renderCradleError nfp (CradleError _ _ec t) = - ideErrorWithSource (Just "cradle") (Just DsError) nfp (T.unlines (map T.pack t)) + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines (map T.pack t)) -- See Note [Multi Cradle Dependency Info] type DependencyInfo = Map.Map FilePath (Maybe UTCTime) @@ -1120,4 +1121,4 @@ showPackageSetupException (PackageCheckFailed BasePackageAbiMismatch{..}) = unwo renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic) renderPackageSetupException fp e = - ideErrorWithSource (Just "cradle") (Just DsError) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) + ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 1f3db651fb..c8e384c1b5 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -30,7 +30,7 @@ import qualified Development.IDE.Spans.AtPoint as AtPoint import Development.IDE.Types.HscEnvEq (hscEnv) import Development.IDE.Types.Location import qualified HieDb -import Language.LSP.Types (DocumentHighlight (..), +import Language.LSP.Protocol.Types (DocumentHighlight (..), SymbolInformation (..)) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 07db951a72..bb036f0b33 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -64,6 +64,7 @@ import Data.IORef import Data.List.Extra import Data.Map (Map) import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy(Proxy)) import qualified Data.Set as Set import Data.Maybe import qualified Data.Text as T @@ -98,8 +99,9 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Serialized import HieDb import qualified Language.LSP.Server as LSP -import Language.LSP.Types (DiagnosticTag (..)) -import qualified Language.LSP.Types as LSP +import Language.LSP.Protocol.Types (DiagnosticTag (..)) +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Protocol.Message as LSP import System.Directory import System.FilePath import System.IO.Extra (fixIO, newTempFileWithin) @@ -611,7 +613,7 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do source = "compile" catchErrs x = x `catches` [ Handler $ return . (,Nothing) . diagFromGhcException source dflags - , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "") + , Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "") . (("Error during " ++ T.unpack source) ++) . show @SomeException ] @@ -741,7 +743,7 @@ unDefer ( _ , fd) = (False, fd) upgradeWarningToError :: FileDiagnostic -> FileDiagnostic upgradeWarningToError (nfp, sh, fd) = - (nfp, sh, fd{_severity = Just DsError, _message = warn2err $ _message fd}) where + (nfp, sh, fd{_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message fd}) where warn2err :: T.Text -> T.Text warn2err = T.intercalate ": error:" . T.splitOn ": warning:" @@ -780,18 +782,15 @@ tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic) tagDiag (w@(Reason warning), (nfp, sh, fd)) #endif | Just tag <- requiresTag warning - = (w, (nfp, sh, fd { _tags = addTag tag (_tags fd) })) + = (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags fd) })) where requiresTag :: WarningFlag -> Maybe DiagnosticTag requiresTag Opt_WarnWarningsDeprecations - = Just DtDeprecated + = Just DiagnosticTag_Deprecated requiresTag wflag -- deprecation was already considered above | wflag `elem` unnecessaryDeprecationWarningFlags - = Just DtUnnecessary + = Just DiagnosticTag_Unnecessary requiresTag _ = Nothing - addTag :: DiagnosticTag -> Maybe (List DiagnosticTag) -> Maybe (List DiagnosticTag) - addTag t Nothing = Just (List [t]) - addTag t (Just (List ts)) = Just (List (t : ts)) -- other diagnostics are left unaffected tagDiag t = t @@ -919,12 +918,13 @@ indexHieFile se mod_summary srcPath !hash hf = do case lspEnv se of Nothing -> pure Nothing Just env -> LSP.runLspT env $ do - u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO Unique.newUnique + u <- LSP.ProgressToken . LSP.InR . T.pack . show . hashUnique <$> liftIO Unique.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" + _ <- LSP.sendRequest LSP.SMethod_WindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ()) + LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams u $ + toJSON $ LSP.WorkDoneProgressBegin + { _kind = LSP.AString @"begin" + , _title = "Indexing" , _cancellable = Nothing , _message = Nothing , _percentage = Nothing @@ -942,22 +942,25 @@ indexHieFile se mod_summary srcPath !hash hf = do progressPct = floor $ 100 * progressFrac whenJust (lspEnv se) $ \env -> whenJust tok $ \tok -> LSP.runLspT env $ - LSP.sendNotification LSP.SProgress $ LSP.ProgressParams tok $ - LSP.Report $ + LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams tok $ + toJSON $ case style of - Percentage -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing + Percentage -> LSP.WorkDoneProgressReport + { _kind = LSP.AString @"report" + , _cancellable = Nothing , _message = Nothing , _percentage = Just progressPct } - Explicit -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing + Explicit -> LSP.WorkDoneProgressReport + { _kind = LSP.AString @"report" + , _cancellable = Nothing , _message = Just $ T.pack " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..." , _percentage = Nothing } - NoProgress -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing + NoProgress -> LSP.WorkDoneProgressReport + { _kind = LSP.AString @"report" + , _cancellable = Nothing , _message = Nothing , _percentage = Nothing } @@ -974,15 +977,17 @@ indexHieFile se mod_summary srcPath !hash hf = do swapTVar indexCompleted 0 whenJust (lspEnv se) $ \env -> LSP.runLspT env $ when (coerce $ ideTesting se) $ - LSP.sendNotification (LSP.SCustomMethod "ghcide/reference/ready") $ + LSP.sendNotification (LSP.SMethod_CustomMethod (Proxy @"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" + LSP.sendNotification LSP.SMethod_Progress $ LSP.ProgressParams tok $ + toJSON $ + LSP.WorkDoneProgressEnd + { _kind = LSP.AString @"end" + , _message = Just $ "Finished indexing " <> T.pack (show done) <> " files" } -- We are done with the current indexing cycle, so destroy the token pure Nothing @@ -1014,7 +1019,7 @@ handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic] handleGenerationErrors dflags source action = action >> return [] `catches` [ Handler $ return . diagFromGhcException source dflags - , Handler $ return . diagFromString source DsError (noSpan "") + , Handler $ return . diagFromString source DiagnosticSeverity_Error (noSpan "") . (("Error during " ++ T.unpack source) ++) . show @SomeException ] @@ -1022,7 +1027,7 @@ handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagno handleGenerationErrors' dflags source action = fmap ([],) action `catches` [ Handler $ return . (,Nothing) . diagFromGhcException source dflags - , Handler $ return . (,Nothing) . diagFromString source DsError (noSpan "") + , Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "") . (("Error during " ++ T.unpack source) ++) . show @SomeException ] @@ -1292,9 +1297,9 @@ parseFileContents env customPreprocessor filename ms = do let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module unless (null errs) $ - throwE $ diagFromStrings "parser" DsError errs + throwE $ diagFromStrings "parser" DiagnosticSeverity_Error errs - let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns + let preproc_warnings = diagFromStrings "parser" DiagnosticSeverity_Warning preproc_warns (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed psMessages let (warns, errs) = renderMessages msgs diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index ead86d9700..9a1caecd88 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -33,8 +33,8 @@ import Development.IDE.Types.Logger (Pretty (pretty), import Development.IDE.Types.Options import qualified Focus import Ide.Plugin.Config (Config) +import Language.LSP.Protocol.Types import Language.LSP.Server hiding (getVirtualFile) -import Language.LSP.Types import qualified StmContainers.Map as STM import qualified System.Directory as Dir import qualified System.FilePath.Glob as Glob @@ -117,16 +117,16 @@ modifyFileExists state changes = do -- See Note [Invalidating file existence results] -- flush previous values let (fileModifChanges, fileExistChanges) = - partition ((== FcChanged) . snd) changes + partition ((== FileChangeType_Changed) . snd) changes mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges io1 <- recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges io2 <- recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges return (io1 <> io2) fromChange :: FileChangeType -> Maybe Bool -fromChange FcCreated = Just True -fromChange FcDeleted = Just False -fromChange FcChanged = Nothing +fromChange FileChangeType_Created = Just True +fromChange FileChangeType_Deleted = Just False +fromChange FileChangeType_Changed = Nothing ------------------------------------------------------------------------------------- diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index f3906ced6b..89d50432cf 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -56,6 +56,7 @@ import qualified System.Directory as Dir import qualified Development.IDE.Types.Logger as L +import Data.Aeson (ToJSON (toJSON)) import qualified Data.Binary as B import qualified Data.ByteString.Lazy as LBS import Data.List (foldl') @@ -69,14 +70,13 @@ import Development.IDE.Types.Logger (Pretty (pretty), cmapWithPrio, logWith, viaShow, (<+>)) -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions), - FileChangeType (FcChanged), +import Language.LSP.Protocol.Message (toUntypedRegistration) +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions), FileSystemWatcher (..), - WatchKind (..), _watchers) -import qualified Language.LSP.Types as LSP -import qualified Language.LSP.Types.Capabilities as LSP +import qualified Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Server as LSP import Language.LSP.VFS import System.FilePath import System.IO.Unsafe @@ -162,14 +162,14 @@ resetInterfaceStore state f = do -- | Reset the GetModificationTime state of watched files -- Assumes the list does not include any FOIs -resetFileStore :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO () +resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO () resetFileStore ideState changes = mask $ \_ -> do -- we record FOIs document versions in all the stored values -- so NEVER reset FOIs to avoid losing their versions -- FOI filtering is done by the caller (LSP Notification handler) forM_ changes $ \(nfp, c) -> do case c of - FcChanged + LSP.FileChangeType_Changed -- already checked elsewhere | not $ HM.member nfp fois -> atomically $ deleteValue (shakeExtras ideState) GetModificationTime nfp @@ -268,26 +268,27 @@ registerFileWatches globs = do if watchSupported then do let - regParams = LSP.RegistrationParams (List [LSP.SomeRegistration registration]) + regParams = LSP.RegistrationParams [toUntypedRegistration 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 = LSP.Registration "globalFileWatches" - LSP.SWorkspaceDidChangeWatchedFiles - regOptions + registration = LSP.TRegistration { _id ="globalFileWatches" + , _method = LSP.SMethod_WorkspaceDidChangeWatchedFiles + , _registerOptions = Just $ regOptions} regOptions = - DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers } + DidChangeWatchedFilesRegistrationOptions { _watchers = 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 = True, _watchDelete = True} + -- WatchKind_Custom 7 is for create, change, and delete + watchKind = LSP.WatchKind_Custom 7 -- 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 <- globs ] + watchers = [ watcher (LSP.GlobPattern (LSP.InL (LSP.Pattern (Text.pack glob)))) | glob <- globs ] - void $ LSP.sendRequest LSP.SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response + void $ LSP.sendRequest LSP.SMethod_ClientRegisterCapability regParams (const $ pure ()) -- TODO handle response return True else return False @@ -311,7 +312,7 @@ shareFilePath k = unsafePerformIO $ do atomicModifyIORef' filePathMap $ \km -> let new_key = HashMap.lookup k km in case new_key of - Just v -> (km, v) + Just v -> (km, v) Nothing -> (HashMap.insert k k km, k) {-# NOINLINE shareFilePath #-} - + diff --git a/ghcide/src/Development/IDE/Core/IdeConfiguration.hs b/ghcide/src/Development/IDE/Core/IdeConfiguration.hs index 45f6e8c3da..c59fb2fc9d 100644 --- a/ghcide/src/Development/IDE/Core/IdeConfiguration.hs +++ b/ghcide/src/Development/IDE/Core/IdeConfiguration.hs @@ -13,6 +13,7 @@ module Development.IDE.Core.IdeConfiguration where import Control.Concurrent.Strict +import Control.Lens ((^.)) import Control.Monad import Control.Monad.IO.Class import Data.Aeson.Types (Value) @@ -22,7 +23,7 @@ import Data.Text (Text, isPrefixOf) import Development.IDE.Core.Shake import Development.IDE.Graph import Development.IDE.Types.Location -import Language.LSP.Types +import Language.LSP.Protocol.Types import System.FilePath (isRelative) -- | Lsp client relevant configuration details @@ -49,15 +50,15 @@ parseConfiguration InitializeParams {..} = IdeConfiguration {..} where workspaceFolders = - foldMap (singleton . toNormalizedUri) _rootUri + foldMap (singleton . toNormalizedUri) (nullToMaybe _rootUri) <> (foldMap . foldMap) (singleton . parseWorkspaceFolder) - _workspaceFolders + (nullToMaybe =<< _workspaceFolders) clientSettings = hashed _initializationOptions parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri parseWorkspaceFolder WorkspaceFolder{_uri} = - toNormalizedUri (Uri _uri) + toNormalizedUri _uri modifyWorkspaceFolders :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO () diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 904adc7cb8..ddb919a424 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -24,6 +24,7 @@ import Control.Monad import Control.Monad.IO.Class import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.Proxy import qualified Data.Text as T import Development.IDE.Graph @@ -45,8 +46,9 @@ import Development.IDE.Types.Logger (Pretty (pretty), cmapWithPrio, logDebug) import Development.IDE.Types.Options (IdeTesting (..)) +import GHC.TypeLits (KnownSymbol) +import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Types as LSP data Log = LogShake Shake.Log deriving Show @@ -130,12 +132,13 @@ kick :: Action () kick = do files <- HashMap.keys <$> getFilesOfInterestUntracked ShakeExtras{exportsMap, ideTesting = IdeTesting testing, lspEnv, progress} <- getShakeExtras - let signal msg = when testing $ liftIO $ + let signal :: KnownSymbol s => Proxy s -> Action () + signal msg = when testing $ liftIO $ mRunLspT lspEnv $ - LSP.sendNotification (LSP.SCustomMethod msg) $ + LSP.sendNotification (LSP.SMethod_CustomMethod msg) $ toJSON $ map fromNormalizedFilePath files - signal "kick/start" + signal (Proxy @"kick/start") liftIO $ progressUpdate progress KickStarted -- Update the exports map @@ -155,4 +158,4 @@ kick = do void garbageCollectDirtyKeys liftIO $ writeVar var False - signal "kick/done" + signal (Proxy @"kick/done") diff --git a/ghcide/src/Development/IDE/Core/PositionMapping.hs b/ghcide/src/Development/IDE/Core/PositionMapping.hs index 8ba2b11457..b80e515cc2 100644 --- a/ghcide/src/Development/IDE/Core/PositionMapping.hs +++ b/ghcide/src/Development/IDE/Core/PositionMapping.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLabels #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 module Development.IDE.Core.PositionMapping @@ -28,11 +29,13 @@ import Control.Monad import Data.Algorithm.Diff import Data.Bifunctor import Data.List -import qualified Data.Text as T -import qualified Data.Vector.Unboxed as V -import Language.LSP.Types (Position (Position), Range (Range), - TextDocumentContentChangeEvent (TextDocumentContentChangeEvent), - UInt) +import Data.Row +import qualified Data.Text as T +import qualified Data.Vector.Unboxed as V +import Language.LSP.Protocol.Types (Position (Position), + Range (Range), + TextDocumentContentChangeEvent (TextDocumentContentChangeEvent), + UInt, type (|?) (InL)) -- | Either an exact position, or the range of text that was substituted data PositionResult a @@ -120,10 +123,12 @@ mkDelta cs = foldl' applyChange idDelta cs addDelta :: PositionDelta -> PositionMapping -> PositionMapping addDelta delta (PositionMapping pm) = PositionMapping (composeDelta delta pm) +-- TODO: We currently ignore the right hand side (if there is only text), as +-- that was what was done with lsp* 1.6 packages applyChange :: PositionDelta -> TextDocumentContentChangeEvent -> PositionDelta -applyChange PositionDelta{..} (TextDocumentContentChangeEvent (Just r) _ t) = PositionDelta - { toDelta = toCurrent r t <=< toDelta - , fromDelta = fromDelta <=< fromCurrent r t +applyChange PositionDelta{..} (TextDocumentContentChangeEvent (InL x)) = PositionDelta + { toDelta = toCurrent (x .! #range) (x .! #text) <=< toDelta + , fromDelta = fromDelta <=< fromCurrent (x .! #range) (x .! #text) } applyChange posMapping _ = posMapping diff --git a/ghcide/src/Development/IDE/Core/Preprocessor.hs b/ghcide/src/Development/IDE/Core/Preprocessor.hs index 91f1bb5a88..577e351678 100644 --- a/ghcide/src/Development/IDE/Core/Preprocessor.hs +++ b/ghcide/src/Development/IDE/Core/Preprocessor.hs @@ -8,9 +8,9 @@ module Development.IDE.Core.Preprocessor import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat.Util as Util -import qualified Development.IDE.GHC.Util as Util import Development.IDE.GHC.CPP import Development.IDE.GHC.Orphans () +import qualified Development.IDE.GHC.Util as Util import Control.DeepSeq (NFData (rnf)) import Control.Exception (evaluate) @@ -133,7 +133,9 @@ diagsFromCPPLogs filename logs = _source = Just "CPP", _message = T.unlines $ cdMessage d, _relatedInformation = Nothing, - _tags = Nothing + _tags = Nothing, + _codeDescription = Nothing, + _data_ = Nothing } diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index 7436ca56ff..598e4d649b 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -21,6 +21,7 @@ import Control.Concurrent.Strict import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) +import Data.Aeson (ToJSON (toJSON)) import Data.Foldable (for_) import Data.Functor (($>)) import qualified Data.Text as T @@ -30,9 +31,10 @@ import Development.IDE.Graph hiding (ShakeValue) import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified Focus +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP -import Language.LSP.Types -import qualified Language.LSP.Types as LSP import qualified StmContainers.Map as STM import System.Time.Extra import UnliftIO.Exception (bracket_) @@ -125,30 +127,32 @@ delayedProgressReporting before after (Just lspEnv) optProgressStyle = 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) liftIO $ sleep before - u <- ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique + u <- ProgressToken . InR . T.pack . show . hashUnique <$> liftIO newUnique b <- liftIO newBarrier - void $ LSP.runLspT lspEnv $ LSP.sendRequest LSP.SWindowWorkDoneProgressCreate + void $ LSP.runLspT lspEnv $ LSP.sendRequest SMethod_WindowWorkDoneProgressCreate LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b liftIO $ async $ do ready <- waitBarrier b LSP.runLspT lspEnv $ for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0) where - start id = LSP.sendNotification LSP.SProgress $ + start id = LSP.sendNotification SMethod_Progress $ LSP.ProgressParams { _token = id - , _value = LSP.Begin $ WorkDoneProgressBeginParams - { _title = "Processing" + , _value = toJSON $ WorkDoneProgressBegin + { _kind = AString @"begin" + , _title = "Processing" , _cancellable = Nothing , _message = Nothing , _percentage = Nothing } } - stop id = LSP.sendNotification LSP.SProgress + stop id = LSP.sendNotification SMethod_Progress LSP.ProgressParams { _token = id - , _value = LSP.End WorkDoneProgressEndParams - { _message = Nothing + , _value = toJSON $ WorkDoneProgressEnd + { _kind = AString @"end" + , _message = Nothing } } loop _ _ | optProgressStyle == NoProgress = @@ -164,17 +168,19 @@ delayedProgressReporting before after (Just lspEnv) optProgressStyle = do nextPct :: UInt nextPct = floor $ 100 * nextFrac when (nextPct /= prevPct) $ - LSP.sendNotification LSP.SProgress $ + LSP.sendNotification SMethod_Progress $ LSP.ProgressParams { _token = id - , _value = LSP.Report $ case optProgressStyle of - Explicit -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing + , _value = case optProgressStyle of + Explicit -> toJSON $ WorkDoneProgressReport + { _kind = AString @"report" + , _cancellable = Nothing , _message = Just $ T.pack $ show done <> "/" <> show todo , _percentage = Nothing } - Percentage -> LSP.WorkDoneProgressReportParams - { _cancellable = Nothing + Percentage -> toJSON $ WorkDoneProgressReport + { _kind = AString @"report" + , _cancellable = Nothing , _message = Nothing , _percentage = Just nextPct } diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index edc2abe148..491f4d4e0c 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -42,7 +42,7 @@ import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Diagnostics import GHC.Serialized (Serialized) -import Language.LSP.Types (Int32, +import Language.LSP.Protocol.Types (Int32, NormalizedFilePath) data LinkableType = ObjectLinkable | BCOLinkable diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 64bdb1d8b0..e94b7f23f2 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -92,6 +92,7 @@ import qualified Data.IntMap.Strict as IntMap import Data.List import qualified Data.Map as M import Data.Maybe +import Data.Proxy import qualified Data.Text.Utf16.Rope as Rope import qualified Data.Set as Set import qualified Data.Text as T @@ -135,7 +136,8 @@ import qualified GHC.LanguageExtensions as LangExt import qualified HieDb import Ide.Plugin.Config import qualified Language.LSP.Server as LSP -import Language.LSP.Types (SMethod (SCustomMethod, SWindowShowMessage), ShowMessageParams (ShowMessageParams), MessageType (MtInfo)) +import Language.LSP.Protocol.Types (ShowMessageParams (ShowMessageParams), MessageType (MessageType_Info)) +import Language.LSP.Protocol.Message (SMethod (SMethod_CustomMethod, SMethod_WindowShowMessage)) import Language.LSP.VFS import System.Directory (makeAbsolute, doesFileExist) import Data.Default (def, Default) @@ -314,7 +316,7 @@ withoutOption opt ms = ms{ms_hspp_opts= gopt_unset (ms_hspp_opts ms) opt} -- Ignore Haddock errors that are in both. Demote Haddock-only errors to warnings. mergeParseErrorsHaddock :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic] mergeParseErrorsHaddock normal haddock = normal ++ - [ (a,b,c{_severity = Just DsWarning, _message = fixMessage $ _message c}) + [ (a,b,c{_severity = Just DiagnosticSeverity_Warning, _message = fixMessage $ _message c}) | (a,b,c) <- haddock, Diag._range c `Set.notMember` locations] where locations = Set.fromList $ map (Diag._range . thd3) normal @@ -549,12 +551,14 @@ reportImportCyclesRule recorder = cycleErrorInFile _ _ = Nothing toDiag imp mods = (fp , ShowDiag , ) $ Diagnostic { _range = rng - , _severity = Just DsError + , _severity = Just DiagnosticSeverity_Error , _source = Just "Import cycle detection" , _message = "Cyclic module dependency between " <> showCycle mods , _code = Nothing , _relatedInformation = Nothing , _tags = Nothing + , _codeDescription = Nothing + , _data_ = Nothing } where rng = fromMaybe noRange $ srcSpanToRange (getLoc imp) fp = toNormalizedFilePath' $ fromMaybe noFilePath $ srcSpanToFilename (getLoc imp) @@ -591,7 +595,7 @@ getHieAstRuleDefinition f hsc tmr = do diagsWrite <- case isFoi of IsFOI Modified{firstOpen = False} -> do when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ - LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $ + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ toJSON $ fromNormalizedFilePath f pure [] _ | Just asts <- masts -> do @@ -855,7 +859,7 @@ getModIfaceFromDiskAndIndexRule recorder = -> do -- All good, the db has indexed the file when (coerce $ ideTesting se) $ liftIO $ mRunLspT (lspEnv se) $ - LSP.sendNotification (SCustomMethod "ghcide/reference/ready") $ + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/reference/ready")) $ toJSON $ fromNormalizedFilePath f -- Not in db, must re-index _ -> do @@ -1206,8 +1210,8 @@ instance Default RulesConfig where displayTHWarning :: LspT c IO () displayTHWarning | not isWindows && not hostIsDynamic = do - LSP.sendNotification SWindowShowMessage $ - ShowMessageParams MtInfo thWarningMessage + LSP.sendNotification SMethod_WindowShowMessage $ + ShowMessageParams MessageType_Info thWarningMessage | otherwise = return () thWarningMessage :: T.Text diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index 9118dc68d7..3e61ee582e 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -31,8 +31,8 @@ import Development.IDE.Types.Logger as Logger (Logger, cmapWithPrio) import Development.IDE.Types.Options (IdeOptions (..)) import Ide.Plugin.Config +import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Types as LSP import Control.Monad import qualified Development.IDE.Core.FileExists as FileExists diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 18152a5421..4ba1090087 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -167,10 +167,10 @@ import Ide.Types (IdePlugins (IdePlugins) PluginDescriptor (pluginId), PluginId) import Language.LSP.Diagnostics +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP -import Language.LSP.Types -import qualified Language.LSP.Types as LSP -import Language.LSP.Types.Capabilities import Language.LSP.VFS hiding (start) import qualified "list-t" ListT import OpenTelemetry.Eventlog @@ -303,7 +303,7 @@ type WithProgressFunc = forall a. type WithIndefiniteProgressFunc = forall a. T.Text -> LSP.ProgressCancellable -> IO a -> IO a -type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,TextDocumentVersion)) +type GetStalePersistent = NormalizedFilePath -> IdeAction (Maybe (Dynamic,PositionDelta,Maybe Int32)) getShakeExtras :: Action ShakeExtras getShakeExtras = do @@ -344,7 +344,7 @@ getPluginConfigAction plId = do -- This is called when we don't already have a result, or computing the rule failed. -- The result of this function will always be marked as 'stale', and a 'proper' rebuild of the rule will -- be queued if the rule hasn't run before. -addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,TextDocumentVersion))) -> Rules () +addPersistentRule :: IdeRule k v => k -> (NormalizedFilePath -> IdeAction (Maybe (v,PositionDelta,Maybe Int32))) -> Rules () addPersistentRule k getVal = do ShakeExtras{persistentKeys} <- getShakeExtrasRules void $ liftIO $ atomically $ modifyTVar' persistentKeys $ insertKeyMap (newKey k) (fmap (fmap (first3 toDyn)) . getVal) @@ -639,7 +639,6 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer actionQueue <- newQueue let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv - dirtyKeys <- newTVarIO mempty -- Take one VFS snapshot at the start vfsVar <- newTVarIO =<< vfsSnapshot lspEnv @@ -900,7 +899,7 @@ garbageCollectKeys label maxAge checkParents agedKeys = do logDebug logger $ T.pack $ label <> " of " <> show n <> " keys (took " <> showDuration t <> ")" when (coerce ideTesting) $ liftIO $ mRunLspT lspEnv $ - LSP.sendNotification (SCustomMethod "ghcide/GC") + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/GC")) (toJSON $ mapMaybe (fmap showKey . fromKeyType) garbage) return garbage @@ -1128,7 +1127,7 @@ defineEarlyCutOffNoFile recorder f = defineEarlyCutoff recorder $ RuleNoDiagnost defineEarlyCutoff' :: forall k v. IdeRule k v - => (TextDocumentVersion -> [FileDiagnostic] -> Action ()) -- ^ update diagnostics + => (Maybe Int32 -> [FileDiagnostic] -> Action ()) -- ^ update diagnostics -- | compare current and previous for freshness -> (BS.ByteString -> BS.ByteString -> Bool) -> k @@ -1220,7 +1219,7 @@ traceA (A Succeeded{}) = "Success" updateFileDiagnostics :: MonadIO m => Recorder (WithPriority Log) -> NormalizedFilePath - -> TextDocumentVersion + -> Maybe Int32 -> Key -> ShakeExtras -> [(ShowDiagnostic,Diagnostic)] -- ^ current results @@ -1254,15 +1253,15 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti Just env -> LSP.runLspT env $ do liftIO $ tag "count" (show $ Prelude.length newDiags) liftIO $ tag "key" (show k) - LSP.sendNotification LSP.STextDocumentPublishDiagnostics $ - LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) (List newDiags) + LSP.sendNotification SMethod_TextDocumentPublishDiagnostics $ + LSP.PublishDiagnosticsParams (fromNormalizedUri uri) (fmap fromIntegral ver) ( newDiags) return action where diagsFromRule :: Diagnostic -> Diagnostic diagsFromRule c@Diagnostic{_range} | coerce ideTesting = c {_relatedInformation = - Just $ List [ + Just $ [ DiagnosticRelatedInformation (Location (filePathToUri $ fromNormalizedFilePath fp) @@ -1297,7 +1296,7 @@ updateSTMDiagnostics :: (forall a. String -> String -> a -> a) -> STMDiagnosticStore -> NormalizedUri -> - TextDocumentVersion -> + Maybe Int32 -> DiagnosticsBySource -> STM [LSP.Diagnostic] updateSTMDiagnostics addTag store uri mv newDiagsBySource = @@ -1314,7 +1313,7 @@ updateSTMDiagnostics addTag store uri mv newDiagsBySource = setStageDiagnostics :: (forall a. String -> String -> a -> a) -> NormalizedUri - -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited + -> Maybe Int32 -- ^ the time that the file these diagnostics originate from was last edited -> T.Text -> [LSP.Diagnostic] -> STMDiagnosticStore @@ -1329,8 +1328,8 @@ getAllDiagnostics :: getAllDiagnostics = fmap (concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT -updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> STM () -updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (List changes) = +updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> STM () +updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = STM.focus (Focus.alter f) uri positionMapping where uri = toNormalizedUri _uri @@ -1341,8 +1340,5 @@ updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} Versi -- used which is evident in long running sessions. EM.mapAccumRWithKey (\acc _k (delta, _) -> let new = addDelta delta acc in (new, (delta, acc))) zeroMapping - (EM.insert actual_version (shared_change, zeroMapping) mappingForUri) + (EM.insert _version (shared_change, zeroMapping) mappingForUri) shared_change = mkDelta changes - actual_version = case _version of - Nothing -> error "Nothing version from server" -- This is a violation of the spec - Just v -> v diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 609134c5ab..ce4e3b6bc3 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -31,7 +31,7 @@ import Development.IDE.Types.Diagnostics (FileDiagnostic, import Development.IDE.Types.Location (Uri (..)) import Development.IDE.Types.Logger (Logger (Logger)) import Ide.Types (PluginId (..)) -import Language.LSP.Types (NormalizedFilePath, +import Language.LSP.Protocol.Types (NormalizedFilePath, fromNormalizedFilePath) import OpenTelemetry.Eventlog (SpanInFlight (..), addEvent, beginSpan, endSpan, setTag, diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index a8a7acce27..a8f5e88ca3 100644 --- a/ghcide/src/Development/IDE/GHC/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Error.hs @@ -44,7 +44,7 @@ import Development.IDE.GHC.Orphans () import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import GHC -import Language.LSP.Types (isSubrangeOf) +import Language.LSP.Protocol.Types (isSubrangeOf) diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic @@ -57,6 +57,8 @@ diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ fromMaybe noFileP , _code = Nothing , _relatedInformation = Nothing , _tags = Nothing + , _codeDescription = Nothing + , _data_ = Nothing } -- | Produce a GHC-style error from a source span and a message. @@ -132,13 +134,13 @@ toDSeverity :: GHC.Severity -> Maybe D.DiagnosticSeverity toDSeverity SevOutput = Nothing toDSeverity SevInteractive = Nothing toDSeverity SevDump = Nothing -toDSeverity SevInfo = Just DsInfo -toDSeverity SevFatal = Just DsError +toDSeverity SevInfo = Just DiagnosticSeverity_Information +toDSeverity SevFatal = Just DiagnosticSeverity_Error #else toDSeverity SevIgnore = Nothing #endif -toDSeverity SevWarning = Just DsWarning -toDSeverity SevError = Just DsError +toDSeverity SevWarning = Just DiagnosticSeverity_Warning +toDSeverity SevError = Just DiagnosticSeverity_Error -- | Produce a bag of GHC-style errors (@ErrorMessages@) from the given @@ -186,7 +188,7 @@ catchSrcErrors dflags fromWhere ghcM = do diagFromGhcException :: T.Text -> DynFlags -> GhcException -> [FileDiagnostic] -diagFromGhcException diagSource dflags exc = diagFromString diagSource DsError (noSpan "") (showGHCE dflags exc) +diagFromGhcException diagSource dflags exc = diagFromString diagSource DiagnosticSeverity_Error (noSpan "") (showGHCE dflags exc) showGHCE :: DynFlags -> GhcException -> String showGHCE dflags exc = case exc of diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index 9ddda656c9..ff82af1d65 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/ghcide/src/Development/IDE/GHC/Warnings.hs @@ -12,7 +12,7 @@ import qualified Data.Text as T import Development.IDE.GHC.Compat import Development.IDE.GHC.Error import Development.IDE.Types.Diagnostics -import Language.LSP.Types (type (|?) (..)) +import Language.LSP.Protocol.Types (type (|?) (..)) -- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some diff --git a/ghcide/src/Development/IDE/Import/FindImports.hs b/ghcide/src/Development/IDE/Import/FindImports.hs index a5b356a9a8..ba98e4f84f 100644 --- a/ghcide/src/Development/IDE/Import/FindImports.hs +++ b/ghcide/src/Development/IDE/Import/FindImports.hs @@ -180,7 +180,7 @@ notFoundErr env modName reason = mkError' $ ppr' $ cannotFindModule env modName0 $ lookupToFindResult reason where dfs = hsc_dflags env - mkError' = diagFromString "not found" DsError (Compat.getLoc modName) + mkError' = diagFromString "not found" DiagnosticSeverity_Error (Compat.getLoc modName) modName0 = unLoc modName ppr' = showSDoc dfs -- We convert the lookup result to a find result to reuse GHC's cannotFindModule pretty printer. diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index 94158f7ba3..fdd51a9014 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -16,26 +16,28 @@ module Development.IDE.LSP.HoverDefinition ) where import Control.Monad.IO.Class +import Data.Maybe (fromMaybe) import Development.IDE.Core.Actions import Development.IDE.Core.Rules import Development.IDE.Core.Shake import Development.IDE.Types.Location import Development.IDE.Types.Logger +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP -import Language.LSP.Types import qualified Data.Text as T -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 +gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (MessageResult Method_TextDocumentDefinition)) +hover :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (Hover |? Null)) +gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError (MessageResult Method_TextDocumentTypeDefinition)) +documentHighlight :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either ResponseError ([DocumentHighlight] |? Null)) +gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR) +gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR) +hover = request "Hover" getAtPoint (InR Null) foundHover +documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL -references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError (List Location)) +references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError ([Location] |? Null)) references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO $ case uriToFilePath' uri of Just path -> do @@ -43,17 +45,17 @@ references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO logDebug (ideLogger ide) $ "References request at position " <> T.pack (showPosition pos) <> " in file: " <> T.pack path - Right . List <$> (runAction "references" ide $ refsAtPoint filePath pos) - Nothing -> pure $ Left $ ResponseError InvalidParams ("Invalid URI " <> T.pack (show uri)) Nothing + Right . InL <$> (runAction "references" ide $ refsAtPoint filePath pos) + Nothing -> pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) ("Invalid URI " <> T.pack (show uri)) Nothing -wsSymbols :: IdeState -> WorkspaceSymbolParams -> LSP.LspM c (Either ResponseError (List SymbolInformation)) +wsSymbols :: IdeState -> WorkspaceSymbolParams -> LSP.LspM c (Either ResponseError [SymbolInformation]) wsSymbols ide (WorkspaceSymbolParams _ _ query) = liftIO $ do logDebug (ideLogger ide) $ "Workspace symbols request: " <> query - runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ Right . maybe (List []) List <$> workspaceSymbols query + runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ Right . fromMaybe [] <$> workspaceSymbols query -foundHover :: (Maybe Range, [T.Text]) -> Maybe Hover +foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null foundHover (mbRange, contents) = - Just $ Hover (HoverContents $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator contents) mbRange + InL $ Hover (InL $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator contents) mbRange -- | Respond to and log a hover or go-to-definition request request diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index b910a7cba2..5e3a8800b7 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -1,12 +1,12 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StarIsType #-} - -- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync -- This version removes the daml: handling module Development.IDE.LSP.LanguageServer @@ -26,8 +26,9 @@ import qualified Data.Text as T import Development.IDE.LSP.Server import Development.IDE.Session (runWithDb) import Ide.Types (traceWithSpan) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP -import Language.LSP.Types import System.IO import UnliftIO.Async import UnliftIO.Concurrent @@ -47,7 +48,6 @@ import Language.LSP.Server (LanguageContextEnv, LspServerLog, type (<~>)) import System.IO.Unsafe (unsafeInterleaveIO) - data Log = LogRegisteringIdeConfig !IdeConfiguration | LogReactorThreadException !SomeException @@ -92,7 +92,7 @@ runLanguageServer -> config -> (config -> Value -> Either T.Text config) -> (MVar () - -> IO (LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv config, a)), + -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either ResponseError (LSP.LanguageContextEnv config, a)), LSP.Handlers (m config), (LanguageContextEnv config, a) -> m config <~> IO)) -> IO () @@ -133,7 +133,7 @@ setupLSP :: -> LSP.Handlers (ServerM config) -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) -> MVar () - -> IO (LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), + -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), LSP.Handlers (ServerM config), (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do @@ -195,8 +195,8 @@ handleInit -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage - -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) -handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do + -> LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) +handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (TRequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params let root = LSP.resRootPath env dir <- maybe getCurrentDirectory return root @@ -233,11 +233,11 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa case cancelOrRes of Left () -> do log Debug $ LogCancelledRequest _id - k $ ResponseError RequestCancelled "" Nothing + k $ ResponseError (InL LSPErrorCodes_RequestCancelled) "" Nothing Right res -> pure res ) $ \(e :: SomeException) -> do exceptionInHandler e - k $ ResponseError InternalError (T.pack $ show e) Nothing + k $ ResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing _ <- flip forkFinally handleServerException $ do untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb hieChan -> do putMVar dbMVar (WithHieDbShield withHieDb,hieChan) @@ -263,27 +263,30 @@ untilMVar mvar io = void $ waitAnyCancel =<< traverse async [ io , readMVar mvar ] cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) -cancelHandler cancelRequest = LSP.notificationHandler SCancelRequest $ \NotificationMessage{_params=CancelParams{_id}} -> - liftIO $ cancelRequest (SomeLspId _id) +cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \TNotificationMessage{_params=CancelParams{_id}} -> + liftIO $ cancelRequest (SomeLspId (toLspId _id)) + where toLspId :: (Int32 |? T.Text) -> LspId a + toLspId (InL x) = IdInt x + toLspId (InR y) = IdString y shutdownHandler :: IO () -> LSP.Handlers (ServerM c) -shutdownHandler stopReactor = LSP.requestHandler SShutdown $ \_ resp -> do +shutdownHandler stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do (_, ide) <- ask liftIO $ logDebug (ideLogger ide) "Received shutdown message" -- stop the reactor to free up the hiedb connection liftIO stopReactor -- flush out the Shake session to record a Shake profile if applicable liftIO $ shakeShut ide - resp $ Right Empty + resp $ Right Null exitHandler :: IO () -> LSP.Handlers (ServerM c) -exitHandler exit = LSP.notificationHandler SExit $ const $ liftIO exit +exitHandler exit = LSP.notificationHandler SMethod_Exit $ const $ liftIO exit modifyOptions :: LSP.Options -> LSP.Options -modifyOptions x = x{ LSP.textDocumentSync = Just $ tweakTDS origTDS +modifyOptions x = x{ LSP.optTextDocumentSync = Just $ tweakTDS origTDS } where - tweakTDS tds = tds{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ InR $ SaveOptions Nothing} - origTDS = fromMaybe tdsDefault $ LSP.textDocumentSync x + tweakTDS tds = tds{_openClose=Just True, _change=Just TextDocumentSyncKind_Incremental, _save=Just $ InR $ SaveOptions Nothing} + origTDS = fromMaybe tdsDefault $ LSP.optTextDocumentSync x tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 3830358af8..80b956904d 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -13,8 +13,9 @@ module Development.IDE.LSP.Notifications , ghcideNotificationsPluginPriority ) where -import Language.LSP.Types -import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Types as LSP import Control.Concurrent.STM.Stats (atomically) import Control.Monad.Extra @@ -56,9 +57,9 @@ whenUriFile uri act = whenJust (LSP.uriToFilePath uri) $ act . toNormalizedFileP descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat - [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ + [ mkPluginNotificationHandler LSP.SMethod_TextDocumentDidOpen $ \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do - atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List []) + atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri _version) [] 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 @@ -66,7 +67,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHa setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file logDebug (ideLogger ide) $ "Opened text document: " <> getUri _uri - , mkPluginNotificationHandler LSP.STextDocumentDidChange $ + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ \ide vfs _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do atomically $ updatePositionMapping ide identifier changes whenUriFile _uri $ \file -> do @@ -74,14 +75,14 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHa setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file logDebug (ideLogger ide) $ "Modified text document: " <> getUri _uri - , mkPluginNotificationHandler LSP.STextDocumentDidSave $ + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do addFileOfInterest ide file OnDisk setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file logDebug (ideLogger ide) $ "Saved text document: " <> getUri _uri - , mkPluginNotificationHandler LSP.STextDocumentDidClose $ + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do deleteFileOfInterest ide file @@ -90,8 +91,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHa setSomethingModified (VFSModified vfs) ide [] $ Text.unpack msg logDebug (ideLogger ide) msg - , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWatchedFiles $ - \ide vfs _ (DidChangeWatchedFilesParams (List fileEvents)) -> liftIO $ do + , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $ + \ide vfs _ (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 -- filter out files of interest, since we already know all about those @@ -110,7 +111,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHa resetFileStore ide fileEvents' setSomethingModified (VFSModified vfs) ide [] msg - , mkPluginNotificationHandler LSP.SWorkspaceDidChangeWorkspaceFolders $ + , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $ \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do let add = S.union substract = flip S.difference @@ -118,14 +119,14 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHa $ add (foldMap (S.singleton . parseWorkspaceFolder) (_added events)) . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events)) - , mkPluginNotificationHandler LSP.SWorkspaceDidChangeConfiguration $ + , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration $ \ide vfs _ (DidChangeConfigurationParams cfg) -> liftIO $ do let msg = Text.pack $ show cfg logDebug (ideLogger ide) $ "Configuration changed: " <> msg modifyClientSettings ide (const $ Just cfg) setSomethingModified (VFSModified vfs) ide [toKey GetClientSettings emptyFilePath] "config change" - , mkPluginNotificationHandler LSP.SInitialized $ \ide _ _ _ -> do + , mkPluginNotificationHandler LSP.SMethod_Initialized $ \ide _ _ _ -> do --------- Initialize Shake session -------------------------------------------------------------------- liftIO $ shakeSessionInit (cmapWithPrio LogShake recorder) ide diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index 7afcb5bfdd..64c7e14bd9 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -23,25 +23,25 @@ import Development.IDE.GHC.Error (rangeToRealSrcSpan, import Development.IDE.Types.Location import Development.IDE.GHC.Util (printOutputable) import Language.LSP.Server (LspM) -import Language.LSP.Types (DocumentSymbol (..), +import Language.LSP.Protocol.Types (DocumentSymbol (..), DocumentSymbolParams (DocumentSymbolParams, _textDocument), - List (..), ResponseError, SymbolInformation, - SymbolKind (SkConstructor, SkField, SkFile, SkFunction, SkInterface, SkMethod, SkModule, SkObject, SkStruct, SkTypeParameter, SkUnknown), + SymbolKind (..), TextDocumentIdentifier (TextDocumentIdentifier), - type (|?) (InL), uriToFilePath) + type (|?) (InL, InR), uriToFilePath, Null) +import Language.LSP.Protocol.Message (ResponseError) #if MIN_VERSION_ghc(9,2,0) import Data.List.NonEmpty (nonEmpty) #endif moduleOutline - :: IdeState -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) + :: IdeState -> DocumentSymbolParams -> LspM c (Either ResponseError ([SymbolInformation] |? ([DocumentSymbol] |? Null))) 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 -> InL (List []) + Nothing -> InL [] Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } } -> let declSymbols = mapMaybe documentSymbolForDecl hsmodDecls @@ -49,7 +49,7 @@ moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentif (L (locA -> (RealSrcSpan l _)) m) -> Just $ (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable m - , _kind = SkFile + , _kind = SymbolKind_File , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0 } _ -> Nothing @@ -59,14 +59,14 @@ moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentif allSymbols = case moduleSymbol of Nothing -> importSymbols <> declSymbols Just x -> - [ x { _children = Just (List (importSymbols <> declSymbols)) + [ x { _children = Just (importSymbols <> declSymbols) } ] in - InL (List allSymbols) + InR (InL allSymbols) - Nothing -> pure $ Right $ InL (List []) + Nothing -> pure $ Right $ InL [] documentSymbolForDecl :: LHsDecl GhcPs -> Maybe DocumentSymbol documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) @@ -77,7 +77,7 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ FamDecl { tcdFam = t -> " " <> t ) , _detail = Just $ printOutputable fdInfo - , _kind = SkFunction + , _kind = SymbolKind_Function } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) = Just (defDocumentSymbol l :: DocumentSymbol) @@ -86,13 +86,13 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ ClassDecl { tcdLNa "" -> "" t -> " " <> t ) - , _kind = SkInterface + , _kind = SymbolKind_Interface , _detail = Just "class" , _children = - Just $ List + Just $ [ (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable n - , _kind = SkMethod + , _kind = SymbolKind_Method , _selectionRange = realSrcSpanToRange l' } | L (locA -> (RealSrcSpan l _)) (ClassOpSig _ False names _) <- tcdSigs @@ -102,15 +102,15 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ ClassDecl { tcdLNa documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable name - , _kind = SkStruct + , _kind = SymbolKind_Struct , _children = - Just $ List + Just $ [ (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable n - , _kind = SkConstructor + , _kind = SymbolKind_Constructor , _selectionRange = realSrcSpanToRange l' #if MIN_VERSION_ghc(9,2,0) - , _children = List . toList <$> nonEmpty childs + , _children = toList <$> nonEmpty childs } | con <- extract_cons dd_cons , let (cs, flds) = hsConDeclsBinders con @@ -133,7 +133,7 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLNam #else { _name = printOutputable (unLoc (rdrNameFieldOcc n)) #endif - , _kind = SkField + , _kind = SymbolKind_Field } cvtFld _ = Nothing #else @@ -145,10 +145,10 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLNam } where -- | Extract the record fields of a constructor - conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List + conArgRecordFields (RecCon (L _ lcdfs)) = Just [ (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable n - , _kind = SkField + , _kind = SymbolKind_Field } | L _ cdf <- lcdfs , L (locA -> (RealSrcSpan l _)) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf @@ -157,12 +157,12 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLNam #endif documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ SynDecl { tcdLName = L (locA -> (RealSrcSpan l' _)) n })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable n - , _kind = SkTypeParameter + , _kind = SymbolKind_TypeParameter , _selectionRange = realSrcSpanToRange l' } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable cid_poly_ty - , _kind = SkInterface + , _kind = SymbolKind_Interface } #if MIN_VERSION_ghc(9,2,0) documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl FamEqn { feqn_tycon, feqn_pats } })) @@ -177,7 +177,7 @@ documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ DataFamInstD { dfid_inst = D printOutputable (unLoc feqn_tycon) <> " " <> T.unwords (map printOutputable feqn_pats) #endif - , _kind = SkInterface + , _kind = SymbolKind_Interface } #if MIN_VERSION_ghc(9,2,0) documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl _ FamEqn { feqn_tycon, feqn_pats } })) @@ -192,23 +192,23 @@ documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ TyFamInstD { tfid_inst = TyF printOutputable (unLoc feqn_tycon) <> " " <> T.unwords (map printOutputable feqn_pats) #endif - , _kind = SkInterface + , _kind = SymbolKind_Interface } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) = gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) -> (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable @(HsType GhcPs) name - , _kind = SkInterface + , _kind = SymbolKind_Interface } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ FunBind{fun_id = L _ name})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable name - , _kind = SkFunction + , _kind = SymbolKind_Function } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ PatBind{pat_lhs})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable pat_lhs - , _kind = SkFunction + , _kind = SymbolKind_Function } documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ForD _ x)) = Just @@ -217,7 +217,7 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ForD _ x)) = Just ForeignImport{} -> name ForeignExport{} -> name XForeignDecl{} -> "?" - , _kind = SkObject + , _kind = SymbolKind_Object , _detail = case x of ForeignImport{} -> Just "import" ForeignExport{} -> Just "export" @@ -240,15 +240,15 @@ documentSymbolForImportSummary importSymbols = in Just (defDocumentSymbol (rangeToRealSrcSpan "" importRange)) { _name = "imports" - , _kind = SkModule - , _children = Just (List importSymbols) + , _kind = SymbolKind_Module + , _children = Just importSymbols } documentSymbolForImport :: LImportDecl GhcPs -> Maybe DocumentSymbol documentSymbolForImport (L (locA -> (RealSrcSpan l _)) ImportDecl { ideclName, ideclQualified }) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = "import " <> printOutputable ideclName - , _kind = SkModule + , _kind = SymbolKind_Module , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" } } documentSymbolForImport _ = Nothing @@ -258,7 +258,9 @@ defDocumentSymbol l = DocumentSymbol { .. } where _detail = Nothing _deprecated = Nothing _name = "" - _kind = SkUnknown 0 + -- This used to be SkUnknown 0, which is invalid, as SymbolKinds start at 1, + -- therefore, I am replacing it with SymbolKind_File, which is the type for 1 + _kind = SymbolKind_File _range = realSrcSpanToRange l _selectionRange = realSrcSpanToRange l _children = Nothing diff --git a/ghcide/src/Development/IDE/LSP/Server.hs b/ghcide/src/Development/IDE/LSP/Server.hs index b47bc46f90..bdfe407d5b 100644 --- a/ghcide/src/Development/IDE/LSP/Server.hs +++ b/ghcide/src/Development/IDE/LSP/Server.hs @@ -1,12 +1,8 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} module Development.IDE.LSP.Server ( ReactorMessage(..) , ReactorChan @@ -14,15 +10,14 @@ module Development.IDE.LSP.Server , requestHandler , notificationHandler ) where - -import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Reader import Development.IDE.Core.Shake import Development.IDE.Core.Tracing -import Ide.Types (HasTracing, traceWithSpan) -import Language.LSP.Server (Handlers, LspM) -import qualified Language.LSP.Server as LSP -import Language.LSP.Types +import Ide.Types (HasTracing, traceWithSpan) +import Language.LSP.Protocol.Message +import Language.LSP.Server (Handlers, LspM) +import qualified Language.LSP.Server as LSP import Language.LSP.VFS import UnliftIO.Chan @@ -35,25 +30,26 @@ newtype ServerM c a = ServerM { unServerM :: ReaderT (ReactorChan, IdeState) (Ls deriving (Functor, Applicative, Monad, MonadReader (ReactorChan, IdeState), MonadIO, MonadUnliftIO, LSP.MonadLsp c) requestHandler - :: forall (m :: Method FromClient Request) c. (HasTracing (MessageParams m)) => + :: forall (m :: Method ClientToServer Request) c. (HasTracing (MessageParams m)) => SMethod m - -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (ResponseResult m))) + -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (MessageResult m))) -> Handlers (ServerM c) -requestHandler m k = LSP.requestHandler m $ \RequestMessage{_method,_id,_params} resp -> do +requestHandler m k = LSP.requestHandler m $ \TRequestMessage{_method,_id,_params} resp -> do st@(chan,ide) <- ask env <- LSP.getLspEnv - let resp' = flip (runReaderT . unServerM) st . resp + let resp' :: Either ResponseError (MessageResult m) -> LspM c () + resp' = flip (runReaderT . unServerM) 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) notificationHandler - :: forall (m :: Method FromClient Notification) c. (HasTracing (MessageParams m)) => + :: forall (m :: Method ClientToServer Notification) c. (HasTracing (MessageParams m)) => SMethod m -> (IdeState -> VFS -> MessageParams m -> LspM c ()) -> Handlers (ServerM c) -notificationHandler m k = LSP.notificationHandler m $ \NotificationMessage{_params,_method}-> do +notificationHandler m k = LSP.notificationHandler m $ \TNotificationMessage{_params,_method}-> do (chan,ide) <- ask env <- LSP.getLspEnv -- Take a snapshot of the VFS state on every notification diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index ae18d3a571..a7b124a96a 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -235,7 +235,7 @@ defaultArguments recorder logger plugins = Arguments { optCheckProject = pure $ checkProject config , optCheckParents = pure $ checkParents config } - , argsLspOptions = def {LSP.completionTriggerCharacters = Just "."} + , argsLspOptions = def {LSP.optCompletionTriggerCharacters = Just "."} , argsDefaultHlsConfig = def , argsGetHieDbLoc = getHieDbLoc , argsDebouncer = newAsyncDebouncer @@ -293,7 +293,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re let hlsPlugin = asGhcIdePlugin (cmapWithPrio LogPluginHLS recorder) argsHlsPlugins hlsCommands = allLspCmdIds' pid argsHlsPlugins plugins = hlsPlugin <> argsGhcidePlugin - options = argsLspOptions { LSP.executeCommandCommands = LSP.executeCommandCommands argsLspOptions <> Just hlsCommands } + options = argsLspOptions { LSP.optExecuteCommandCommands = LSP.optExecuteCommandCommands argsLspOptions <> Just hlsCommands } argsOnConfigChange = getConfigFromNotification argsHlsPlugins rules = argsRules >> pluginRules plugins diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 9dc28d379d..2a1841131c 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -11,15 +11,15 @@ module Development.IDE.Plugin.Completions import Control.Concurrent.Async (concurrently) import Control.Concurrent.STM.Stats (readTVarIO) +import Control.Lens ((&), (.~)) import Control.Monad.IO.Class -import Control.Lens ((&), (.~)) +import Data.Aeson import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as Set -import Data.Aeson import Data.Maybe import qualified Data.Text as T -import Development.IDE.Core.PositionMapping import Development.IDE.Core.Compile +import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service hiding (Log, LogShake) import Development.IDE.Core.Shake hiding (Log) @@ -27,10 +27,10 @@ import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Util import Development.IDE.Graph -import Development.IDE.Spans.Common -import Development.IDE.Spans.Documentation import Development.IDE.Plugin.Completions.Logic import Development.IDE.Plugin.Completions.Types +import Development.IDE.Spans.Common +import Development.IDE.Spans.Documentation import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackageExports, envVisibleModuleNames), hscEnv) @@ -41,9 +41,10 @@ import Development.IDE.Types.Logger (Pretty (pretty), WithPriority, cmapWithPrio) import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP -import Language.LSP.Types -import qualified Language.LSP.Types.Lens as J import qualified Language.LSP.VFS as VFS import Numeric.Natural import Text.Fuzzy.Parallel (Scored (..)) @@ -64,8 +65,8 @@ ghcideCompletionsPluginPriority = defaultPluginPriority descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = produceCompletions recorder - , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP - <> mkPluginHandler SCompletionItemResolve resolveCompletion + , pluginHandlers = mkPluginHandler SMethod_TextDocumentCompletion getCompletionsLSP + <> mkPluginHandler SMethod_CompletionItemResolve resolveCompletion , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} , pluginPriority = ghcideCompletionsPluginPriority } @@ -119,8 +120,8 @@ dropListFromImportDecl iDecl = let in f <$> iDecl resolveCompletion :: IdeState -> PluginId -> CompletionItem -> LSP.LspM Config (Either ResponseError CompletionItem) -resolveCompletion ide _ comp@CompletionItem{_detail,_documentation,_xdata} - | Just resolveData <- _xdata +resolveCompletion ide _ comp@CompletionItem{_detail,_documentation,_data_} + | Just resolveData <- _data_ , Success (CompletionResolveData uri needType (NameDetails mod occ)) <- fromJSON resolveData , Just file <- uriToNormalizedFilePath $ toNormalizedUri uri = liftIO $ runIdeAction "Completion resolve" (shakeExtras ide) $ do @@ -137,7 +138,7 @@ resolveCompletion ide _ comp@CompletionItem{_detail,_documentation,_xdata} mdkm <- useWithStaleFast GetDocMap file let (dm,km) = case mdkm of Just (DKMap dm km, _) -> (dm,km) - Nothing -> (mempty, mempty) + Nothing -> (mempty, mempty) doc <- case lookupNameEnv dm name of Just doc -> pure $ spanDocToMarkdown doc Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name @@ -150,11 +151,11 @@ resolveCompletion ide _ comp@CompletionItem{_detail,_documentation,_xdata} Just ty -> Just (":: " <> printOutputable (stripForall ty) <> "\n") Nothing -> Nothing doc1 = case _documentation of - Just (CompletionDocMarkup (MarkupContent MkMarkdown old)) -> - CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator (old:doc) - _ -> CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator doc - pure (Right $ comp & J.detail .~ (det1 <> _detail) - & J.documentation .~ Just doc1 + Just (InR (MarkupContent MarkupKind_Markdown old)) -> + InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator (old:doc) + _ -> InR $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator doc + pure (Right $ comp & L.detail .~ (det1 <> _detail) + & L.documentation .~ Just doc1 ) where stripForall ty = case splitForAllTyCoVars ty of @@ -166,7 +167,7 @@ getCompletionsLSP :: IdeState -> PluginId -> CompletionParams - -> LSP.LspM Config (Either ResponseError (ResponseResult TextDocumentCompletion)) + -> LSP.LspM Config (Either ResponseError (MessageResult Method_TextDocumentCompletion)) getCompletionsLSP ide plId CompletionParams{_textDocument=TextDocumentIdentifier uri ,_position=position @@ -213,17 +214,16 @@ getCompletionsLSP ide plId let pfix = getCompletionPrefix position cnts case (pfix, completionContext) of ((PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) - -> return (InL $ List []) + -> return (InL []) (_, _) -> do let clientCaps = clientCapabilities $ shakeExtras ide plugins = idePlugins $ shakeExtras ide config <- liftIO $ runAction "" ide $ getCompletionsConfig plId allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri - pure $ InL (List $ orderedCompletions allCompletions) - _ -> return (InL $ List []) - _ -> return (InL $ List []) - _ -> return (InL $ List []) + pure $ InL (orderedCompletions allCompletions) + _ -> return (InL []) + _ -> return (InL []) getCompletionsConfig :: PluginId -> Action CompletionsConfig getCompletionsConfig pId = diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 677cd741d4..d370b5142a 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} - +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedLabels #-} -- Mostly taken from "haskell-ide-engine" module Development.IDE.Plugin.Completions.Logic ( @@ -14,15 +15,19 @@ module Development.IDE.Plugin.Completions.Logic ( ) where import Control.Applicative +import Control.Lens hiding (Context) import Data.Char (isAlphaNum, isUpper) +import Data.Default (def) import Data.Generics import Data.List.Extra as List hiding (stripPrefix) import qualified Data.Map as Map +import Data.Row import Data.Maybe (catMaybes, fromMaybe, - isJust, listToMaybe, - mapMaybe, isNothing) + isJust, isNothing, + listToMaybe, + mapMaybe) import qualified Data.Text as T import qualified Text.Fuzzy.Parallel as Fuzzy @@ -41,7 +46,7 @@ import Development.IDE.Core.PositionMapping import Development.IDE.GHC.Compat hiding (ppr) import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Compat.Util -import Development.IDE.GHC.CoreFile (occNamePrefixes) +import Development.IDE.GHC.CoreFile (occNamePrefixes) import Development.IDE.GHC.Error import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types @@ -64,8 +69,8 @@ import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), IdePlugins (..), PluginId) -import Language.LSP.Types -import Language.LSP.Types.Capabilities +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types import qualified Language.LSP.VFS as VFS import Text.Fuzzy.Parallel (Scored (score), original) @@ -76,7 +81,7 @@ import Development.IDE import Development.IDE.Spans.AtPoint (pointCommand) #if MIN_VERSION_ghc(9,5,0) -import Language.Haskell.Syntax.Basic +import Language.Haskell.Syntax.Basic #endif -- Chunk size used for parallelizing fuzzy matching @@ -172,11 +177,11 @@ getCContext pos pm occNameToComKind :: OccName -> CompletionItemKind occNameToComKind oc | isVarOcc oc = case occNameString oc of - i:_ | isUpper i -> CiConstructor - _ -> CiFunction - | isTcOcc oc = CiStruct - | isDataOcc oc = CiConstructor - | otherwise = CiVariable + i:_ | isUpper i -> CompletionItemKind_Constructor + _ -> CompletionItemKind_Function + | isTcOcc oc = CompletionItemKind_Struct + | isDataOcc oc = CompletionItemKind_Constructor + | otherwise = CompletionItemKind_Variable showModName :: ModuleName -> T.Text @@ -215,13 +220,15 @@ mkCompl _sortText = Nothing, _filterText = Nothing, _insertText = Just insertText, - _insertTextFormat = Just Snippet, + _insertTextFormat = Just InsertTextFormat_Snippet, _insertTextMode = Nothing, _textEdit = Nothing, _additionalTextEdits = Nothing, _commitCharacters = Nothing, _command = mbCommand, - _xdata = toJSON <$> fmap (CompletionResolveData uri (isNothing typeText)) nameDetails} + _data_ = toJSON <$> fmap (CompletionResolveData uri (isNothing typeText)) nameDetails, + _labelDetails = Nothing, + _textEditText = Nothing} removeSnippetsWhen (isJust isInfix) ci where kind = Just compKind @@ -230,8 +237,8 @@ mkCompl Local pos -> "*Defined at " <> pprLineCol (srcSpanStart pos) <> " in this module*\n" ImportedFrom mod -> "*Imported from '" <> mod <> "'*\n" DefinedIn mod -> "*Defined in '" <> mod <> "'*\n" - documentation = Just $ CompletionDocMarkup $ - MarkupContent MkMarkdown $ + documentation = Just $ InR $ + MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator docs' pprLineCol :: SrcLoc -> T.Text pprLineCol (UnhelpfulLoc fs) = T.pack $ unpackFS fs @@ -253,8 +260,8 @@ mkNameCompItem doc thingParent origName provenance isInfix !imp mod = CI {..} typeText = Nothing label = stripPrefix $ printOutputable origName insertText = case isInfix of - Nothing -> label - Just LeftSide -> label <> "`" + Nothing -> label + Just LeftSide -> label <> "`" Just Surrounded -> label additionalTextEdits = @@ -278,30 +285,32 @@ showForSnippet x = printOutputable x mkModCompl :: T.Text -> CompletionItem mkModCompl label = - CompletionItem label (Just CiModule) Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing + (defaultCompletionItemWithLabel label) + { _kind = Just CompletionItemKind_Module } mkModuleFunctionImport :: T.Text -> T.Text -> CompletionItem mkModuleFunctionImport moduleName label = - CompletionItem label (Just CiFunction) Nothing (Just moduleName) - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing + (defaultCompletionItemWithLabel label) + { _kind = Just CompletionItemKind_Function + , _detail = Just moduleName } mkImportCompl :: T.Text -> T.Text -> CompletionItem mkImportCompl enteredQual label = - CompletionItem m (Just CiModule) Nothing (Just label) - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing + (defaultCompletionItemWithLabel m) + { _kind = Just CompletionItemKind_Module + , _detail = Just label } where m = fromMaybe "" (T.stripPrefix enteredQual label) mkExtCompl :: T.Text -> CompletionItem mkExtCompl label = - CompletionItem label (Just CiKeyword) Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing + (defaultCompletionItemWithLabel label) + { _kind = Just CompletionItemKind_Keyword } +defaultCompletionItemWithLabel :: T.Text -> CompletionItem +defaultCompletionItemWithLabel label = + CompletionItem label def def def def def def def def def + def def def def def def def def def fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem fromIdentInfo doc id@IdentInfo{..} q = CI @@ -439,20 +448,20 @@ localCompletionsForParsedModule uri pm@ParsedModule{pm_parsed_source = L _ HsMod compls = concat [ case decl of SigD _ (TypeSig _ ids typ) -> - [mkComp id CiFunction (Just $ showForSnippet typ) | id <- ids] + [mkComp id CompletionItemKind_Function (Just $ showForSnippet typ) | id <- ids] ValD _ FunBind{fun_id} -> - [ mkComp fun_id CiFunction Nothing + [ mkComp fun_id CompletionItemKind_Function Nothing | not (hasTypeSig fun_id) ] ValD _ PatBind{pat_lhs} -> - [mkComp id CiVariable Nothing + [mkComp id CompletionItemKind_Variable Nothing | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] TyClD _ ClassDecl{tcdLName, tcdSigs, tcdATs} -> - mkComp tcdLName CiInterface (Just $ showForSnippet tcdLName) : - [ mkComp id CiFunction (Just $ showForSnippet typ) + mkComp tcdLName CompletionItemKind_Interface (Just $ showForSnippet tcdLName) : + [ mkComp id CompletionItemKind_Function (Just $ showForSnippet typ) | L _ (ClassOpSig _ _ ids typ) <- tcdSigs , id <- ids] ++ - [ mkComp fdLName CiStruct (Just $ showForSnippet fdLName) + [ mkComp fdLName CompletionItemKind_Struct (Just $ showForSnippet fdLName) | L _ (FamilyDecl{fdLName}) <- tcdATs] TyClD _ x -> let generalCompls = [mkComp id cl (Just $ showForSnippet $ tyClDeclLName x) @@ -464,16 +473,16 @@ localCompletionsForParsedModule uri pm@ParsedModule{pm_parsed_source = L _ HsMod -- the constructors and snippets will be duplicated here giving the user 2 choices. generalCompls ++ recordCompls ForD _ ForeignImport{fd_name,fd_sig_ty} -> - [mkComp fd_name CiVariable (Just $ showForSnippet fd_sig_ty)] + [mkComp fd_name CompletionItemKind_Variable (Just $ showForSnippet fd_sig_ty)] ForD _ ForeignExport{fd_name,fd_sig_ty} -> - [mkComp fd_name CiVariable (Just $ showForSnippet fd_sig_ty)] + [mkComp fd_name CompletionItemKind_Variable (Just $ showForSnippet fd_sig_ty)] _ -> [] | L (locA -> pos) decl <- hsmodDecls, let mkComp = mkLocalComp pos ] mkLocalComp pos n ctyp ty = - CI ctyp pn (Local pos) pn ty Nothing (ctyp `elem` [CiStruct, CiInterface]) Nothing (Just $ NameDetails (ms_mod $ pm_mod_summary pm) occ) True + CI ctyp pn (Local pos) pn ty Nothing (ctyp `elem` [CompletionItemKind_Struct, CompletionItemKind_Interface]) Nothing (Just $ NameDetails (ms_mod $ pm_mod_summary pm) occ) True where occ = rdrNameOcc $ unLoc n pn = showForSnippet n @@ -520,7 +529,7 @@ toggleSnippets ClientCapabilities {_textDocument} CompletionsConfig{..} = removeSnippetsWhen (not $ enableSnippets && supported) where supported = - Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport) + Just True == (_textDocument >>= _completion >>= view L.completionItem >>= (\x -> x .! #snippetSupport)) toggleAutoExtend :: CompletionsConfig -> CompItem -> CompItem toggleAutoExtend CompletionsConfig{enableAutoExtend=False} x = x {additionalTextEdits = Nothing} @@ -531,7 +540,7 @@ removeSnippetsWhen condition x = if condition then x - { _insertTextFormat = Just PlainText, + { _insertTextFormat = Just InsertTextFormat_PlainText, _insertText = Nothing } else x @@ -613,7 +622,7 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, -- to get the record's module, which isn't included in the type information used to get the fields. dotFieldSelectorToCompl :: T.Text -> T.Text -> (Bool, CompItem) dotFieldSelectorToCompl recname label = (True, CI - { compKind = CiField + { compKind = CompletionItemKind_Field , insertText = label , provenance = DefinedIn recname , label = label @@ -790,7 +799,7 @@ mkRecordSnippetCompItem :: Uri -> Maybe T.Text -> T.Text -> [T.Text] -> Provenan mkRecordSnippetCompItem uri parent ctxStr compl importedFrom imp = r where r = CI { - compKind = CiSnippet + compKind = CompletionItemKind_Snippet , insertText = buildSnippet , provenance = importedFrom , typeText = Nothing diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs index 393844228b..9151e03955 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} module Development.IDE.Plugin.Completions.Types ( module Development.IDE.Plugin.Completions.Types ) where @@ -22,12 +22,12 @@ import Development.IDE.Graph (RuleResult) import Development.IDE.Spans.Common import GHC.Generics (Generic) import Ide.Plugin.Properties -import Language.LSP.Types (CompletionItemKind (..), Uri) -import qualified Language.LSP.Types as J +import Language.LSP.Protocol.Types (CompletionItemKind (..), Uri) +import qualified Language.LSP.Protocol.Types as J #if MIN_VERSION_ghc(9,0,0) -import qualified GHC.Types.Name.Occurrence as Occ +import qualified GHC.Types.Name.Occurrence as Occ #else -import qualified OccName as Occ +import qualified OccName as Occ #endif -- | Produce completions info for a file @@ -178,7 +178,7 @@ parseNs (String "v") = pure Occ.varName parseNs (String "c") = pure dataName parseNs (String "t") = pure tcClsName parseNs (String "z") = pure tvName -parseNs _ = mempty +parseNs _ = mempty instance FromJSON NameDetails where parseJSON v@(Array _) @@ -204,9 +204,9 @@ instance Show NameDetails where -- We need the URI to be able to reconstruct the GHC environment -- in the file the completion was triggered in. data CompletionResolveData = CompletionResolveData - { itemFile :: Uri + { itemFile :: Uri , itemNeedsType :: Bool -- ^ Do we need to lookup a type for this item? - , itemName :: NameDetails + , itemName :: NameDetails } deriving stock Generic deriving anyclass (FromJSON, ToJSON) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 27e64c77aa..c134a26045 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -9,43 +9,43 @@ module Development.IDE.Plugin.HLS , Log(..) ) where -import Control.Exception (SomeException) -import Control.Lens ((^.)) +import Control.Exception (SomeException) +import Control.Lens ((^.)) import Control.Monad -import qualified Data.Aeson as J -import Data.Bifunctor (first) -import Data.Dependent.Map (DMap) -import qualified Data.Dependent.Map as DMap +import qualified Data.Aeson as A +import Data.Bifunctor (first) +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum import Data.Either -import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map import Data.Some import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import Development.IDE.Core.Shake hiding (Log) +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing -import Development.IDE.Graph (Rules) +import Development.IDE.Graph (Rules) import Development.IDE.LSP.Server import Development.IDE.Plugin -import qualified Development.IDE.Plugin as P -import Development.IDE.Types.Logger +import qualified Development.IDE.Plugin as P +import Development.IDE.Types.Logger hiding (Error) import Ide.Plugin.Config -import Ide.PluginUtils (getClientConfig) -import Ide.Types as HLS -import qualified Language.LSP.Server as LSP -import Language.LSP.Types -import qualified Language.LSP.Types as J -import qualified Language.LSP.Types.Lens as LSP +import Ide.PluginUtils (getClientConfig) +import Ide.Types as HLS +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Server as LSP import Language.LSP.VFS -import Prettyprinter.Render.String (renderString) -import Text.Regex.TDFA.Text () -import UnliftIO (MonadUnliftIO) -import UnliftIO.Async (forConcurrently) -import UnliftIO.Exception (catchAny) +import Prettyprinter.Render.String (renderString) +import Text.Regex.TDFA.Text () +import UnliftIO (MonadUnliftIO) +import UnliftIO.Async (forConcurrently) +import UnliftIO.Exception (catchAny) -- --------------------------------------------------------------------- -- @@ -67,8 +67,8 @@ instance Show Log where show = renderString . layoutCompact . pretty prettyResponseError :: ResponseError -> Doc a prettyResponseError err = errorCode <> ":" <+> errorBody where - errorCode = pretty $ show $ err ^. LSP.code - errorBody = pretty $ err ^. LSP.message + errorCode = pretty $ show $ err ^. L.code + errorBody = pretty $ err ^. L.message pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text pluginNotEnabled method availPlugins = @@ -86,14 +86,14 @@ commandDoesntExist (CommandId com) (PluginId pid) legalCmds = failedToParseArgs :: CommandId -- ^ command that failed to parse -> PluginId -- ^ Plugin that created the command -> String -- ^ The JSON Error message - -> J.Value -- ^ The Argument Values + -> A.Value -- ^ The Argument Values -> Text failedToParseArgs (CommandId com) (PluginId pid) err arg = "Error while parsing args for " <> com <> " in plugin " <> pid <> ": " <> T.pack err <> ", arg = " <> T.pack (show arg) -- | Build a ResponseError and log it before returning to the caller -logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> ErrorCode -> Text -> LSP.LspT Config IO (Either ResponseError a) +logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> (LSPErrorCodes |? ErrorCodes) -> Text -> LSP.LspT Config IO (Either ResponseError a) logAndReturnError recorder p errCode msg = do let err = ResponseError errCode msg Nothing logWith recorder Warning $ LogPluginError p err @@ -146,7 +146,7 @@ executeCommandPlugins :: Recorder (WithPriority Log) -> [(PluginId, [PluginComma executeCommandPlugins recorder ecs = mempty { P.pluginHandlers = executeCommandHandlers recorder ecs } executeCommandHandlers :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config) -executeCommandHandlers recorder ecs = requestHandler SWorkspaceExecuteCommand execCmd +executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCommand execCmd where pluginMap = Map.fromListWith (++) ecs @@ -157,29 +157,29 @@ executeCommandHandlers recorder ecs = requestHandler SWorkspaceExecuteCommand ex _ -> Nothing -- The parameters to the HLS command are always the first element - + execCmd :: IdeState -> ExecuteCommandParams -> LSP.LspT Config IO (Either ResponseError (A.Value |? Null)) execCmd ide (ExecuteCommandParams _ cmdId args) = do - let cmdParams :: J.Value + let cmdParams :: A.Value cmdParams = case args of - Just (J.List (x:_)) -> x - _ -> J.Null + Just ((x:_)) -> x + _ -> A.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 + case A.fromJSON cmdParams of + A.Success (FallbackCodeActionParams mEdit mCmd) -> do -- Send off the workspace request if it has one forM_ mEdit $ \edit -> - LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) case mCmd of -- If we have a command, continue to execute it - Just (J.Command _ innerCmdId innerArgs) + Just (Command _ innerCmdId innerArgs) -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs) - Nothing -> return $ Right J.Null + Nothing -> return $ Right $ InL A.Null - J.Error _str -> return $ Right J.Null + A.Error _str -> return $ Right $ InL A.Null -- Just an ordinary HIE command Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams @@ -187,16 +187,17 @@ executeCommandHandlers recorder ecs = requestHandler SWorkspaceExecuteCommand ex -- Couldn't parse the command identifier _ -> do logWith recorder Warning LogInvalidCommandIdentifier - return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing + return $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Invalid command identifier" Nothing + runPluginCommand :: IdeState -> PluginId -> CommandId -> A.Value -> LSP.LspT Config IO (Either ResponseError (A.Value |? Null)) runPluginCommand ide p com arg = case Map.lookup p pluginMap of - Nothing -> logAndReturnError recorder p InvalidRequest (pluginDoesntExist p) + Nothing -> logAndReturnError recorder p (InR ErrorCodes_InvalidRequest) (pluginDoesntExist p) Just xs -> case List.find ((com ==) . commandId) xs of - Nothing -> logAndReturnError recorder p InvalidRequest (commandDoesntExist com p xs) - Just (PluginCommand _ _ f) -> case J.fromJSON arg of - J.Error err -> logAndReturnError recorder p InvalidParams (failedToParseArgs com p err arg) - J.Success a -> f ide a + Nothing -> logAndReturnError recorder p (InR ErrorCodes_InvalidRequest) (commandDoesntExist com p xs) + Just (PluginCommand _ _ f) -> case A.fromJSON arg of + A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg) + A.Success a -> fmap InL <$> f ide a -- --------------------------------------------------------------------- @@ -220,7 +221,7 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } case nonEmpty fs of Nothing -> do logWith recorder Warning (LogNoPluginForMethod $ Some m) - let err = ResponseError InvalidRequest msg Nothing + let err = ResponseError (InR ErrorCodes_InvalidRequest) msg Nothing msg = pluginNotEnabled m fs' return $ Left err Just fs -> do @@ -275,20 +276,20 @@ runConcurrently -> m (NonEmpty(NonEmpty (Either ResponseError d))) runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do f a b - `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing) + `catchAny` (\e -> pure $ pure $ Left $ ResponseError (InR ErrorCodes_InternalError) (msg e pid) Nothing) combineErrors :: [ResponseError] -> ResponseError combineErrors [x] = x -combineErrors xs = ResponseError InternalError (T.pack (show xs)) Nothing +combineErrors xs = ResponseError (InR ErrorCodes_InternalError) (T.pack (show xs)) Nothing -- | Combine the 'PluginHandler' for all plugins -newtype IdeHandler (m :: J.Method FromClient Request) - = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (ResponseResult m))))] +newtype IdeHandler (m :: Method ClientToServer Request) + = IdeHandler [(PluginId, PluginDescriptor IdeState, IdeState -> MessageParams m -> LSP.LspM Config (NonEmpty (Either ResponseError (MessageResult m))))] -- | Combine the 'PluginHandler' for all plugins -newtype IdeNotificationHandler (m :: J.Method FromClient Notification) +newtype IdeNotificationHandler (m :: Method ClientToServer Notification) = IdeNotificationHandler [(PluginId, PluginDescriptor IdeState, IdeState -> VFS -> MessageParams m -> LSP.LspM Config ())] --- type NotificationHandler (m :: Method FromClient Notification) = MessageParams m -> IO ()` +-- type NotificationHandler (m :: Method ClientToServer Notification) = MessageParams m -> IO ()` -- | Combine the 'PluginHandlers' for all plugins newtype IdeHandlers = IdeHandlers (DMap IdeMethod IdeHandler) diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index c58453105f..d419710d51 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -15,8 +15,9 @@ import Development.IDE.LSP.Outline import qualified Development.IDE.Plugin.Completions as Completions import qualified Development.IDE.Plugin.TypeLenses as TypeLenses import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import Language.LSP.Server (LspM) -import Language.LSP.Types import Text.Regex.TDFA.Text () data Log @@ -43,29 +44,29 @@ descriptors recorder = descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentHover hover' - <> mkPluginHandler STextDocumentDocumentSymbol symbolsProvider - <> mkPluginHandler STextDocumentDefinition (\ide _ DefinitionParams{..} -> + { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hover' + <> mkPluginHandler SMethod_TextDocumentDocumentSymbol symbolsProvider + <> mkPluginHandler SMethod_TextDocumentDefinition (\ide _ DefinitionParams{..} -> gotoDefinition ide TextDocumentPositionParams{..}) - <> mkPluginHandler STextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> + <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> gotoTypeDefinition ide TextDocumentPositionParams{..}) - <> mkPluginHandler STextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> + <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> documentHighlight ide TextDocumentPositionParams{..}) - <> mkPluginHandler STextDocumentReferences (\ide _ params -> references ide params) - <> mkPluginHandler SWorkspaceSymbol (\ide _ params -> wsSymbols ide params), + <> mkPluginHandler SMethod_TextDocumentReferences (\ide _ params -> references ide params) + <> mkPluginHandler SMethod_WorkspaceSymbol (\ide _ params -> fmap InL <$> wsSymbols ide params), pluginConfigDescriptor = defaultConfigDescriptor } -- --------------------------------------------------------------------- -hover' :: IdeState -> PluginId -> HoverParams -> LspM c (Either ResponseError (Maybe Hover)) +hover' :: IdeState -> PluginId -> HoverParams -> LspM c (Either ResponseError (Hover |? Null)) hover' ideState _ HoverParams{..} = do liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ hover ideState TextDocumentPositionParams{..} -- --------------------------------------------------------------------- -symbolsProvider :: IdeState -> PluginId -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) +symbolsProvider :: IdeState -> PluginId -> DocumentSymbolParams -> LspM c (Either ResponseError ([SymbolInformation] |? ([DocumentSymbol] |? Null))) symbolsProvider ide _ params = moduleOutline ide params -- --------------------------------------------------------------------- diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index c6163ab105..8d403ce8ab 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -22,6 +22,7 @@ import Data.Bifunctor import Data.CaseInsensitive (CI, original) import qualified Data.HashMap.Strict as HM import Data.Maybe (isJust) +import Data.Proxy import Data.String import Data.Text (Text, pack) import Development.IDE.Core.OfInterest (getFilesOfInterest) @@ -44,8 +45,9 @@ import Development.IDE.Types.Location (fromUri) import GHC.Generics (Generic) import Ide.Plugin.Config (CheckParents) import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (Null) import qualified Language.LSP.Server as LSP -import Language.LSP.Types import qualified "list-t" ListT import qualified StmContainers.Map as STM import System.Time.Extra @@ -73,7 +75,7 @@ newtype WaitForIdeRuleResult = WaitForIdeRuleResult { ideResultSuccess::Bool} plugin :: PluginDescriptor IdeState plugin = (defaultPluginDescriptor "test") { - pluginHandlers = mkPluginHandler (SCustomMethod "test") $ \st _ -> + pluginHandlers = mkPluginHandler (SMethod_CustomMethod (Proxy @"test")) $ \st _ -> testRequestHandler' st } where @@ -82,14 +84,14 @@ plugin = (defaultPluginDescriptor "test") { = testRequestHandler ide customReq | otherwise = return $ Left - $ ResponseError InvalidRequest "Cannot parse request" Nothing + $ ResponseError (InR ErrorCodes_InvalidRequest) "Cannot parse request" Nothing testRequestHandler :: IdeState -> TestRequest -> LSP.LspM c (Either ResponseError Value) testRequestHandler _ (BlockSeconds secs) = do - LSP.sendNotification (SCustomMethod "ghcide/blocking/request") $ + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/request")) $ toJSON secs liftIO $ sleep secs return (Right Null) @@ -145,7 +147,7 @@ getDatabaseKeys field db = do return [ k | (k, res) <- keys, field res == Step step] mkResponseError :: Text -> ResponseError -mkResponseError msg = ResponseError InvalidRequest msg Nothing +mkResponseError msg = ResponseError (InR ErrorCodes_InvalidRequest) msg Nothing parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool) parseAction "typecheck" fp = Right . isJust <$> use TypeCheck fp @@ -170,6 +172,6 @@ blockCommandDescriptor plId = (defaultPluginDescriptor plId) { blockCommandHandler :: CommandFunction state ExecuteCommandParams blockCommandHandler _ideState _params = do - LSP.sendNotification (SCustomMethod "ghcide/blocking/command") Null + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) Null liftIO $ threadDelay maxBound return (Right Null) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 806dca3969..791d29c5c5 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -20,8 +20,8 @@ import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson.Types (Value (..), toJSON) import qualified Data.Aeson.Types as A -import qualified Data.HashMap.Strict as Map import Data.List (find) +import qualified Data.Map as Map import Data.Maybe (catMaybes, mapMaybe) import qualified Data.Text as T import Development.IDE (GhcSession (..), @@ -63,17 +63,17 @@ import Ide.Types (CommandFunction, defaultPluginDescriptor, mkCustomConfig, mkPluginHandler) -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), +import Language.LSP.Protocol.Message (Method (Method_TextDocumentCodeLens), + SMethod (..)) +import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), CodeLens (CodeLens), CodeLensParams (CodeLensParams, _textDocument), Diagnostic (..), - List (..), - Method (TextDocumentCodeLens), - SMethod (..), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), - WorkspaceEdit (WorkspaceEdit)) + WorkspaceEdit (WorkspaceEdit), + type (|?) (InL)) +import qualified Language.LSP.Server as LSP import Text.Regex.TDFA ((=~), (=~~)) data Log = LogShake Shake.Log deriving Show @@ -88,7 +88,7 @@ typeLensCommandId = "typesignature.add" descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens codeLensProvider , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] , pluginRules = rules recorder , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} @@ -102,7 +102,7 @@ properties = emptyProperties , (Diagnostics, "Follows error messages produced by GHC about missing signatures") ] Always -codeLensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens +codeLensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = pluginResponse $ do mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties nfp <- getNormalizedFilePath uri @@ -129,7 +129,7 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif diag <- liftIO $ atomically $ getDiagnostics ideState hDiag <- liftIO $ atomically $ getHiddenDiagnostics ideState - let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing + let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ tedit) Nothing Nothing generateLensForGlobal mp sig@GlobalBindingTypeSig{gbRendered} = do range <- toCurrentRange mp =<< srcSpanToRange (gbSrcSpan sig) tedit <- gblBindingTypeSigToEdit sig (Just gblSigsMp) @@ -144,7 +144,7 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif ] -- `suggestLocalSignature` relies on diagnostic, if diagnostics don't have the local signature warning, -- the `bindings` is useless, and if diagnostic has, that means we parsed success, and the `bindings` is fresh. - pure $ List $ case mode of + pure $ InL $ case mode of Always -> mapMaybe (generateLensForGlobal gblSigsMp) gblSigs' <> generateLensFromDiags @@ -160,7 +160,7 @@ generateLens pId _range title edit = commandHandler :: CommandFunction IdeState WorkspaceEdit commandHandler _ideState wedit = do - _ <- LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + _ <- LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) return $ Right Null -------------------------------------------------------------------------------- diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index fafb18af0e..37b0fbcc17 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -27,7 +27,8 @@ module Development.IDE.Spans.AtPoint ( import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans () import Development.IDE.Types.Location -import Language.LSP.Types +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..)) -- compiler and infrastructure import Development.IDE.Core.PositionMapping @@ -178,8 +179,8 @@ documentHighlight hf rf pos = pure highlights DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets) highlightType s = if any (isJust . getScopeFromContext) s - then HkWrite - else HkRead + then DocumentHighlightKind_Write + else DocumentHighlightKind_Read gotoTypeDefinition :: MonadIO m @@ -391,13 +392,15 @@ toUri = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' defRowToSymbolInfo :: Res DefRow -> Maybe SymbolInformation defRowToSymbolInfo (DefRow{..}:.(modInfoSrcFile -> Just srcFile)) - = Just $ SymbolInformation (printOutputable defNameOcc) kind Nothing Nothing loc Nothing + = Just $ SymbolInformation (printOutputable defNameOcc) kind Nothing Nothing Nothing loc where kind - | isVarOcc defNameOcc = SkVariable - | isDataOcc defNameOcc = SkConstructor - | isTcOcc defNameOcc = SkStruct - | otherwise = SkUnknown 1 + | isVarOcc defNameOcc = SymbolKind_Variable + | isDataOcc defNameOcc = SymbolKind_Constructor + | isTcOcc defNameOcc = SymbolKind_Struct + -- This used to be (SkUnknown 1), buth there is no SymbolKind_Unknown. + -- Changing this to File, as that is enum representation of 1 + | otherwise = SymbolKind_File loc = Location file range file = fromNormalizedUri . filePathToUri' . toNormalizedFilePath' $ srcFile range = Range start end @@ -424,6 +427,7 @@ pointCommand hf pos k = where sloc fs = mkRealSrcLoc fs (fromIntegral $ line+1) (fromIntegral $ cha+1) sp fs = mkRealSrcSpan (sloc fs) (sloc fs) + line :: UInt line = _line pos cha = _character pos diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index e3590c5372..0c7200c89b 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -32,7 +32,7 @@ import Development.IDE.Spans.Common import System.Directory import System.FilePath -import Language.LSP.Types (filePathToUri, getUri) +import Language.LSP.Protocol.Types (filePathToUri, getUri) #if MIN_VERSION_ghc(9,3,0) import GHC.Types.Unique.Map #endif diff --git a/ghcide/src/Development/IDE/Spans/Pragmas.hs b/ghcide/src/Development/IDE/Spans/Pragmas.hs index 6e00769922..7d9ede69e3 100644 --- a/ghcide/src/Development/IDE/Spans/Pragmas.hs +++ b/ghcide/src/Development/IDE/Spans/Pragmas.hs @@ -18,7 +18,7 @@ import qualified Data.Text as Text import Development.IDE (srcSpanToRange, IdeState, NormalizedFilePath, runAction, useWithStale, GhcSession (..), getFileContents, hscEnv) import Development.IDE.GHC.Compat import Development.IDE.GHC.Compat.Util -import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Protocol.Types as LSP import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Except (ExceptT) import Ide.Types (PluginId(..)) diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs index c8de1e8e10..8189ff89c1 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -9,7 +9,6 @@ module Development.IDE.Types.Diagnostics ( IdeResult, LSP.DiagnosticSeverity(..), DiagnosticStore, - List(..), ideErrorText, ideErrorWithSource, showDiagnostics, @@ -17,21 +16,18 @@ module Development.IDE.Types.Diagnostics ( IdeResultNoDiagnosticsEarlyCutoff) where import Control.DeepSeq +import Data.ByteString (ByteString) import Data.Maybe as Maybe import qualified Data.Text as T +import Development.IDE.Types.Location import Language.LSP.Diagnostics -import Language.LSP.Types as LSP (Diagnostic (..), - DiagnosticSeverity (..), - DiagnosticSource, - List (..)) +import Language.LSP.Protocol.Types as LSP (Diagnostic (..), + DiagnosticSeverity (..)) import Prettyprinter import Prettyprinter.Render.Terminal (Color (..), color) import qualified Prettyprinter.Render.Terminal as Terminal import Prettyprinter.Render.Text -import Data.ByteString (ByteString) -import Development.IDE.Types.Location - -- | The result of an IDE operation. Warnings and errors are in the Diagnostic, -- and a value is in the Maybe. For operations that throw an error you @@ -49,10 +45,10 @@ type IdeResult v = ([FileDiagnostic], Maybe v) type IdeResultNoDiagnosticsEarlyCutoff v = (Maybe ByteString, Maybe v) ideErrorText :: NormalizedFilePath -> T.Text -> FileDiagnostic -ideErrorText = ideErrorWithSource (Just "compiler") (Just DsError) +ideErrorText = ideErrorWithSource (Just "compiler") (Just DiagnosticSeverity_Error) ideErrorWithSource - :: Maybe DiagnosticSource + :: Maybe T.Text -> Maybe DiagnosticSeverity -> a -> T.Text @@ -64,7 +60,9 @@ ideErrorWithSource source sev fp msg = (fp, ShowDiag, LSP.Diagnostic { _source = source, _message = msg, _relatedInformation = Nothing, - _tags = Nothing + _tags = Nothing, + _codeDescription = Nothing, + _data_ = Nothing }) -- | Defines whether a particular diagnostic should be reported @@ -117,14 +115,14 @@ prettyDiagnostic (fp, sh, LSP.Diagnostic{..}) = , slabel_ "Severity:" $ pretty $ show sev , slabel_ "Message: " $ case sev of - LSP.DsError -> annotate $ color Red - LSP.DsWarning -> annotate $ color Yellow - LSP.DsInfo -> annotate $ color Blue - LSP.DsHint -> annotate $ color Magenta + LSP.DiagnosticSeverity_Error -> annotate $ color Red + LSP.DiagnosticSeverity_Warning -> annotate $ color Yellow + LSP.DiagnosticSeverity_Information -> annotate $ color Blue + LSP.DiagnosticSeverity_Hint -> annotate $ color Magenta $ stringParagraphs _message ] where - sev = fromMaybe LSP.DsError _severity + sev = fromMaybe LSP.DiagnosticSeverity_Error _severity -- | Label a document. diff --git a/ghcide/src/Development/IDE/Types/Location.hs b/ghcide/src/Development/IDE/Types/Location.hs index 9891606947..6878c6f0f8 100644 --- a/ghcide/src/Development/IDE/Types/Location.hs +++ b/ghcide/src/Development/IDE/Types/Location.hs @@ -39,9 +39,9 @@ import GHC.Types.SrcLoc as GHC import FastString import SrcLoc as GHC #endif -import Language.LSP.Types (Location (..), Position (..), +import Language.LSP.Protocol.Types (Location (..), Position (..), Range (..)) -import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Protocol.Types as LSP import Text.ParserCombinators.ReadP as ReadP toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index 5b62dccfe8..5869237fbe 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -29,43 +29,44 @@ module Development.IDE.Types.Logger , toCologActionWithPrio ) where -import Colog.Core (LogAction (..), Severity, - WithSeverity (..)) -import qualified Colog.Core as Colog -import Control.Concurrent (myThreadId) -import Control.Concurrent.Extra (Lock, newLock, withLock) -import Control.Concurrent.STM (atomically, flushTBQueue, - isFullTBQueue, newTBQueueIO, - newTVarIO, readTVarIO, - writeTBQueue, writeTVar) -import Control.Exception (IOException) -import Control.Monad (unless, when, (>=>)) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Foldable (for_) -import Data.Functor.Contravariant (Contravariant (contramap)) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Data.Time (defaultTimeLocale, formatTime, - getCurrentTime) -import GHC.Stack (CallStack, HasCallStack, - SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine), - callStack, getCallStack, - withFrozenCallStack) +import Colog.Core (LogAction (..), Severity, + WithSeverity (..)) +import qualified Colog.Core as Colog +import Control.Concurrent (myThreadId) +import Control.Concurrent.Extra (Lock, newLock, withLock) +import Control.Concurrent.STM (atomically, flushTBQueue, + isFullTBQueue, newTBQueueIO, + newTVarIO, readTVarIO, + writeTBQueue, writeTVar) +import Control.Exception (IOException) +import Control.Monad (unless, when, (>=>)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Foldable (for_) +import Data.Functor.Contravariant (Contravariant (contramap)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Time (defaultTimeLocale, formatTime, + getCurrentTime) +import GHC.Stack (CallStack, HasCallStack, + SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine), + callStack, getCallStack, + withFrozenCallStack) +import Language.LSP.Protocol.Message (SMethod (SMethod_WindowLogMessage, SMethod_WindowShowMessage)) +import Language.LSP.Protocol.Types (LogMessageParams (..), + MessageType (..), + ShowMessageParams (..)) import Language.LSP.Server -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (LogMessageParams (..), - MessageType (..), - SMethod (SWindowLogMessage, SWindowShowMessage), - ShowMessageParams (..)) -import Prettyprinter as PrettyPrinterModule -import Prettyprinter.Render.Text (renderStrict) -import System.IO (Handle, IOMode (AppendMode), - hClose, hFlush, openFile, stderr) -import UnliftIO (MonadUnliftIO, displayException, - finally, try) +import qualified Language.LSP.Server as LSP +import Prettyprinter as PrettyPrinterModule +import Prettyprinter.Render.Text (renderStrict) +import System.IO (Handle, IOMode (AppendMode), + hClose, hFlush, openFile, + stderr) +import UnliftIO (MonadUnliftIO, displayException, + finally, try) data Priority -- Don't change the ordering of this type or you will mess up the Ord @@ -287,28 +288,28 @@ withBacklog recFun = do -- | Creates a recorder that sends logs to the LSP client via @window/showMessage@ notifications. lspClientMessageRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text) lspClientMessageRecorder env = Recorder $ \WithPriority {..} -> - liftIO $ LSP.runLspT env $ LSP.sendNotification SWindowShowMessage + liftIO $ LSP.runLspT env $ LSP.sendNotification SMethod_WindowShowMessage ShowMessageParams - { _xtype = priorityToLsp priority, + { _type_ = priorityToLsp priority, _message = payload } -- | Creates a recorder that sends logs to the LSP client via @window/logMessage@ notifications. lspClientLogRecorder :: LanguageContextEnv config -> Recorder (WithPriority Text) lspClientLogRecorder env = Recorder $ \WithPriority {..} -> - liftIO $ LSP.runLspT env $ LSP.sendNotification SWindowLogMessage + liftIO $ LSP.runLspT env $ LSP.sendNotification SMethod_WindowLogMessage LogMessageParams - { _xtype = priorityToLsp priority, + { _type_ = priorityToLsp priority, _message = payload } priorityToLsp :: Priority -> MessageType priorityToLsp = \case - Debug -> MtLog - Info -> MtInfo - Warning -> MtWarning - Error -> MtError + Debug -> MessageType_Log + Info -> MessageType_Info + Warning -> MessageType_Warning + Error -> MessageType_Error toCologActionWithPrio :: (MonadIO m, HasCallStack) => Recorder (WithPriority msg) -> LogAction m (WithSeverity msg) toCologActionWithPrio (Recorder _logger) = LogAction $ \WithSeverity{..} -> do diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 5b59bf0d3b..17bf035439 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -2,7 +2,8 @@ -- SPDX-License-Identifier: Apache-2.0 -- | Options -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE RankNTypes #-} module Development.IDE.Types.Options ( IdeOptions(..) , IdePreprocessedSource(..) @@ -18,7 +19,7 @@ module Development.IDE.Types.Options , OptHaddockParse(..) , ProgressReportingStyle(..) ) where - +import Control.Lens import qualified Data.Text as T import Data.Typeable import Development.IDE.Core.RuleTypes @@ -27,8 +28,8 @@ import Development.IDE.Graph import Development.IDE.Types.Diagnostics import Ide.Plugin.Config import Ide.Types (DynFlagsModifications) -import qualified Language.LSP.Types.Capabilities as LSP - +import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Types as LSP data IdeOptions = IdeOptions { optPreprocessor :: GHC.ParsedSource -> IdePreprocessedSource -- ^ Preprocessor to run over all parsed source trees, generating a list of warnings @@ -110,7 +111,7 @@ data ProgressReportingStyle clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress clientSupportsProgress caps = IdeReportProgress $ Just True == - (LSP._workDoneProgress =<< LSP._window (caps :: LSP.ClientCapabilities)) + ((\x -> x ^. L.workDoneProgress) =<< LSP._window (caps :: LSP.ClientCapabilities)) defaultIdeOptions :: Action IdeGhcSession -> IdeOptions defaultIdeOptions session = IdeOptions diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index c690c0b9bd..1b825e9d0d 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -36,15 +36,18 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedLabels #-} {-# OPTIONS_GHC -Wno-deprecations -Wno-unticked-promoted-constructors #-} module Main (main) where +import Data.Row import Control.Applicative.Combinators import Control.Concurrent import Control.Exception (bracket_, catch, finally) import qualified Control.Lens as Lens +import qualified Control.Lens.Extras as Lens import Control.Monad import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Aeson (toJSON) @@ -52,6 +55,7 @@ import qualified Data.Aeson as A import Data.Default import Data.Foldable import Data.List.Extra +import Data.Proxy import Data.Maybe import qualified Data.Set as Set import qualified Data.Text as T @@ -90,16 +94,12 @@ import Development.IDE.Types.Location import Development.Shake (getDirectoryFilesIO) import Ide.Plugin.Config import Language.LSP.Test -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start), - mkRange) -import Language.LSP.Types.Capabilities -import qualified Language.LSP.Types.Lens as Lens (label) -import qualified Language.LSP.Types.Lens as Lsp (diagnostics, - message, - params) +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message import Language.LSP.VFS (VfsLog, applyChange) import Network.URI import System.Directory @@ -142,13 +142,10 @@ import Development.IDE.Types.Logger (Logger (Logger), toCologActionWithPrio) import qualified FuzzySearch import GHC.Stack (emptyCallStack) +import GHC.TypeLits (symbolVal) import qualified HieDbRetry import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types -import qualified Language.LSP.Types as LSP -import Language.LSP.Types.Lens (didChangeWatchedFiles, - workspace) -import qualified Language.LSP.Types.Lens as L import qualified Progress import System.Time.Extra import qualified Test.QuickCheck.Monadic as MonadicQuickCheck @@ -175,14 +172,14 @@ instance Pretty Log where -- | Wait for the next progress begin step waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (Begin _))) -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressBegin v-> Just () _ -> Nothing -- | Wait for the first progress end step -- Also implemented in hls-test-utils Test.Hls waitForProgressDone :: Session () waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressEnd v -> Just () _ -> Nothing -- | Wait for all progress to be done @@ -193,7 +190,7 @@ waitForAllProgressDone = loop where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) |Lens.is _workDoneProgressEnd v-> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop @@ -216,7 +213,7 @@ main = do defaultMainWithRerun $ testGroup "ghcide" [ testSession "open close" $ do doc <- createDoc "Testing.hs" "haskell" "" - void (skipManyTill anyMessage $ message SWindowWorkDoneProgressCreate) + void (skipManyTill anyMessage $ message SMethod_WindowWorkDoneProgressCreate) waitForProgressBegin closeDoc doc waitForProgressDone @@ -259,12 +256,12 @@ initializeResponseTests = withResource acquire release tests where -- 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 (ResponseMessage Initialize) -> TestTree + tests :: IO (TResponseMessage Method_Initialize) -> TestTree tests getInitializeResponse = testGroup "initialize response capabilities" [ chk " text doc sync" _textDocumentSync tds , chk " hover" _hoverProvider (Just $ InL True) - , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just True)) + , chk " completion" _completionProvider (Just $ CompletionOptions Nothing (Just ["."]) Nothing (Just True) Nothing) , chk "NO signature help" _signatureHelpProvider Nothing , chk " goto definition" _definitionProvider (Just $ InL True) , chk " goto type definition" _typeDefinitionProvider (Just $ InL True) @@ -287,13 +284,14 @@ initializeResponseTests = withResource acquire release tests where , chk "NO color" (^. L.colorProvider) (Just $ InL False) , chk "NO folding range" _foldingRangeProvider (Just $ InL False) , che " execute command" _executeCommandProvider [typeLensCommandId, blockCommandId] - , chk " workspace" (^. L.workspace) (Just $ WorkspaceServerCapabilities (Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )})) + , chk " workspace" (^. L.workspace) (Just $ #workspaceFolders .== Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )} + .+ #fileOperations .== Nothing) , chk "NO experimental" (^. L.experimental) Nothing ] where tds = Just (InL (TextDocumentSyncOptions { _openClose = Just True - , _change = Just TdSyncIncremental + , _change = Just TextDocumentSyncKind_Incremental , _willSave = Nothing , _willSaveWaitUntil = Nothing , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) @@ -307,18 +305,18 @@ initializeResponseTests = withResource acquire release tests where where doTest = do ir <- getInitializeResponse - let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir + let Just ExecuteCommandOptions {_commands = commands} = getActual $ innerCaps ir commandNames = (!! 2) . T.splitOn ":" <$> commands zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames) - innerCaps :: ResponseMessage Initialize -> ServerCapabilities - innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c - innerCaps (ResponseMessage _ _ (Left _)) = error "Initialization error" + innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities + innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c + innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error" - acquire :: IO (ResponseMessage Initialize) + acquire :: IO (TResponseMessage Method_Initialize) acquire = run initializeResponse - release :: ResponseMessage Initialize -> IO () + release :: TResponseMessage Method_Initialize -> IO () release = const $ pure () @@ -327,37 +325,31 @@ diagnosticTests = testGroup "diagnostics" [ testSessionWait "fix syntax error" $ do let content = T.unlines [ "module Testing wher" ] doc <- createDoc "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 19)) - , _rangeLength = Nothing - , _text = "where" - } + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])] + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 15) (Position 0 19) + .+ #rangeLength .== Nothing + .+ #text .== "where" changeDoc doc [change] expectDiagnostics [("Testing.hs", [])] , testSessionWait "introduce syntax error" $ do let content = T.unlines [ "module Testing where" ] doc <- createDoc "Testing.hs" "haskell" content - void $ skipManyTill anyMessage (message SWindowWorkDoneProgressCreate) + void $ skipManyTill anyMessage (message SMethod_WindowWorkDoneProgressCreate) waitForProgressBegin - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 18)) - , _rangeLength = Nothing - , _text = "wher" - } + let change = TextDocumentContentChangeEvent$ InL $ #range .== Range (Position 0 15) (Position 0 18) + .+ #rangeLength .== Nothing + .+ #text .== "wher" changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "parse error")])] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "parse error")])] , testSessionWait "update syntax error" $ do let content = T.unlines [ "module Testing(missing) where" ] doc <- createDoc "Testing.hs" "haskell" content - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'missing'")])] - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 15) (Position 0 16)) - , _rangeLength = Nothing - , _text = "l" - } + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'missing'")])] + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 15) (Position 0 16) + .+ #rangeLength .== Nothing + .+ #text .== "l" changeDoc doc [change] - expectDiagnostics [("Testing.hs", [(DsError, (0, 15), "Not in scope: 'lissing'")])] + expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'lissing'")])] , testSessionWait "variable not in scope" $ do let content = T.unlines [ "module Testing where" @@ -369,8 +361,8 @@ diagnosticTests = testGroup "diagnostics" _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs" - , [ (DsError, (2, 15), "Variable not in scope: ab") - , (DsError, (4, 11), "Variable not in scope: cd") + , [ (DiagnosticSeverity_Error, (2, 15), "Variable not in scope: ab") + , (DiagnosticSeverity_Error, (4, 11), "Variable not in scope: cd") ] ) ] @@ -383,7 +375,7 @@ diagnosticTests = testGroup "diagnostics" _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs" - , [(DsError, (2, 14), "Couldn't match type '[Char]' with 'Int'")] + , [(DiagnosticSeverity_Error, (2, 14), "Couldn't match type '[Char]' with 'Int'")] ) ] , testSessionWait "typed hole" $ do @@ -395,7 +387,7 @@ diagnosticTests = testGroup "diagnostics" _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs" - , [(DsError, (2, 8), "Found hole: _ :: Int -> String")] + , [(DiagnosticSeverity_Error, (2, 8), "Found hole: _ :: Int -> String")] ) ] @@ -411,8 +403,8 @@ diagnosticTests = testGroup "diagnostics" , "b = True"] bMessage = "Couldn't match expected type 'Float' with actual type 'Bool'" expectedDs aMessage = - [ ("A.hs", [(DsError, (2,4), aMessage)]) - , ("B.hs", [(DsError, (3,4), bMessage)])] + [ ("A.hs", [(DiagnosticSeverity_Error, (2,4), aMessage)]) + , ("B.hs", [(DiagnosticSeverity_Error, (3,4), bMessage)])] deferralTest title binding msg = testSessionWait title $ do _ <- createDoc "A.hs" "haskell" $ sourceA binding _ <- createDoc "B.hs" "haskell" sourceB @@ -431,20 +423,18 @@ diagnosticTests = testGroup "diagnostics" , "import ModuleA" ] _ <- createDoc "ModuleB.hs" "haskell" contentB - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 0 0) (Position 0 20)) - , _rangeLength = Nothing - , _text = "" - } + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 0) (Position 0 20) + .+ #rangeLength .== Nothing + .+ #text .== "" changeDoc docA [change] - expectDiagnostics [("ModuleB.hs", [(DsError, (1, 0), "Could not find module")])] + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 0), "Could not find module")])] , testSessionWait "add missing module" $ do let contentB = T.unlines [ "module ModuleB where" , "import ModuleA ()" ] _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics [("ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] let contentA = T.unlines [ "module ModuleA where" ] _ <- createDoc "ModuleA.hs" "haskell" contentA expectDiagnostics [("ModuleB.hs", [])] @@ -459,7 +449,7 @@ diagnosticTests = testGroup "diagnostics" , "import ModuleA ()" ] _ <- createDoc (tmpDir "ModuleB.hs") "haskell" contentB - expectDiagnostics [(tmpDir "ModuleB.hs", [(DsError, (1, 7), "Could not find module")])] + expectDiagnostics [(tmpDir "ModuleB.hs", [(DiagnosticSeverity_Error, (1, 7), "Could not find module")])] let contentA = T.unlines [ "module ModuleA where" ] _ <- createDoc (tmpDir "ModuleA.hs") "haskell" contentA expectDiagnostics [(tmpDir "ModuleB.hs", [])] @@ -476,10 +466,10 @@ diagnosticTests = testGroup "diagnostics" _ <- createDoc "ModuleB.hs" "haskell" contentB expectDiagnostics [ ( "ModuleA.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] ) , ( "ModuleB.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] ) ] , testSession' "deeply nested cyclic module dependency" $ \path -> do @@ -500,7 +490,7 @@ diagnosticTests = testGroup "diagnostics" _ <- createDoc "ModuleD.hs" "haskell" contentD expectDiagnostics [ ( "ModuleB.hs" - , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] + , [(DiagnosticSeverity_Error, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")] ) ] , testSessionWait "cyclic module dependency with hs-boot" $ do @@ -521,7 +511,7 @@ diagnosticTests = testGroup "diagnostics" _ <- createDoc "ModuleA.hs" "haskell" contentA _ <- createDoc "ModuleB.hs" "haskell" contentB _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot - expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])] + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] , testSessionWait "correct reference used with hs-boot" $ do let contentB = T.unlines [ "module ModuleB where" @@ -547,7 +537,7 @@ diagnosticTests = testGroup "diagnostics" _ <- createDoc "ModuleA.hs" "haskell" contentA _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot _ <- createDoc "ModuleC.hs" "haskell" contentC - expectDiagnostics [("ModuleC.hs", [(DsWarning, (3,0), "Top-level binding")])] + expectDiagnostics [("ModuleC.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] , testSessionWait "redundant import" $ do let contentA = T.unlines ["module ModuleA where"] let contentB = T.unlines @@ -559,7 +549,7 @@ diagnosticTests = testGroup "diagnostics" _ <- createDoc "ModuleB.hs" "haskell" contentB expectDiagnosticsWithTags [ ( "ModuleB.hs" - , [(DsWarning, (2, 0), "The import of 'ModuleA' is redundant", Just DtUnnecessary)] + , [(DiagnosticSeverity_Warning, (2, 0), "The import of 'ModuleA' is redundant", Just DiagnosticTag_Unnecessary)] ) ] , testSessionWait "redundant import even without warning" $ do @@ -573,7 +563,7 @@ diagnosticTests = testGroup "diagnostics" ] _ <- createDoc "ModuleA.hs" "haskell" contentA _ <- createDoc "ModuleB.hs" "haskell" contentB - expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])] + expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] , testSessionWait "package imports" $ do let thisDataListContent = T.unlines [ "module Data.List where" @@ -595,14 +585,14 @@ diagnosticTests = testGroup "diagnostics" _ <- createDoc "Main.hs" "haskell" mainContent expectDiagnostics [ ( "Main.hs" - , [(DsError, (6, 9), + , [(DiagnosticSeverity_Error, (6, 9), if ghcVersion >= GHC96 then "Variable not in scope: ThisList.map" else if ghcVersion >= GHC94 then "Variable not in scope: map" -- See https://gitlab.haskell.org/ghc/ghc/-/issues/22130 else "Not in scope: \8216ThisList.map\8217") - ,(DsError, (7, 9), + ,(DiagnosticSeverity_Error, (7, 9), if ghcVersion >= GHC96 then "Variable not in scope: BaseList.x" else if ghcVersion >= GHC94 then @@ -626,7 +616,7 @@ diagnosticTests = testGroup "diagnostics" -- where appropriate. The warning should use an unqualified name 'Ord', not -- something like 'GHC.Classes.Ord'. The choice of redundant-constraints to -- test this is fairly arbitrary. - , [(DsWarning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a") + , [(DiagnosticSeverity_Warning, (2, if ghcVersion >= GHC94 then 7 else 0), "Redundant constraint: Ord a") ] ) ] @@ -654,12 +644,12 @@ diagnosticTests = testGroup "diagnostics" in filePathToUri (joinDrive (lower drive) suffix) let itemA = TextDocumentItem uriA "haskell" 0 aContent let a = TextDocumentIdentifier uriA - sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams itemA) - NotificationMessage{_params = PublishDiagnosticsParams fileUri _ diags} <- skipManyTill anyMessage diagnostic + sendNotification SMethod_TextDocumentDidOpen (DidOpenTextDocumentParams itemA) + TNotificationMessage{_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 - let msg = head (toList diags) ^. L.message + let msg :: T.Text = (head diags) ^. L.message liftIO $ unless ("redundant" `T.isInfixOf` msg) $ assertFailure ("Expected redundant import but got " <> T.unpack msg) closeDoc a @@ -676,7 +666,7 @@ diagnosticTests = testGroup "diagnostics" else expectDiagnostics [ ( "Foo.hs" - , [(DsWarning, (2, 8), "Haddock parse error on input")] + , [(DiagnosticSeverity_Warning, (2, 8), "Haddock parse error on input")] ) ] , testSessionWait "strip file path" $ do @@ -691,10 +681,10 @@ diagnosticTests = testGroup "diagnostics" notification <- skipManyTill anyMessage diagnostic let offenders = - Lsp.params . - Lsp.diagnostics . + L.params . + L.diagnostics . Lens.folded . - Lsp.message . + L.message . Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:")) failure msg = liftIO $ assertFailure $ "Expected file path to be stripped but got " <> T.unpack msg Lens.mapMOf_ offenders failure notification @@ -708,7 +698,7 @@ diagnosticTests = testGroup "diagnostics" _ <- createDoc "Foo.hs" "haskell" fooContent expectDiagnostics [ ( "Foo.hs" - , [(DsWarning, (1, 0), "Top-level binding with no type signature:") + , [(DiagnosticSeverity_Warning, (1, 0), "Top-level binding with no type signature:") ] ) ] @@ -722,7 +712,7 @@ diagnosticTests = testGroup "diagnostics" _ <- createDoc "Foo.hs" "haskell" fooContent expectDiagnostics [ ( "Foo.hs" - , [(DsWarning, (3, 0), "Defined but not used:") + , [(DiagnosticSeverity_Warning, (3, 0), "Defined but not used:") ] ) ] @@ -738,24 +728,24 @@ diagnosticTests = testGroup "diagnostics" bdoc <- createDoc bPath "haskell" bSource _pdoc <- createDoc pPath "haskell" pSource expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So that we know P has been loaded -- Change y from Int to B which introduces a type error in A (imported from P) - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] expectDiagnostics - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) ] -- Open A and edit to fix the type error adoc <- createDoc aPath "haskell" aSource - changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing $ + changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module A where", "import B", "x :: Bool", "x = y"]] expectDiagnostics [ ( "P.hs", - [ (DsError, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"), - (DsWarning, (4, 0), "Top-level binding") + [ (DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"), + (DiagnosticSeverity_Warning, (4, 0), "Top-level binding") ] ), ("A.hs", []) @@ -765,14 +755,14 @@ diagnosticTests = testGroup "diagnostics" , testSessionWait "deduplicate missing module diagnostics" $ do let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ] doc <- createDoc "Foo.hs" "haskell" fooContent - expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])] + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])] - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module Foo() where" ] + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ "module Foo() where" ] expectDiagnostics [] - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines [ "module Foo() where" , "import MissingModule" ] ] - expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])] + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (1,7), "Could not find module 'MissingModule'")])] , testGroup "Cancellation" [ cancellationTestGroup "edit header" editHeader yesSession noParse noTc @@ -782,8 +772,12 @@ diagnosticTests = testGroup "diagnostics" ] where editPair x y = let p = Position x y ; p' = Position x (y+2) in - (TextDocumentContentChangeEvent {_range=Just (Range p p), _rangeLength=Nothing, _text="fd"} - ,TextDocumentContentChangeEvent {_range=Just (Range p p'), _rangeLength=Nothing, _text=""}) + (TextDocumentContentChangeEvent $ InL $ #range .== Range p p + .+ #rangeLength .== Nothing + .+ #text .== "fd" + ,TextDocumentContentChangeEvent $ InL $ #range .== Range p p' + .+ #rangeLength .== Nothing + .+ #text .== "") editHeader = editPair 0 0 editImport = editPair 2 10 editBody = editPair 3 10 @@ -823,7 +817,7 @@ cancellationTemplate (edit, undoEdit) mbKey = testCase (maybe "-" fst mbKey) $ r ] -- for the example above we expect one warning - let missingSigDiags = [(DsWarning, (3, 0), "Top-level binding") ] + let missingSigDiags = [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding") ] typeCheck doc >> expectCurrentDiagnostics doc missingSigDiags -- Now we edit the document and wait for the given key (if any) @@ -861,7 +855,7 @@ watchedFilesTests = testGroup "watched files" [ 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 STextDocumentPublishDiagnostics + watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle liftIO $ length watchedFileRegs @?= 2 @@ -871,7 +865,7 @@ watchedFilesTests = testGroup "watched files" let yaml = "cradle: {direct: {arguments: [\"-i" <> tail(init(show tmpDir)) <> "\", \"A\", \"WatchedFilesMissingModule\"]}}" liftIO $ writeFile (sessionDir "hie.yaml") yaml _doc <- createDoc "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule" - watchedFileRegs <- getWatchedFilesSubscriptionsUntil STextDocumentPublishDiagnostics + watchedFileRegs <- getWatchedFilesSubscriptionsUntil SMethod_TextDocumentPublishDiagnostics -- Expect 2 subscriptions: one for all .hs files and one for the hie.yaml cradle liftIO $ length watchedFileRegs @?= 2 @@ -892,15 +886,15 @@ watchedFilesTests = testGroup "watched files" ,"a :: ()" ,"a = b" ] - expectDiagnostics [("A.hs", [(DsError, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'")])] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Bool'")])] -- modify B off editor liftIO $ writeFile (sessionDir "B.hs") $ unlines ["module B where" ,"b :: Int" ,"b = 0"] - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri $ sessionDir "B.hs") FcChanged ] - expectDiagnostics [("A.hs", [(DsError, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])] + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + [FileEvent (filePathToUri $ sessionDir "B.hs") FileChangeType_Changed ] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 4), "Couldn't match expected type '()' with actual type 'Int'")])] ] ] @@ -924,7 +918,7 @@ addSigLensesTests = sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do let originalCode = before enableGHCWarnings exported def others let expectedCode = after' enableGHCWarnings exported def others - sendNotification SWorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode + sendNotification SMethod_WorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode doc <- createDoc "Sigs.hs" "haskell" originalCode waitForProgressDone codeLenses <- getCodeLenses doc @@ -983,11 +977,14 @@ addSigLensesTests = liftIO $ newLens @?= oldLens ] -linkToLocation :: [LocationLink] -> [Location] -linkToLocation = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange) +defToLocation :: Definition |? ([DefinitionLink] |? Null) -> [Location] +defToLocation (InL (Definition (InL l))) = [l] +defToLocation (InL (Definition (InR ls))) = ls +defToLocation (InR (InL defLink)) = (\(DefinitionLink LocationLink{_targetUri,_targetRange}) -> Location _targetUri _targetRange) <$> defLink +defToLocation (InR (InR Null)) = [] -checkDefs :: [Location] |? [LocationLink] -> Session [Expect] -> Session () -checkDefs (either id linkToLocation . toEither -> defs) mkExpectations = traverse_ check =<< mkExpectations where +checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session () +checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpectations where check (ExpectRange expectedRange) = do assertNDefinitionsFound 1 defs assertRangeCorrect (head defs) expectedRange @@ -1038,7 +1035,7 @@ findDefinitionAndHoverTests = let check expected = case hover of Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" - Just Hover{_contents = (HoverContents MarkupContent{_value = standardizeQuotes -> msg}) + Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg}) ,_range = rangeInHover } -> case expected of ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg @@ -1063,7 +1060,7 @@ findDefinitionAndHoverTests = let Position{_line = l + 1, _character = c + 1} in case map (read . T.unpack) lineCol of - [l,c] -> liftIO $ adjust (_start expectedRange) @=? Position l c + [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c _ -> liftIO $ assertFailure $ "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> "\n but got: " <> show (msg, rangeInHover) @@ -1086,8 +1083,8 @@ findDefinitionAndHoverTests = let , testGroup "hover" $ mapMaybe snd tests , checkFileCompiles sourceFilePath $ expectDiagnostics - [ ( "GotoHover.hs", [(DsError, (62, 7), "Found hole: _")]) - , ( "GotoHover.hs", [(DsError, (65, 8), "Found hole: _")]) + [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")]) + , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")]) ] , testGroup "type-definition" typeDefinitionTests , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ] @@ -1112,7 +1109,7 @@ findDefinitionAndHoverTests = let hover = (getHover , checkHover) -- search locations expectations on results - fffL4 = _start fffR ; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] + fffL4 = fffR ^. L.start; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] fffL8 = Position 12 4 ; fffL14 = Position 18 7 ; aL20 = Position 19 15 @@ -1265,7 +1262,7 @@ pluginSimpleTests = expectDiagnostics [ ( "KnownNat.hs", - [(DsError, (9, 15), "Variable not in scope: c")] + [(DiagnosticSeverity_Error, (9, 15), "Variable not in scope: c")] ) ] @@ -1306,7 +1303,7 @@ cppTests = ," failed" ,"#endif" ] - expectDiagnostics [("A.hs", [(DsError, (3, 2), "Variable not in scope: worked")])] + expectDiagnostics [("A.hs", [(DiagnosticSeverity_Error, (3, 2), "Variable not in scope: worked")])] ] where expectError :: T.Text -> Cursor -> Session () @@ -1314,7 +1311,7 @@ cppTests = _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs", - [(DsError, cursor, "error: unterminated")] + [(DiagnosticSeverity_Error, cursor, "error: unterminated")] ) ] expectNoMoreDiagnostics 0.5 @@ -1330,7 +1327,7 @@ preprocessorTests = testSessionWait "preprocessor" $ do _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs", - [(DsError, (2, 8), "Variable not in scope: z")] + [(DiagnosticSeverity_Error, (2, 8), "Variable not in scope: z")] ) ] @@ -1391,7 +1388,7 @@ thTests = ] _ <- createDoc "A.hs" "haskell" sourceA _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics [ ( "B.hs", [(DsError, (6, 29), "Variable not in scope: n")] ) ] + expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Error, (6, 29), "Variable not in scope: n")] ) ] , testSessionWait "newtype-closure" $ do let sourceA = T.unlines @@ -1439,7 +1436,7 @@ thTests = , "main = $a (putStrLn \"success!\")"] _ <- createDoc "A.hs" "haskell" sourceA _ <- createDoc "B.hs" "haskell" sourceB - expectDiagnostics [ ( "B.hs", [(DsWarning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ] + expectDiagnostics [ ( "B.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding with no type signature: main :: IO ()")] ) ] , testCase "findsTHnewNameConstructor" $ runWithExtraFiles "THNewName" $ \dir -> do -- This test defines a TH value with the meaning "data A = A" in A.hs @@ -1450,7 +1447,7 @@ thTests = let cPath = dir "C.hs" _ <- openDoc cPath "haskell" - expectDiagnostics [ ( cPath, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ] + expectDiagnostics [ ( cPath, [(DiagnosticSeverity_Warning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ] ] -- | Tests for projects that use symbolic links one way or another @@ -1461,7 +1458,7 @@ symlinkTests = liftIO $ createFileLink (dir "some_loc" "Sym.hs") (dir "other_loc" "Sym.hs") let fooPath = dir "src" "Foo.hs" _ <- openDoc fooPath "haskell" - expectDiagnosticsWithTags [("src" "Foo.hs", [(DsWarning, (2, 0), "The import of 'Sym' is redundant", Just DtUnnecessary)])] + expectDiagnosticsWithTags [("src" "Foo.hs", [(DiagnosticSeverity_Warning, (2, 0), "The import of 'Sym' is redundant", Just DiagnosticTag_Unnecessary)])] pure () ] @@ -1494,19 +1491,19 @@ thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do bdoc <- createDoc bPath "haskell" bSource cdoc <- createDoc cPath "haskell" cSource - expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] + expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])] -- Change th from () to Bool let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] - changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] + changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource'] -- generate an artificial warning to avoid timing out if the TH change does not propagate - changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing $ cSource <> "\nfoo=()"] + changeDoc cdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ cSource <> "\nfoo=()"] -- Check that the change propagates to C expectDiagnostics - [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")]) - ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level bindin")]) + [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) + ,("THC.hs", [(DiagnosticSeverity_Warning, (6,0), "Top-level binding")]) + ,("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level bindin")]) ] closeDoc adoc @@ -1529,18 +1526,18 @@ thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do adoc <- createDoc aPath "haskell" aSource bdoc <- createDoc bPath "haskell" bSource - expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] + expectDiagnostics [("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])] let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] - changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] + changeDoc adoc [TextDocumentContentChangeEvent . InR . (.==) #text $ aSource'] -- modify b too let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource'] + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ bSource'] waitForProgressBegin waitForAllProgressDone - expectCurrentDiagnostics bdoc [(DsWarning, (4,thDollarIdx), "Top-level binding")] + expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")] closeDoc adoc closeDoc bdoc @@ -1562,7 +1559,7 @@ completionTests , testGroup "doc" completionDocTests ] -completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe (List TextEdit))] -> TestTree +completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe [TextEdit])] -> TestTree completionTest name src pos expected = testSessionWait name $ do docId <- createDoc "A.hs" "haskell" (T.unlines src) _ <- waitForDiagnostics @@ -1576,7 +1573,7 @@ completionTest name src pos expected = testSessionWait name $ do CompletionItem{..} <- if expectedSig || expectedDocs then do - rsp <- request SCompletionItemResolve item + rsp <- request SMethod_CompletionItemResolve item case rsp ^. L.result of Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) Right x -> pure x @@ -1593,41 +1590,41 @@ topLevelCompletionTests = [ "variable" ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] (Position 0 8) - [("xxx", CiFunction, "xxx", True, True, Nothing) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing) ], completionTest "constructor" ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] (Position 0 8) - [("xxx", CiFunction, "xxx", True, True, Nothing) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing) ], completionTest "class method" ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"] (Position 0 8) - [("xxx", CiFunction, "xxx", True, True, Nothing)], + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing)], completionTest "type" ["bar :: Xz", "zzz = ()", "-- | haddock", "data Xzz = XzzCon"] (Position 0 9) - [("Xzz", CiStruct, "Xzz", False, True, Nothing)], + [("Xzz", CompletionItemKind_Struct, "Xzz", False, True, Nothing)], completionTest "class" ["bar :: Xz", "zzz = ()", "-- | haddock", "class Xzz a"] (Position 0 9) - [("Xzz", CiInterface, "Xzz", False, True, Nothing)], + [("Xzz", CompletionItemKind_Interface, "Xzz", False, True, Nothing)], completionTest "records" ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] (Position 1 19) - [("_personName", CiFunction, "_personName", False, True, Nothing), - ("_personAge", CiFunction, "_personAge", False, True, Nothing)], + [("_personName", CompletionItemKind_Function, "_personName", False, True, Nothing), + ("_personAge", CompletionItemKind_Function, "_personAge", False, True, Nothing)], completionTest "recordsConstructor" ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ] (Position 1 19) - [("XyRecord", CiConstructor, "XyRecord", False, True, Nothing), - ("XyRecord", CiSnippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)] + [("XyRecord", CompletionItemKind_Constructor, "XyRecord", False, True, Nothing), + ("XyRecord", CompletionItemKind_Snippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)] ] localCompletionTests :: [TestTree] @@ -1636,8 +1633,8 @@ localCompletionTests = [ "argument" ["bar (Just abcdef) abcdefg = abcd"] (Position 0 32) - [("abcdef", CiFunction, "abcdef", True, False, Nothing), - ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) ], completionTest "let" @@ -1646,8 +1643,8 @@ localCompletionTests = [ ," in abcd" ] (Position 2 15) - [("abcdef", CiFunction, "abcdef", True, False, Nothing), - ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) ], completionTest "where" @@ -1656,8 +1653,8 @@ localCompletionTests = [ ," abcdefg = let abcd = undefined in undefined" ] (Position 0 10) - [("abcdef", CiFunction, "abcdef", True, False, Nothing), - ("abcdefg", CiFunction , "abcdefg", True, False, Nothing) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) ], completionTest "do/1" @@ -1668,7 +1665,7 @@ localCompletionTests = [ ," pure ()" ] (Position 2 6) - [("abcdef", CiFunction, "abcdef", True, False, Nothing) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) ], completionTest "do/2" @@ -1682,12 +1679,12 @@ localCompletionTests = [ ," abcdefghij = undefined" ] (Position 5 8) - [("abcde", CiFunction, "abcde", True, False, Nothing) - ,("abcdefghij", CiFunction, "abcdefghij", True, False, Nothing) - ,("abcdef", CiFunction, "abcdef", True, False, Nothing) - ,("abcdefg", CiFunction, "abcdefg", True, False, Nothing) - ,("abcdefgh", CiFunction, "abcdefgh", True, False, Nothing) - ,("abcdefghi", CiFunction, "abcdefghi", True, False, Nothing) + [("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) + ,("abcdefghij", CompletionItemKind_Function, "abcdefghij", True, False, Nothing) + ,("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) + ,("abcdefg", CompletionItemKind_Function, "abcdefg", True, False, Nothing) + ,("abcdefgh", CompletionItemKind_Function, "abcdefgh", True, False, Nothing) + ,("abcdefghi", CompletionItemKind_Function, "abcdefghi", True, False, Nothing) ], completionTest "type family" @@ -1696,7 +1693,7 @@ localCompletionTests = [ ,"a :: Ba" ] (Position 2 7) - [("Bar", CiStruct, "Bar", True, False, Nothing) + [("Bar", CompletionItemKind_Struct, "Bar", True, False, Nothing) ], completionTest "class method" @@ -1708,19 +1705,15 @@ localCompletionTests = [ , " abcd = abc" ] (Position 4 14) - [("abcd", CiFunction, "abcd", True, False, Nothing) - ,("abcde", CiFunction, "abcde", True, False, Nothing) + [("abcd", CompletionItemKind_Function, "abcd", True, False, Nothing) + ,("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) ], testSessionWait "incomplete entries" $ do let src a = "data Data = " <> a doc <- createDoc "A.hs" "haskell" $ src "AAA" void $ waitForTypecheck doc let editA rhs = - changeDoc doc [TextDocumentContentChangeEvent - { _range=Nothing - , _rangeLength=Nothing - , _text=src rhs}] - + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ src rhs] editA "AAAA" void $ waitForTypecheck doc editA "AAAAA" @@ -1737,30 +1730,30 @@ nonLocalCompletionTests = "variable" ["module A where", "f = hea"] (Position 1 7) - [("head", CiFunction, "head", True, True, Nothing)], + [("head", CompletionItemKind_Function, "head", True, True, Nothing)], completionTest "constructor" ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"] (Position 2 8) - [ ("True", CiConstructor, "True", True, True, Nothing) + [ ("True", CompletionItemKind_Constructor, "True", True, True, Nothing) ], brokenForWinGhc $ completionTest "type" ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"] (Position 2 8) - [ ("Bool", CiStruct, "Bool", True, True, Nothing) + [ ("Bool", CompletionItemKind_Struct, "Bool", True, True, Nothing) ], completionTest "qualified" ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] (Position 2 15) - [ ("head", CiFunction, "head", True, True, Nothing) + [ ("head", CompletionItemKind_Function, "head", True, True, Nothing) ], completionTest "duplicate import" ["module A where", "import Data.List", "import Data.List", "f = permu"] (Position 3 9) - [ ("permutations", CiFunction, "permutations", False, False, Nothing) + [ ("permutations", CompletionItemKind_Function, "permutations", False, False, Nothing) ], completionTest "dont show hidden items" @@ -1778,7 +1771,7 @@ nonLocalCompletionTests = ,"f = BS.read" ] (Position 2 10) - [("readFile", CiFunction, "readFile", True, True, Nothing)] + [("readFile", CompletionItemKind_Function, "readFile", True, True, Nothing)] ], -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls completionTest @@ -1799,7 +1792,7 @@ otherCompletionTests = [ "keyword" ["module A where", "f = newty"] (Position 1 9) - [("newtype", CiKeyword, "", False, False, Nothing)], + [("newtype", CompletionItemKind_Keyword, "", False, False, Nothing)], completionTest "type context" [ "{-# OPTIONS_GHC -Wunused-binds #-}", @@ -1811,7 +1804,7 @@ otherCompletionTests = [ -- This should be sufficient to detect that we are in a -- type context and only show the completion to the type. (Position 3 11) - [("Integer", CiStruct, "Integer", True, True, Nothing)], + [("Integer", CompletionItemKind_Struct, "Integer", True, True, Nothing)], testSession "duplicate record fields" $ do void $ @@ -1859,7 +1852,7 @@ packageCompletionTests = compls <- getCompletions doc (Position 2 12) let compls' = [T.drop 1 $ T.dropEnd 3 d - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} <- compls , _label == "fromList" ] @@ -1879,7 +1872,7 @@ packageCompletionTests = compls <- getCompletions doc (Position 2 7) let compls' = [T.drop 1 $ T.dropEnd 3 d - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} <- compls , _label == "Map" ] @@ -1904,7 +1897,7 @@ packageCompletionTests = CompletionItem { _insertText = Just "fromList" , _documentation = - Just (CompletionDocMarkup (MarkupContent MkMarkdown d)) + Just (InR (MarkupContent MarkupKind_Markdown d)) } -> "GHC.Exts" `T.isInfixOf` d _ -> False @@ -1948,7 +1941,7 @@ projectCompletionTests = compls <- getCompletions doc (Position 1 10) let compls' = [T.drop 1 $ T.dropEnd 3 d - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} <- compls , _label == "anidentifier" ] @@ -1967,9 +1960,9 @@ projectCompletionTests = "import ALocal" ] compls <- getCompletions doc (Position 1 13) - let item = head $ filter ((== "ALocalModule") . (^. Lens.label)) compls + let item = head $ filter ((== "ALocalModule") . (^. L.label)) compls liftIO $ do - item ^. Lens.label @?= "ALocalModule", + item ^. L.label @?= "ALocalModule", testSession' "auto complete functions from qualified imports without alias" $ \dir-> do liftIO $ writeFile (dir "hie.yaml") "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" @@ -2088,7 +2081,7 @@ completionDocTests = _ <- waitForDiagnostics compls <- getCompletions doc pos rcompls <- forM compls $ \item -> do - rsp <- request SCompletionItemResolve item + rsp <- request SMethod_CompletionItemResolve item case rsp ^. L.result of Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) Right x -> pure x @@ -2097,7 +2090,7 @@ completionDocTests = case mn of Nothing -> txt Just n -> T.take n txt - | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown txt)), ..} <- rcompls + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown txt)), ..} <- rcompls , _label == label ] liftIO $ compls' @?= expected @@ -2108,48 +2101,48 @@ highlightTests = testGroup "highlight" doc <- createDoc "A.hs" "haskell" source _ <- waitForDiagnostics highlights <- getHighlights doc (Position 3 2) - 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) - , DocumentHighlight (R 5 22 5 25) (Just HkRead) + liftIO $ highlights @?= + [ DocumentHighlight (R 2 0 2 3) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 3 0 3 3) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 4 6 4 9) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 5 22 5 25) (Just DocumentHighlightKind_Read) ] , testSessionWait "type" $ do doc <- createDoc "A.hs" "haskell" source _ <- waitForDiagnostics highlights <- getHighlights doc (Position 2 8) - liftIO $ highlights @?= List - [ DocumentHighlight (R 2 7 2 10) (Just HkRead) - , DocumentHighlight (R 3 11 3 14) (Just HkRead) + liftIO $ highlights @?= + [ DocumentHighlight (R 2 7 2 10) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 3 11 3 14) (Just DocumentHighlightKind_Read) ] , testSessionWait "local" $ do doc <- createDoc "A.hs" "haskell" source _ <- waitForDiagnostics highlights <- getHighlights doc (Position 6 5) - 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) + liftIO $ highlights @?= + [ DocumentHighlight (R 6 4 6 7) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 6 10 6 13) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 7 12 7 15) (Just DocumentHighlightKind_Read) ] , knownBrokenForGhcVersions [GHC90, GHC92, GHC94, GHC96] "Ghc9 highlights the constructor and not just this field" $ testSessionWait "record" $ do doc <- createDoc "A.hs" "haskell" recsource _ <- waitForDiagnostics highlights <- getHighlights doc (Position 4 15) - liftIO $ highlights @?= List + liftIO $ highlights @?= -- Span is just the .. on 8.10, but Rec{..} before [ if ghcVersion >= GHC810 - then DocumentHighlight (R 4 8 4 10) (Just HkWrite) - else DocumentHighlight (R 4 4 4 11) (Just HkWrite) - , DocumentHighlight (R 4 14 4 20) (Just HkRead) + then DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Write) + else DocumentHighlight (R 4 4 4 11) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 4 14 4 20) (Just DocumentHighlightKind_Read) ] highlights <- getHighlights doc (Position 3 17) - liftIO $ highlights @?= List - [ DocumentHighlight (R 3 17 3 23) (Just HkWrite) + liftIO $ highlights @?= + [ DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write) -- Span is just the .. on 8.10, but Rec{..} before , if ghcVersion >= GHC810 - then DocumentHighlight (R 4 8 4 10) (Just HkRead) - else DocumentHighlight (R 4 4 4 11) (Just HkRead) + then DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Read) + else DocumentHighlight (R 4 4 4 11) (Just DocumentHighlightKind_Read) ] ] where @@ -2178,28 +2171,28 @@ outlineTests = testGroup let source = T.unlines ["module A where", "class A a where a :: a -> Bool"] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left + liftIO $ symbols @?= Right [ moduleSymbol "A" (R 0 7 0 8) [ classSymbol "A a" (R 1 0 1 30) - [docSymbol' "a" SkMethod (R 1 16 1 30) (R 1 16 1 17)] + [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)] ] ] , testSessionWait "type class instance " $ do let source = T.unlines ["class A a where", "instance A () where"] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left + liftIO $ symbols @?= Right [ classSymbol "A a" (R 0 0 0 15) [] - , docSymbol "A ()" SkInterface (R 1 0 1 19) + , docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19) ] , testSessionWait "type family" $ do let source = T.unlines ["{-# language TypeFamilies #-}", "type family A"] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "A" "type family" SkFunction (R 1 0 1 13)] + liftIO $ symbols @?= Right [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)] , testSessionWait "type family instance " $ do let source = T.unlines [ "{-# language TypeFamilies #-}" @@ -2208,15 +2201,15 @@ outlineTests = testGroup ] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolD "A a" "type family" SkFunction (R 1 0 1 15) - , docSymbol "A ()" SkInterface (R 2 0 2 23) + liftIO $ symbols @?= Right + [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15) + , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23) ] , testSessionWait "data family" $ do let source = T.unlines ["{-# language TypeFamilies #-}", "data family A"] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "A" "data family" SkFunction (R 1 0 1 11)] + liftIO $ symbols @?= Right [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)] , testSessionWait "data family instance " $ do let source = T.unlines [ "{-# language TypeFamilies #-}" @@ -2225,58 +2218,58 @@ outlineTests = testGroup ] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolD "A a" "data family" SkFunction (R 1 0 1 11) - , docSymbol "A ()" SkInterface (R 2 0 2 25) + liftIO $ symbols @?= Right + [ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 11) + , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25) ] , testSessionWait "constant" $ do let source = T.unlines ["a = ()"] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "a" SkFunction (R 0 0 0 6)] + liftIO $ symbols @?= Right + [docSymbol "a" SymbolKind_Function (R 0 0 0 6)] , testSessionWait "pattern" $ do let source = T.unlines ["Just foo = Just 21"] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "Just foo" SkFunction (R 0 0 0 18)] + liftIO $ symbols @?= Right + [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)] , testSessionWait "pattern with type signature" $ do let source = T.unlines ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol "a :: ()" SkFunction (R 1 0 1 12)] + liftIO $ symbols @?= Right + [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)] , testSessionWait "function" $ do let source = T.unlines ["a _x = ()"] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbol "a" SkFunction (R 0 0 0 9)] + liftIO $ symbols @?= Right [docSymbol "a" SymbolKind_Function (R 0 0 0 9)] , testSessionWait "type synonym" $ do let source = T.unlines ["type A = Bool"] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [docSymbol' "A" SkTypeParameter (R 0 0 0 13) (R 0 5 0 6)] + liftIO $ symbols @?= Right + [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)] , testSessionWait "datatype" $ do let source = T.unlines ["data A = C"] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left + liftIO $ symbols @?= Right [ docSymbolWithChildren "A" - SkStruct + SymbolKind_Struct (R 0 0 0 10) - [docSymbol "C" SkConstructor (R 0 9 0 10)] + [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)] ] , testSessionWait "record fields" $ do let source = T.unlines ["data A = B {", " x :: Int", " , y :: Int}"] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left - [ docSymbolWithChildren "A" SkStruct (R 0 0 2 13) - [ docSymbolWithChildren' "B" SkConstructor (R 0 9 2 13) (R 0 9 0 10) - [ docSymbol "x" SkField (R 1 2 1 3) - , docSymbol "y" SkField (R 2 4 2 5) + liftIO $ symbols @?= Right + [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 2 13) + [ docSymbolWithChildren' "B" SymbolKind_Constructor (R 0 9 2 13) (R 0 9 0 10) + [ docSymbol "x" SymbolKind_Field (R 1 2 1 3) + , docSymbol "y" SymbolKind_Field (R 2 4 2 5) ] ] ] @@ -2284,23 +2277,23 @@ outlineTests = testGroup let source = T.unlines ["import Data.Maybe ()"] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left + liftIO $ symbols @?= Right [docSymbolWithChildren "imports" - SkModule + SymbolKind_Module (R 0 0 0 20) - [ docSymbol "import Data.Maybe" SkModule (R 0 0 0 20) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20) ] ] , testSessionWait "multiple import" $ do let source = T.unlines ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left + liftIO $ symbols @?= Right [docSymbolWithChildren "imports" - SkModule + SymbolKind_Module (R 1 0 3 27) - [ docSymbol "import Data.Maybe" SkModule (R 1 0 1 20) - , docSymbol "import Control.Exception" SkModule (R 3 0 3 27) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20) + , docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27) ] ] , testSessionWait "foreign import" $ do @@ -2310,7 +2303,7 @@ outlineTests = testGroup ] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "a" "import" SkObject (R 1 0 1 33)] + liftIO $ symbols @?= Right [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)] , testSessionWait "foreign export" $ do let source = T.unlines [ "{-# language ForeignFunctionInterface #-}" @@ -2318,7 +2311,7 @@ outlineTests = testGroup ] docId <- createDoc "A.hs" "haskell" source symbols <- getDocumentSymbols docId - liftIO $ symbols @?= Left [docSymbolD "odd" "export" SkObject (R 1 0 1 39)] + liftIO $ symbols @?= Right [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)] ] where docSymbol name kind loc = @@ -2328,25 +2321,25 @@ outlineTests = testGroup docSymbolD name detail kind loc = DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing docSymbolWithChildren name kind loc cc = - DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just $ List cc) + DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc) docSymbolWithChildren' name kind loc selectionLoc cc = - DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just $ List cc) + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc) moduleSymbol name loc cc = DocumentSymbol name Nothing - SkFile + SymbolKind_File Nothing Nothing (R 0 0 maxBound 0) loc - (Just $ List cc) + (Just cc) classSymbol name loc cc = DocumentSymbol name (Just "class") - SkInterface + SymbolKind_Interface Nothing Nothing loc loc - (Just $ List cc) + (Just cc) pattern R :: UInt -> UInt -> UInt -> UInt -> Range pattern R x y x' y' = Range (Position x y) (Position x' y') @@ -2532,13 +2525,13 @@ loadCradleOnlyonce = testGroup "load cradle only once" 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 STextDocumentPublishDiagnostics)) + msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) liftIO $ length msgs @?= 1 - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module B where\nimport Data.Maybe"] - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ "module B where\nimport Data.Maybe"] + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) liftIO $ length msgs @?= 0 _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" - msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message STextDocumentPublishDiagnostics)) + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) liftIO $ length msgs @?= 0 retryFailedCradle :: TestTree @@ -2555,8 +2548,8 @@ retryFailedCradle = testSession' "retry failed" $ \dir -> do -- Fix the cradle and typecheck again let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}" liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri $ dir "hie.yaml") FcChanged ] + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + [FileEvent (filePathToUri $ dir "hie.yaml") FileChangeType_Changed ] WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess @@ -2588,29 +2581,27 @@ dependentFileTest = testGroup "addDependentFile" expectDiagnostics $ if ghcVersion >= GHC90 -- String vs [Char] causes this change in error message - then [("Foo.hs", [(DsError, if ghcVersion >= GHC92 then (4,11) else (4, 6), "Couldn't match type")])] - else [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] + then [("Foo.hs", [(DiagnosticSeverity_Error, if ghcVersion >= GHC92 then (4,11) else (4, 6), "Couldn't match type")])] + else [("Foo.hs", [(DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type")])] -- Now modify the dependent file liftIO $ writeFile depFilePath "B" - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri "dep-file.txt") FcChanged ] + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + [FileEvent (filePathToUri "dep-file.txt") FileChangeType_Changed ] -- Modifying Baz will now trigger Foo to be rebuilt as well - let change = TextDocumentContentChangeEvent - { _range = Just (Range (Position 2 0) (Position 2 6)) - , _rangeLength = Nothing - , _text = "f = ()" - } + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 2 0) (Position 2 6) + .+ #rangeLength .== Nothing + .+ #text .== "f = ()" changeDoc doc [change] expectDiagnostics [("Foo.hs", [])] cradleLoadedMessage :: Session FromServerMessage cradleLoadedMessage = satisfy $ \case - FromServerMess (SCustomMethod m) (NotMess _) -> m == cradleLoadedMethod + FromServerMess (SMethod_CustomMethod p) (NotMess _) -> symbolVal p == cradleLoadedMethod _ -> False -cradleLoadedMethod :: T.Text +cradleLoadedMethod :: String cradleLoadedMethod = "ghcide/cradle/loaded" ignoreFatalWarning :: TestTree @@ -2627,7 +2618,7 @@ simpleSubDirectoryTest = mainSource <- liftIO $ readFileUtf8 mainPath _mdoc <- createDoc mainPath "haskell" mainSource expectDiagnosticsWithTags - [("a/src/Main.hs", [(DsWarning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded + [("a/src/Main.hs", [(DiagnosticSeverity_Warning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded ] expectNoMoreDiagnostics 0.5 @@ -2721,9 +2712,9 @@ bootTests = testGroup "boot" -- that the `getDefinitions` request/response in the outer ghcide -- session will find no definitions. let hoverParams = HoverParams cDoc (Position 4 3) Nothing - hoverRequestId <- sendRequest STextDocumentHover hoverParams + hoverRequestId <- sendRequest SMethod_TextDocumentHover hoverParams let parseReadyMessage = isReferenceReady cPath - let parseHoverResponse = responseForId STextDocumentHover hoverRequestId + let parseHoverResponse = responseForId SMethod_TextDocumentHover hoverRequestId hoverResponseOrReadyMessage <- skipManyTill anyMessage ((Left <$> parseHoverResponse) <|> (Right <$> parseReadyMessage)) _ <- skipManyTill anyMessage $ case hoverResponseOrReadyMessage of @@ -2756,10 +2747,10 @@ ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do liftIO $ writeFileUTF8 aPath (unlines $ init (lines $ T.unpack aSource) ++ ["th_a = [d| a = False|]"]) -- Check that the change propagates to C - changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource] + changeDoc cdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ cSource] expectDiagnostics - [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] + [("THC.hs", [(DiagnosticSeverity_Error, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) + ,("THB.hs", [(DiagnosticSeverity_Warning, (4,thDollarIdx), "Top-level binding")])] closeDoc cdoc ifaceErrorTest :: TestTree @@ -2773,17 +2764,17 @@ ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \d bdoc <- createDoc bPath "haskell" bSource expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So what we know P has been loaded + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So what we know P has been loaded -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] -- save so that we can that the error propagates to A - sendNotification STextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing) + sendNotification SMethod_TextDocumentDidSave (DidSaveTextDocumentParams bdoc Nothing) -- Check that the error propagates to A expectDiagnostics - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])] + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])] -- Check that we wrote the interfaces for B when we saved hidir <- getInterfaceFilesDir bdoc @@ -2792,9 +2783,9 @@ ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \d pdoc <- openDoc pPath "haskell" expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")]) + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) ] - changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ] + changeDoc pdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ pSource <> "\nfoo = y :: Bool" ] -- Now in P we have -- bar = x :: Int -- foo = y :: Bool @@ -2804,8 +2795,8 @@ ifaceErrorTest = testCase "iface-error-test-1" $ runWithExtraFiles "recomp" $ \d -- - The diagnostic for A has already been received. Ghcide does not repeat diagnostics -- - P is being typechecked with the last successful artifacts for A. expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")]) - ,("P.hs", [(DsWarning,(6,0), "Top-level binding")]) + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) + ,("P.hs", [(DiagnosticSeverity_Warning,(6,0), "Top-level binding")]) ] expectNoMoreDiagnostics 2 @@ -2820,13 +2811,13 @@ ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \ bdoc <- createDoc bPath "haskell" bSource pdoc <- createDoc pPath "haskell" pSource expectDiagnostics - [("P.hs", [(DsWarning,(4,0), "Top-level binding")])] -- So that we know P has been loaded + [("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")])] -- So that we know P has been loaded -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] -- Add a new definition to P - changeDoc pdoc [TextDocumentContentChangeEvent Nothing Nothing $ pSource <> "\nfoo = y :: Bool" ] + changeDoc pdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ pSource <> "\nfoo = y :: Bool" ] -- Now in P we have -- bar = x :: Int -- foo = y :: Bool @@ -2835,9 +2826,9 @@ ifaceErrorTest2 = testCase "iface-error-test-2" $ runWithExtraFiles "recomp" $ \ expectDiagnostics -- As in the other test, P is being typechecked with the last successful artifacts for A -- (ot thanks to -fdeferred-type-errors) - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ,("P.hs", [(DsWarning, (4, 0), "Top-level binding")]) - ,("P.hs", [(DsWarning, (6, 0), "Top-level binding")]) + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ,("P.hs", [(DiagnosticSeverity_Warning, (4, 0), "Top-level binding")]) + ,("P.hs", [(DiagnosticSeverity_Warning, (6, 0), "Top-level binding")]) ] expectNoMoreDiagnostics 2 @@ -2853,7 +2844,7 @@ ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \ bdoc <- createDoc bPath "haskell" bSource -- Change y from Int to B - changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] + changeDoc bdoc [TextDocumentContentChangeEvent . InR . (.==) #text $ T.unlines ["module B where", "y :: Bool", "y = undefined"]] -- P should not typecheck, as there are no last valid artifacts for A _pdoc <- createDoc pPath "haskell" pSource @@ -2861,8 +2852,8 @@ ifaceErrorTest3 = testCase "iface-error-test-3" $ runWithExtraFiles "recomp" $ \ -- In this example the interface file for A should not exist (modulo the cache folder) -- Despite that P still type checks, as we can generate an interface file for A thanks to -fdeferred-type-errors expectDiagnostics - [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) - ,("P.hs", [(DsWarning,(4,0), "Top-level binding")]) + [("A.hs", [(DiagnosticSeverity_Error, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")]) + ,("P.hs", [(DiagnosticSeverity_Warning,(4,0), "Top-level binding")]) ] expectNoMoreDiagnostics 2 @@ -2879,22 +2870,20 @@ sessionDepsArePickedUp = testSession' expectDiagnostics $ if ghcVersion >= GHC90 -- String vs [Char] causes this change in error message - then [("Foo.hs", [(DsError, (3, 6), "Couldn't match type")])] - else [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])] + then [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])] + else [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match expected type")])] -- Update hie.yaml to enable OverloadedStrings. liftIO $ writeFileUTF8 (dir "hie.yaml") "cradle: {direct: {arguments: [-XOverloadedStrings]}}" - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri $ dir "hie.yaml") FcChanged ] + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + [FileEvent (filePathToUri $ dir "hie.yaml") FileChangeType_Changed ] -- Send change event. let change = - TextDocumentContentChangeEvent - { _range = Just (Range (Position 4 0) (Position 4 0)), - _rangeLength = Nothing, - _text = "\n" - } + TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 4 0) (Position 4 0) + .+ #rangeLength .== Nothing + .+ #text .== "\n" changeDoc doc [change] -- Now no errors. expectDiagnostics [("Foo.hs", [])] @@ -2942,7 +2931,7 @@ asyncTests = testGroup "async" testSession "command" $ do -- Execute a command that will block forever let req = ExecuteCommandParams Nothing blockCommandId Nothing - void $ sendRequest SWorkspaceExecuteCommand req + void $ sendRequest SMethod_WorkspaceExecuteCommand 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 #-}" @@ -2954,7 +2943,7 @@ asyncTests = testGroup "async" [ "foo :: a -> a" ] , testSession "request" $ do -- Execute a custom request that will block for 1000 seconds - void $ sendRequest (SCustomMethod "test") $ toJSON $ BlockSeconds 1000 + void $ sendRequest (SMethod_CustomMethod (Proxy @"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 #-}" @@ -2970,10 +2959,10 @@ asyncTests = testGroup "async" clientSettingsTest :: TestTree clientSettingsTest = testGroup "client settings handling" [ testSession "ghcide restarts shake session on config changes" $ do - void $ skipManyTill anyMessage $ message SClientRegisterCapability + void $ skipManyTill anyMessage $ message SMethod_ClientRegisterCapability void $ createDoc "A.hs" "haskell" "module A where" waitForProgressDone - sendNotification SWorkspaceDidChangeConfiguration + sendNotification SMethod_WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON (mempty :: A.Object))) skipManyTill anyMessage restartingBuildSession @@ -2981,7 +2970,7 @@ clientSettingsTest = testGroup "client settings handling" where restartingBuildSession :: Session () restartingBuildSession = do - FromServerMess SWindowLogMessage NotificationMessage{_params = LogMessageParams{..}} <- loggingNotification + FromServerMess SMethod_WindowLogMessage TNotificationMessage{_params = LogMessageParams{..}} <- loggingNotification guard $ "Restarting build session" `T.isInfixOf` _message referenceTests :: TestTree @@ -3105,7 +3094,7 @@ data IncludeDeclaration = YesIncludeDeclaration | NoExcludeDeclaration -getReferences' :: SymbolLocation -> IncludeDeclaration -> Session (List Location) +getReferences' :: SymbolLocation -> IncludeDeclaration -> Session ([Location]) getReferences' (file, l, c) includeDeclaration = do doc <- openDoc file "haskell" getReferences doc (Position l c) $ toBool includeDeclaration @@ -3134,7 +3123,7 @@ referenceTestSession name thisDoc docs' f = testSessionWithExtraFiles "reference referenceTest :: String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree referenceTest name loc includeDeclaration expected = referenceTestSession name (fst3 loc) docs $ \dir -> do - List actual <- getReferences' loc includeDeclaration + actual <- getReferences' loc includeDeclaration liftIO $ actual `expectSameLocations` map (first3 (dir )) expected where docs = map fst3 expected @@ -3145,8 +3134,8 @@ expectSameLocations :: [Location] -> [SymbolLocation] -> Assertion expectSameLocations actual expected = do let actual' = Set.map (\location -> (location ^. L.uri - , location ^. L.range . L.start . L.line . to fromIntegral - , location ^. L.range . L.start . L.character . to fromIntegral)) + , location ^. L.range . L.start . L.line . Lens.to fromIntegral + , location ^. L.range . L.start . L.character . Lens.to fromIntegral)) $ Set.fromList actual expected' <- Set.fromList <$> (forM expected $ \(file, l, c) -> do @@ -3261,7 +3250,7 @@ lspTestCaps :: ClientCapabilities lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities (Just True) Nothing Nothing } lspTestCapsNoFileWatches :: ClientCapabilities -lspTestCapsNoFileWatches = lspTestCaps & workspace . Lens._Just . didChangeWatchedFiles .~ Nothing +lspTestCapsNoFileWatches = lspTestCaps & L.workspace . Lens._Just . L.didChangeWatchedFiles .~ Nothing openTestDataDoc :: FilePath -> Session TextDocumentIdentifier openTestDataDoc path = do @@ -3284,7 +3273,9 @@ unitTests recorder logger = do uriToFilePath' uri @?= Just "" , testCase "showDiagnostics prints ranges 1-based (like vscode)" $ do let diag = ("", Diagnostics.ShowDiag, Diagnostic - { _range = Range + { _codeDescription = Nothing + , _data_ = Nothing + , _range = Range { _start = Position{_line = 0, _character = 1} , _end = Position{_line = 2, _character = 3} } @@ -3304,7 +3295,7 @@ unitTests recorder logger = do let plugins = pluginDescToIdePlugins $ [ (priorityPluginDescriptor i) { pluginNotificationHandlers = mconcat - [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \_ _ _ _ -> + [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> liftIO $ atomicModifyIORef_ orderRef (i:) ] } @@ -3381,10 +3372,10 @@ garbageCollectionTests = testGroup "garbage collection" , "a = ()" ] doc <- generateGarbage "A" dir - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing edit] + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ edit] builds <- waitForTypecheck doc liftIO $ assertBool "it still builds" builds - expectCurrentDiagnostics doc [(DsError, (2,4), "Couldn't match expected type")] + expectCurrentDiagnostics doc [(DiagnosticSeverity_Error, (2,4), "Couldn't match expected type")] ] ] where @@ -3547,7 +3538,9 @@ positionMappingTests recorder = range <- genRange rope PrintableText replacement <- arbitrary let newRope = runIdentity $ applyChange mempty rope - (TextDocumentContentChangeEvent (Just range) Nothing replacement) + (TextDocumentContentChangeEvent $ InL $ #range .== range + .+ #rangeLength .== Nothing + .+ #text .== replacement) newPos <- genPosition newRope pure (range, replacement, newPos) forAll @@ -3601,11 +3594,12 @@ nthLine i r getWatchedFilesSubscriptionsUntil :: forall m. SServerMethod m -> Session [DidChangeWatchedFilesRegistrationOptions] getWatchedFilesSubscriptionsUntil m = do - msgs <- manyTill (Just <$> message SClientRegisterCapability <|> Nothing <$ anyMessage) (message m) + msgs <- manyTill (Just <$> message SMethod_ClientRegisterCapability <|> Nothing <$ anyMessage) (message m) return - [ args - | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs - , SomeRegistration (Registration _id SWorkspaceDidChangeWatchedFiles args) <- regs + [ x + | Just TRequestMessage{_params = RegistrationParams regs} <- msgs + , Registration _id "workspace/didChangeWatchedFiles" (Just args) <- regs + , Just x@(DidChangeWatchedFilesRegistrationOptions _) <- [A.decode . A.encode $ args] ] -- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path diff --git a/ghcide/test/ghcide-test-utils.cabal b/ghcide/test/ghcide-test-utils.cabal index 5e1791c3b8..b6a876928e 100644 --- a/ghcide/test/ghcide-test-utils.cabal +++ b/ghcide/test/ghcide-test-utils.cabal @@ -35,9 +35,10 @@ library lsp-types, hls-plugin-api, lens, - lsp-test ^>= 0.14, + lsp-test ^>= 0.15, tasty-hunit >= 0.10, text, + row-types, hs-source-dirs: src exposed-modules: Development.IDE.Test diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 216020a89e..29a47fe49c 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -43,20 +43,20 @@ import Data.Bifunctor (second) import Data.Default import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) +import Data.Proxy import Data.Text (Text) import qualified Data.Text as T import Development.IDE.Plugin.Test (TestRequest (..), WaitForIdeRuleResult, ideResultSuccess) import Development.IDE.Test.Diagnostic +import GHC.TypeLits ( symbolVal ) import Ide.Plugin.Config (CheckParents, checkProject) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import Language.LSP.Test hiding (message) import qualified Language.LSP.Test as LspTest -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import Language.LSP.Types.Lens as Lsp import System.Directory (canonicalizePath) import System.FilePath (equalFilePath) import System.Time.Extra @@ -75,23 +75,23 @@ requireDiagnosticM actuals expected = case requireDiagnostic actuals expected of -- if any diagnostic messages arrive in that period expectNoMoreDiagnostics :: HasCallStack => Seconds -> Session () expectNoMoreDiagnostics timeout = - expectMessages STextDocumentPublishDiagnostics timeout $ \diagsNot -> do - let fileUri = diagsNot ^. params . uri - actual = diagsNot ^. params . diagnostics - unless (actual == List []) $ liftIO $ + expectMessages SMethod_TextDocumentPublishDiagnostics timeout $ \diagsNot -> do + let fileUri = diagsNot ^. L.params . L.uri + actual = diagsNot ^. L.params . L.diagnostics + unless (actual == []) $ liftIO $ assertFailure $ "Got unexpected diagnostics for " <> show fileUri <> " got " <> show actual -expectMessages :: SMethod m -> Seconds -> (ServerMessage m -> Session ()) -> Session () +expectMessages :: SMethod m -> Seconds -> (TServerMessage 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. - let cm = SCustomMethod "test" + let cm = SMethod_CustomMethod (Proxy @"test") i <- sendRequest cm $ A.toJSON GetShakeSessionQueueCount go cm i where @@ -102,7 +102,7 @@ expectMessages m timeout handle = do flushMessages :: Session () flushMessages = do - let cm = SCustomMethod "non-existent-method" + let cm = SMethod_CustomMethod (Proxy @"non-existent-method") i <- sendRequest cm A.Null void (responseForId cm i) <|> ignoreOthers cm i where @@ -118,8 +118,8 @@ expectDiagnostics = expectDiagnosticsWithTags . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) -unwrapDiagnostic :: NotificationMessage TextDocumentPublishDiagnostics -> (Uri, List Diagnostic) -unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics) +unwrapDiagnostic :: TServerMessage Method_TextDocumentPublishDiagnostics -> (Uri, [Diagnostic]) +unwrapDiagnostic diagsNot = (diagsNot^. L.params . L.uri, diagsNot^. L.params . L.diagnostics) expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () expectDiagnosticsWithTags expected = do @@ -130,13 +130,13 @@ expectDiagnosticsWithTags expected = do expectDiagnosticsWithTags' :: (HasCallStack, MonadIO m) => - m (Uri, List Diagnostic) -> + m (Uri, [Diagnostic]) -> Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] -> m () expectDiagnosticsWithTags' next m | null m = do (_,actual) <- next case actual of - List [] -> + [] -> return () _ -> liftIO $ assertFailure $ "Got unexpected diagnostics:" <> show actual @@ -178,19 +178,19 @@ checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [(Diagnostic checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do let expected' = Map.fromList [(nuri, map (\(ds, c, t) -> (ds, c, t, Nothing)) expected)] nuri = toNormalizedUri _uri - expectDiagnosticsWithTags' (return (_uri, List obtained)) expected' + expectDiagnosticsWithTags' (return (_uri, obtained)) expected' canonicalizeUri :: Uri -> IO Uri canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri)) -diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics) -diagnostic = LspTest.message STextDocumentPublishDiagnostics +diagnostic :: Session (TNotificationMessage Method_TextDocumentPublishDiagnostics) +diagnostic = LspTest.message SMethod_TextDocumentPublishDiagnostics tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) tryCallTestPlugin cmd = do - let cm = SCustomMethod "test" + let cm = SMethod_CustomMethod (Proxy @"test") waitId <- sendRequest cm (A.toJSON cmd) - ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId + TResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId return $ case _result of Left e -> Left e Right json -> case A.fromJSON json of @@ -230,8 +230,8 @@ getFilesOfInterest = callTestPlugin GetFilesOfInterest waitForCustomMessage :: T.Text -> (A.Value -> Maybe res) -> Session res waitForCustomMessage msg pred = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess (SCustomMethod lbl) (NotMess NotificationMessage{_params = value}) - | lbl == msg -> pred value + FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params = value}) + | symbolVal p == T.unpack msg -> pred value _ -> Nothing waitForGC :: Session [T.Text] @@ -242,7 +242,7 @@ waitForGC = waitForCustomMessage "ghcide/GC" $ \v -> configureCheckProject :: Bool -> Session () configureCheckProject overrideCheckProject = - sendNotification SWorkspaceDidChangeConfiguration + sendNotification SMethod_WorkspaceDidChangeConfiguration (DidChangeConfigurationParams $ toJSON def{checkProject = overrideCheckProject}) @@ -252,9 +252,10 @@ isReferenceReady p = void $ referenceReady (equalFilePath p) referenceReady :: (FilePath -> Bool) -> Session FilePath referenceReady pred = satisfyMaybe $ \case - FromServerMess (SCustomMethod "ghcide/reference/ready") (NotMess NotificationMessage{_params}) + FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params}) | A.Success fp <- A.fromJSON _params , pred fp + , symbolVal p == "ghcide/reference/ready" -> Just fp _ -> Nothing diff --git a/ghcide/test/src/Development/IDE/Test/Diagnostic.hs b/ghcide/test/src/Development/IDE/Test/Diagnostic.hs index 8bf8bc1e9f..86c1b8bb9d 100644 --- a/ghcide/test/src/Development/IDE/Test/Diagnostic.hs +++ b/ghcide/test/src/Development/IDE/Test/Diagnostic.hs @@ -1,10 +1,10 @@ module Development.IDE.Test.Diagnostic where -import Control.Lens ((^.)) -import qualified Data.Text as T -import GHC.Stack (HasCallStack) -import Language.LSP.Types -import Language.LSP.Types.Lens as Lsp +import Control.Lens ((^.)) +import qualified Data.Text as T +import GHC.Stack (HasCallStack) +import Language.LSP.Protocol.Lens +import Language.LSP.Protocol.Types -- | (0-based line number, 0-based column number) type Cursor = (UInt, UInt) @@ -33,10 +33,10 @@ requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) standardizeQuotes (T.toLower $ d ^. message) && hasTag expectedTag (d ^. tags) - hasTag :: Maybe DiagnosticTag -> Maybe (List DiagnosticTag) -> Bool - hasTag Nothing _ = True - hasTag (Just _) Nothing = False - hasTag (Just actualTag) (Just (List tags)) = actualTag `elem` tags + hasTag :: Maybe DiagnosticTag -> Maybe [DiagnosticTag] -> Bool + hasTag Nothing _ = True + hasTag (Just _) Nothing = False + hasTag (Just actualTag) (Just tags) = actualTag `elem` tags standardizeQuotes :: T.Text -> T.Text standardizeQuotes msg = let diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index b8d43f06e6..aec1e399d6 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 category: Development name: haskell-language-server -version: 2.0.0.0 +version: 2.1.0.0 synopsis: LSP server for GHC description: Please see the README on GitHub at @@ -218,149 +218,149 @@ flag cabalfmt common cabalfmt if flag(cabalfmt) - build-depends: hls-cabal-fmt-plugin == 2.0.0.0 + build-depends: hls-cabal-fmt-plugin == 2.1.0.0 cpp-options: -Dhls_cabalfmt common cabal if flag(cabal) - build-depends: hls-cabal-plugin == 2.0.0.0 + build-depends: hls-cabal-plugin == 2.1.0.0 cpp-options: -Dhls_cabal common class if flag(class) - build-depends: hls-class-plugin == 2.0.0.0 + build-depends: hls-class-plugin == 2.1.0.0 cpp-options: -Dhls_class common callHierarchy if flag(callHierarchy) - build-depends: hls-call-hierarchy-plugin == 2.0.0.0 + build-depends: hls-call-hierarchy-plugin == 2.1.0.0 cpp-options: -Dhls_callHierarchy common haddockComments if flag(haddockComments) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-haddock-comments-plugin == 2.0.0.0 + build-depends: hls-haddock-comments-plugin == 2.1.0.0 cpp-options: -Dhls_haddockComments common eval if flag(eval) - build-depends: hls-eval-plugin == 2.0.0.0 + build-depends: hls-eval-plugin == 2.1.0.0 cpp-options: -Dhls_eval common importLens if flag(importLens) - build-depends: hls-explicit-imports-plugin == 2.0.0.0 + build-depends: hls-explicit-imports-plugin == 2.1.0.0 cpp-options: -Dhls_importLens common refineImports if flag(refineImports) - build-depends: hls-refine-imports-plugin == 2.0.0.0 + build-depends: hls-refine-imports-plugin == 2.1.0.0 cpp-options: -Dhls_refineImports common rename if flag(rename) - build-depends: hls-rename-plugin == 2.0.0.0 + build-depends: hls-rename-plugin == 2.1.0.0 cpp-options: -Dhls_rename common retrie if flag(retrie) - build-depends: hls-retrie-plugin == 2.0.0.0 + build-depends: hls-retrie-plugin == 2.1.0.0 cpp-options: -Dhls_retrie common tactic if flag(tactic) && (impl(ghc < 9.2.1) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-tactics-plugin == 2.0.0.0 + build-depends: hls-tactics-plugin == 2.1.0.0 cpp-options: -Dhls_tactic common hlint if flag(hlint) && impl(ghc < 9.5) - build-depends: hls-hlint-plugin == 2.0.0.0 + build-depends: hls-hlint-plugin == 2.1.0.0 cpp-options: -Dhls_hlint common stan if flag(stan) && (impl(ghc >= 8.10) && impl(ghc < 9.0)) - build-depends: hls-stan-plugin == 2.0.0.0 + build-depends: hls-stan-plugin == 2.1.0.0 cpp-options: -Dhls_stan common moduleName if flag(moduleName) - build-depends: hls-module-name-plugin == 2.0.0.0 + build-depends: hls-module-name-plugin == 2.1.0.0 cpp-options: -Dhls_moduleName common pragmas if flag(pragmas) - build-depends: hls-pragmas-plugin == 2.0.0.0 + build-depends: hls-pragmas-plugin == 2.1.0.0 cpp-options: -Dhls_pragmas common splice if flag(splice) - build-depends: hls-splice-plugin == 2.0.0.0 + build-depends: hls-splice-plugin == 2.1.0.0 cpp-options: -Dhls_splice common alternateNumberFormat if flag(alternateNumberFormat) - build-depends: hls-alternate-number-format-plugin == 2.0.0.0 + build-depends: hls-alternate-number-format-plugin == 2.1.0.0 cpp-options: -Dhls_alternateNumberFormat common qualifyImportedNames if flag(qualifyImportedNames) - build-depends: hls-qualify-imported-names-plugin == 2.0.0.0 + build-depends: hls-qualify-imported-names-plugin == 2.1.0.0 cpp-options: -Dhls_qualifyImportedNames common codeRange if flag(codeRange) - build-depends: hls-code-range-plugin == 2.0.0.0 + build-depends: hls-code-range-plugin == 2.1.0.0 cpp-options: -Dhls_codeRange common changeTypeSignature if flag(changeTypeSignature) - build-depends: hls-change-type-signature-plugin == 2.0.0.0 + build-depends: hls-change-type-signature-plugin == 2.1.0.0 cpp-options: -Dhls_changeTypeSignature common gadt if flag(gadt) - build-depends: hls-gadt-plugin == 2.0.0.0 + build-depends: hls-gadt-plugin == 2.1.0.0 cpp-options: -Dhls_gadt common explicitFixity if flag(explicitFixity) - build-depends: hls-explicit-fixity-plugin == 2.0.0.0 + build-depends: hls-explicit-fixity-plugin == 2.1.0.0 cpp-options: -DexplicitFixity common explicitFields if flag(explicitFields) - build-depends: hls-explicit-record-fields-plugin == 2.0.0.0 + build-depends: hls-explicit-record-fields-plugin == 2.1.0.0 cpp-options: -DexplicitFields common overloadedRecordDot if flag(overloadedRecordDot) && (impl(ghc >= 9.2.0) || flag(ignore-plugins-ghc-bounds)) - build-depends: hls-overloaded-record-dot-plugin == 2.0.0.0 + build-depends: hls-overloaded-record-dot-plugin == 2.1.0.0 cpp-options: -Dhls_overloaded_record_dot -- formatters common floskell if flag(floskell) && impl(ghc < 9.5) - build-depends: hls-floskell-plugin == 2.0.0.0 + build-depends: hls-floskell-plugin == 2.1.0.0 cpp-options: -Dhls_floskell common fourmolu if flag(fourmolu) - build-depends: hls-fourmolu-plugin == 2.0.0.0 + build-depends: hls-fourmolu-plugin == 2.1.0.0 cpp-options: -Dhls_fourmolu common ormolu if flag(ormolu) && impl(ghc < 9.5) - build-depends: hls-ormolu-plugin == 2.0.0.0 + build-depends: hls-ormolu-plugin == 2.1.0.0 cpp-options: -Dhls_ormolu common stylishHaskell if flag(stylishHaskell) && impl(ghc < 9.5) - build-depends: hls-stylish-haskell-plugin == 2.0.0.0 + build-depends: hls-stylish-haskell-plugin == 2.1.0.0 cpp-options: -Dhls_stylishHaskell common refactor if flag(refactor) - build-depends: hls-refactor-plugin == 2.0.0.0 + build-depends: hls-refactor-plugin == 2.1.0.0 cpp-options: -Dhls_refactor library @@ -416,12 +416,12 @@ library , cryptohash-sha1 , data-default , ghc - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , githash >=0.1.6.1 - , lsp + , lsp >= 2.0.0.0 , hie-bios , hiedb - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , optparse-applicative , optparse-simple , process @@ -560,13 +560,14 @@ test-suite func-test , lens-aeson , ghcide , ghcide-test-utils - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , lsp-types , aeson , hls-plugin-api , lsp-test , containers , unordered-containers + , row-types hs-source-dirs: test/functional test/utils diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 28c4fb05c1..ca6a786475 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-graph -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Haskell Language Server internal graph API description: Please see the README on GitHub at diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 98757d26ae..2762f335ff 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-plugin-api -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Haskell Language Server API for plugin communication description: Please see the README on GitHub at @@ -55,10 +55,10 @@ library , filepath , ghc , hashable - , hls-graph == 2.0.0.0 + , hls-graph == 2.1.0.0 , lens , lens-aeson - , lsp ^>=1.6.0.0 + , lsp ^>=2.0.0.0 , opentelemetry >=0.4 , optparse-applicative , regex-tdfa >=1.3.1.0 diff --git a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs index 19599fd794..c3a5295257 100644 --- a/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs +++ b/hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs @@ -5,20 +5,21 @@ module Ide.Plugin.ConfigUtils where -import Control.Lens (at, ix, (&), (?~)) -import qualified Data.Aeson as A -import Data.Aeson.Lens (_Object) -import qualified Data.Aeson.Types as A +import Control.Lens (at, ix, (&), (?~)) +import qualified Data.Aeson as A +import Data.Aeson.Lens (_Object) +import qualified Data.Aeson.Types as A import Data.Default -import qualified Data.Dependent.Map as DMap -import qualified Data.Dependent.Sum as DSum -import Data.List.Extra (nubOrd) -import Data.String (IsString (fromString)) -import qualified Data.Text as T +import qualified Data.Dependent.Map as DMap +import qualified Data.Dependent.Sum as DSum +import Data.List.Extra (nubOrd) +import Data.String (IsString (fromString)) +import qualified Data.Text as T import Ide.Plugin.Config -import Ide.Plugin.Properties (toDefaultJSON, toVSCodeExtensionSchema) +import Ide.Plugin.Properties (toDefaultJSON, + toVSCodeExtensionSchema) import Ide.Types -import Language.LSP.Types +import Language.LSP.Protocol.Message -- Attention: -- 'diagnosticsOn' will never be added into the default config or the schema, @@ -86,13 +87,13 @@ pluginsToDefaultConfig IdePlugins {..} = -- This function captures ide methods registered by the plugin, and then converts it to kv pairs handlersToGenericDefaultConfig :: PluginConfig -> DSum.DSum IdeMethod f -> [A.Pair] handlersToGenericDefaultConfig PluginConfig{..} (IdeMethod m DSum.:=> _) = case m of - STextDocumentCodeAction -> ["codeActionsOn" A..= plcCodeActionsOn] - STextDocumentCodeLens -> ["codeLensOn" A..= plcCodeLensOn] - STextDocumentRename -> ["renameOn" A..= plcRenameOn] - STextDocumentHover -> ["hoverOn" A..= plcHoverOn] - STextDocumentDocumentSymbol -> ["symbolsOn" A..= plcSymbolsOn] - STextDocumentCompletion -> ["completionOn" A..= plcCompletionOn] - STextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn] + SMethod_TextDocumentCodeAction -> ["codeActionsOn" A..= plcCodeActionsOn] + SMethod_TextDocumentCodeLens -> ["codeLensOn" A..= plcCodeLensOn] + SMethod_TextDocumentRename -> ["renameOn" A..= plcRenameOn] + SMethod_TextDocumentHover -> ["hoverOn" A..= plcHoverOn] + SMethod_TextDocumentDocumentSymbol -> ["symbolsOn" A..= plcSymbolsOn] + SMethod_TextDocumentCompletion -> ["completionOn" A..= plcCompletionOn] + SMethod_TextDocumentPrepareCallHierarchy -> ["callHierarchyOn" A..= plcCallHierarchyOn] _ -> [] -- | Generates json schema used in haskell vscode extension @@ -116,13 +117,13 @@ pluginsToVSCodeExtensionSchema IdePlugins {..} = A.object $ mconcat $ singlePlug _ -> x dedicatedSchema = customConfigToDedicatedSchema configCustomConfig handlersToGenericSchema (IdeMethod m DSum.:=> _) = case m of - STextDocumentCodeAction -> [toKey' "codeActionsOn" A..= schemaEntry "code actions"] - STextDocumentCodeLens -> [toKey' "codeLensOn" A..= schemaEntry "code lenses"] - STextDocumentRename -> [toKey' "renameOn" A..= schemaEntry "rename"] - STextDocumentHover -> [toKey' "hoverOn" A..= schemaEntry "hover"] - STextDocumentDocumentSymbol -> [toKey' "symbolsOn" A..= schemaEntry "symbols"] - STextDocumentCompletion -> [toKey' "completionOn" A..= schemaEntry "completions"] - STextDocumentPrepareCallHierarchy -> [toKey' "callHierarchyOn" A..= schemaEntry "call hierarchy"] + SMethod_TextDocumentCodeAction -> [toKey' "codeActionsOn" A..= schemaEntry "code actions"] + SMethod_TextDocumentCodeLens -> [toKey' "codeLensOn" A..= schemaEntry "code lenses"] + SMethod_TextDocumentRename -> [toKey' "renameOn" A..= schemaEntry "rename"] + SMethod_TextDocumentHover -> [toKey' "hoverOn" A..= schemaEntry "hover"] + SMethod_TextDocumentDocumentSymbol -> [toKey' "symbolsOn" A..= schemaEntry "symbols"] + SMethod_TextDocumentCompletion -> [toKey' "completionOn" A..= schemaEntry "completions"] + SMethod_TextDocumentPrepareCallHierarchy -> [toKey' "callHierarchyOn" A..= schemaEntry "call hierarchy"] _ -> [] schemaEntry desc = A.object diff --git a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs index 461e0af432..97b5614d42 100644 --- a/hls-plugin-api/src/Ide/Plugin/RangeMap.hs +++ b/hls-plugin-api/src/Ide/Plugin/RangeMap.hs @@ -22,9 +22,8 @@ module Ide.Plugin.RangeMap import Data.Bifunctor (first) import Data.Foldable (foldl') import Development.IDE.Graph.Classes (NFData) -import Language.LSP.Types (Position, - Range (Range), - isSubrangeOf) +import Language.LSP.Protocol.Types (Position, + Range (Range)) #ifdef USE_FINGERTREE import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM #endif diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 14da81039a..1c43c9c13c 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -40,34 +40,30 @@ module Ide.PluginUtils where -import Control.Arrow ((&&&)) -import Control.Lens ((^.)) -import Control.Monad.Extra (maybeM) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) +import Control.Arrow ((&&&)) +import Control.Lens (re, (^.)) +import Control.Monad.Extra (maybeM) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Data.Algorithm.Diff import Data.Algorithm.DiffOutput -import Data.Bifunctor (Bifunctor (first)) -import Data.Char (isPrint, showLitChar) -import Data.Functor (void) -import qualified Data.HashMap.Strict as H -import Data.String (IsString (fromString)) -import qualified Data.Text as T -import Data.Void (Void) +import Data.Bifunctor (Bifunctor (first)) +import Data.Char (isPrint, showLitChar) +import Data.Functor (void) +import qualified Data.Map as M +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import Data.Void (Void) import Ide.Plugin.Config import Ide.Plugin.Properties import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import Language.LSP.Server -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import qualified Language.LSP.Types as J -import Language.LSP.Types.Capabilities -import qualified Language.LSP.Types.Lens as J -import qualified Text.Megaparsec as P -import qualified Text.Megaparsec.Char as P -import qualified Text.Megaparsec.Char.Lexer as P +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P +import qualified Text.Megaparsec.Char.Lexer as P -- --------------------------------------------------------------------- @@ -106,14 +102,14 @@ diffText clientCaps old new withDeletions = supports = clientSupportsDocumentChanges clientCaps in diffText' supports old new withDeletions -makeDiffTextEdit :: T.Text -> T.Text -> List TextEdit +makeDiffTextEdit :: T.Text -> T.Text -> [TextEdit] makeDiffTextEdit f1 f2 = diffTextEdit f1 f2 IncludeDeletions -makeDiffTextEditAdditive :: T.Text -> T.Text -> List TextEdit +makeDiffTextEditAdditive :: T.Text -> T.Text -> [TextEdit] makeDiffTextEditAdditive f1 f2 = diffTextEdit f1 f2 SkipDeletions -diffTextEdit :: T.Text -> T.Text -> WithDeletions -> List TextEdit -diffTextEdit fText f2Text withDeletions = J.List r +diffTextEdit :: T.Text -> T.Text -> WithDeletions -> [TextEdit] +diffTextEdit fText f2Text withDeletions = r where r = map diffOperationToTextEdit diffOps d = getGroupedDiff (lines $ T.unpack fText) (lines $ T.unpack f2Text) @@ -125,8 +121,8 @@ diffTextEdit fText f2Text withDeletions = J.List r isDeletion _ = False - diffOperationToTextEdit :: DiffOperation LineRange -> J.TextEdit - diffOperationToTextEdit (Change fm to) = J.TextEdit range nt + diffOperationToTextEdit :: DiffOperation LineRange -> TextEdit + diffOperationToTextEdit (Change fm to) = TextEdit range nt where range = calcRange fm nt = T.pack $ init $ unlines $ lrContents to @@ -138,28 +134,28 @@ diffTextEdit fText f2Text withDeletions = J.List r the line ending character(s) then use an end position denoting the start of the next line" -} - diffOperationToTextEdit (Deletion (LineRange (sl, el) _) _) = J.TextEdit range "" + diffOperationToTextEdit (Deletion (LineRange (sl, el) _) _) = TextEdit range "" where - range = J.Range (J.Position (fromIntegral $ sl - 1) 0) - (J.Position (fromIntegral el) 0) + range = Range (Position (fromIntegral $ sl - 1) 0) + (Position (fromIntegral el) 0) - diffOperationToTextEdit (Addition fm l) = J.TextEdit range nt + diffOperationToTextEdit (Addition fm l) = TextEdit range nt -- fm has a range wrt to the changed file, which starts in the current file at l + 1 -- So the range has to be shifted to start at l + 1 where - range = J.Range (J.Position (fromIntegral l) 0) - (J.Position (fromIntegral l) 0) + range = Range (Position (fromIntegral l) 0) + (Position (fromIntegral l) 0) nt = T.pack $ unlines $ lrContents fm - calcRange fm = J.Range s e + calcRange fm = Range s e where sl = fst $ lrNumbers fm sc = 0 - s = J.Position (fromIntegral $ sl - 1) sc -- Note: zero-based lines + s = Position (fromIntegral $ sl - 1) sc -- Note: zero-based lines el = snd $ lrNumbers fm ec = fromIntegral $ length $ last $ lrContents fm - e = J.Position (fromIntegral $ el - 1) ec -- Note: zero-based lines + e = Position (fromIntegral $ el - 1) ec -- Note: zero-based lines -- | A pure version of 'diffText' for testing @@ -170,15 +166,15 @@ diffText' supports (verTxtDocId,fText) f2Text withDeletions = else WorkspaceEdit (Just h) Nothing Nothing where diff = diffTextEdit fText f2Text withDeletions - h = H.singleton (verTxtDocId ^. J.uri) diff - docChanges = J.List [InL docEdit] - docEdit = J.TextDocumentEdit verTxtDocId $ fmap InL diff + h = M.singleton (verTxtDocId ^. L.uri) diff + docChanges = [InL docEdit] + docEdit = TextDocumentEdit (verTxtDocId ^.re _versionedTextDocumentIdentifier) $ fmap InL diff -- --------------------------------------------------------------------- clientSupportsDocumentChanges :: ClientCapabilities -> Bool clientSupportsDocumentChanges caps = - let ClientCapabilities mwCaps _ _ _ _ = caps + let ClientCapabilities mwCaps _ _ _ _ _ = caps supports = do wCaps <- mwCaps WorkspaceEditClientCapabilities mDc _ _ _ _ <- _workspaceEdit wCaps @@ -282,7 +278,7 @@ handleMaybeM msg act = maybeM (throwE msg) return $ lift act pluginResponse :: Monad m => ExceptT String m a -> m (Either ResponseError a) pluginResponse = - fmap (first (\msg -> ResponseError InternalError (fromString msg) Nothing)) + fmap (first (\msg -> ResponseError (InR ErrorCodes_InternalError) (fromString msg) Nothing)) . runExceptT -- --------------------------------------------------------------------- diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 7647d085b7..c32b7173d0 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -9,6 +9,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -19,7 +20,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} - module Ide.Types ( PluginDescriptor(..), defaultPluginDescriptor, defaultCabalPluginDescriptor , defaultPluginPriority @@ -51,65 +51,48 @@ module Ide.Types where #ifdef mingw32_HOST_OS -import qualified System.Win32.Process as P (getCurrentProcessId) +import qualified System.Win32.Process as P (getCurrentProcessId) #else -import Control.Monad (void) -import qualified System.Posix.Process as P (getProcessID) +import Control.Monad (void) +import qualified System.Posix.Process as P (getProcessID) import System.Posix.Signals #endif -import Control.Applicative ((<|>)) -import Control.Arrow ((&&&)) -import Control.Lens ((.~), (^.)) -import Data.Aeson hiding (defaultOptions) +import Control.Applicative ((<|>)) +import Control.Arrow ((&&&)) +import Control.Lens ((.~), (^.)) +import Data.Aeson hiding (Null, defaultOptions) import Data.Default -import Data.Dependent.Map (DMap) -import qualified Data.Dependent.Map as DMap -import qualified Data.DList as DList +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap +import qualified Data.DList as DList import Data.GADT.Compare -import Data.Hashable (Hashable) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.List.Extra (find, sortOn) -import Data.List.NonEmpty (NonEmpty (..), toList) -import qualified Data.Map as Map +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.List.Extra (find, sortOn) +import Data.List.NonEmpty (NonEmpty (..), toList) +import qualified Data.Map as Map import Data.Maybe import Data.Ord import Data.Semigroup import Data.String -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import Development.IDE.Graph -import GHC (DynFlags) +import GHC (DynFlags) import GHC.Generics import Ide.Plugin.Properties -import Language.LSP.Server (LspM, getVirtualFile) -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import Language.LSP.Types.Capabilities (ClientCapabilities (ClientCapabilities), - TextDocumentClientCapabilities (_codeAction, _documentSymbol)) -import Language.LSP.Types.Lens as J (HasChildren (children), - HasCommand (command), - HasContents (contents), - HasDeprecated (deprecated), - HasEdit (edit), - HasKind (kind), - HasName (name), - HasOptions (..), - HasRange (range), - HasTextDocument (..), - HasTitle (title), - HasUri (..)) -import qualified Language.LSP.Types.Lens as J +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server (LspM, getVirtualFile) import Language.LSP.VFS import Numeric.Natural import OpenTelemetry.Eventlog -import Options.Applicative (ParserInfo) +import Options.Applicative (ParserInfo) import System.FilePath import System.IO.Unsafe -import Text.Regex.TDFA.Text () - +import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- data IdePlugins ideState = IdePlugins_ @@ -342,7 +325,7 @@ defaultConfigDescriptor = -- | Methods that can be handled by plugins. -- 'ExtraParams' captures any extra data the IDE passes to the handlers for this method -- Only methods for which we know how to combine responses can be instances of 'PluginMethod' -class HasTracing (MessageParams m) => PluginMethod (k :: MethodType) (m :: Method FromClient k) where +class HasTracing (MessageParams m) => PluginMethod (k :: MessageKind) (m :: Method ClientToServer k) where -- | Parse the configuration to check if this plugin is enabled. -- Perform sanity checks on the message to see whether the plugin is enabled @@ -382,17 +365,17 @@ class HasTracing (MessageParams m) => PluginMethod (k :: MethodType) (m :: Metho -- ^ Is this plugin enabled and allowed to respond to the given request -- with the given parameters? - default pluginEnabled :: (HasTextDocument (MessageParams m) doc, HasUri doc Uri) + default pluginEnabled :: (L.HasTextDocument (MessageParams m) doc, L.HasUri doc Uri) => SMethod m -> MessageParams m -> PluginDescriptor c -> Config -> Bool pluginEnabled _ params desc conf = pluginResponsible uri desc && plcGlobalOn (configForPlugin conf desc) where - uri = params ^. J.textDocument . J.uri + uri = params ^. L.textDocument . L.uri -- --------------------------------------------------------------------- -- Plugin Requests -- --------------------------------------------------------------------- -class PluginMethod Request m => PluginRequestMethod (m :: Method FromClient Request) where +class PluginMethod Request m => PluginRequestMethod (m :: Method ClientToServer Request) where -- | How to combine responses from different plugins. -- -- For example, for Hover requests, we might have multiple producers of @@ -408,21 +391,21 @@ class PluginMethod Request m => PluginRequestMethod (m :: Method FromClient Requ -> Config -- ^ IDE Configuration -> ClientCapabilities -> MessageParams m - -> NonEmpty (ResponseResult m) -> ResponseResult m + -> NonEmpty (MessageResult m) -> MessageResult m - default combineResponses :: Semigroup (ResponseResult m) - => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (ResponseResult m) -> ResponseResult m + default combineResponses :: Semigroup (MessageResult m) + => SMethod m -> Config -> ClientCapabilities -> MessageParams m -> NonEmpty (MessageResult m) -> MessageResult m combineResponses _method _config _caps _params = sconcat -instance PluginMethod Request TextDocumentCodeAction where +instance PluginMethod Request Method_TextDocumentCodeAction where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc) where - uri = msgParams ^. J.textDocument . J.uri + uri = msgParams ^. L.textDocument . L.uri -instance PluginRequestMethod TextDocumentCodeAction where - combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _) (CodeActionParams _ _ _ _ context) resps = - fmap compat $ List $ filter wasRequested $ (\(List x) -> x) $ sconcat resps +instance PluginRequestMethod Method_TextDocumentCodeAction where + combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _ _) (CodeActionParams _ _ _ _ context) resps = + InL $ fmap compat $ filter wasRequested $ concat $ mapMaybe nullToMaybe $ toList resps where compat :: (Command |? CodeAction) -> (Command |? CodeAction) compat x@(InL _) = x @@ -431,304 +414,325 @@ instance PluginRequestMethod TextDocumentCodeAction where = x | otherwise = InL cmd where - cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. title) (Just cmdParams) - cmdParams = [toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))] + cmd = mkLspCommand "hls" "fallbackCodeAction" (action ^. L.title) (Just cmdParams) + cmdParams = [toJSON (FallbackCodeActionParams (action ^. L.edit) (action ^. L.command))] wasRequested :: (Command |? CodeAction) -> Bool wasRequested (InL _) = True wasRequested (InR ca) | Nothing <- _only context = True - | Just (List allowed) <- _only context + | Just allowed <- _only context -- See https://github.com/microsoft/language-server-protocol/issues/970 -- This is somewhat vague, but due to the hierarchical nature of action kinds, we -- should check whether the requested kind is a *prefix* of the action kind. -- That means, for example, we will return actions with kinds `quickfix.import` and -- `quickfix.somethingElse` if the requested kind is `quickfix`. - , Just caKind <- ca ^. kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed + , Just caKind <- ca ^. L.kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed | otherwise = False -instance PluginMethod Request TextDocumentDefinition where +instance PluginMethod Request Method_TextDocumentDefinition where pluginEnabled _ msgParams pluginDesc _ = pluginResponsible uri pluginDesc where - uri = msgParams ^. J.textDocument . J.uri + uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request TextDocumentTypeDefinition where +instance PluginMethod Request Method_TextDocumentTypeDefinition where pluginEnabled _ msgParams pluginDesc _ = pluginResponsible uri pluginDesc where - uri = msgParams ^. J.textDocument . J.uri + uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request TextDocumentDocumentHighlight where +instance PluginMethod Request Method_TextDocumentDocumentHighlight where pluginEnabled _ msgParams pluginDesc _ = pluginResponsible uri pluginDesc where - uri = msgParams ^. J.textDocument . J.uri + uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request TextDocumentReferences where +instance PluginMethod Request Method_TextDocumentReferences where pluginEnabled _ msgParams pluginDesc _ = pluginResponsible uri pluginDesc where - uri = msgParams ^. J.textDocument . J.uri + uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request WorkspaceSymbol where +instance PluginMethod Request Method_WorkspaceSymbol where -- Unconditionally enabled, but should it really be? pluginEnabled _ _ _ _ = True -instance PluginMethod Request TextDocumentCodeLens where +instance PluginMethod Request Method_TextDocumentCodeLens where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc && pluginEnabledConfig plcCodeLensOn (configForPlugin config pluginDesc) where - uri = msgParams ^. J.textDocument . J.uri + uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request TextDocumentRename where +instance PluginMethod Request Method_TextDocumentRename where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc && pluginEnabledConfig plcRenameOn (configForPlugin config pluginDesc) where - uri = msgParams ^. J.textDocument . J.uri -instance PluginMethod Request TextDocumentHover where + uri = msgParams ^. L.textDocument . L.uri +instance PluginMethod Request Method_TextDocumentHover where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc && pluginEnabledConfig plcHoverOn (configForPlugin config pluginDesc) where - uri = msgParams ^. J.textDocument . J.uri + uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request TextDocumentDocumentSymbol where +instance PluginMethod Request Method_TextDocumentDocumentSymbol where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc && pluginEnabledConfig plcSymbolsOn (configForPlugin config pluginDesc) where - uri = msgParams ^. J.textDocument . J.uri + uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request CompletionItemResolve where +instance PluginMethod Request Method_CompletionItemResolve where pluginEnabled _ msgParams pluginDesc config = pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) -instance PluginMethod Request TextDocumentCompletion where +instance PluginMethod Request Method_TextDocumentCompletion where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc && pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) where - uri = msgParams ^. J.textDocument . J.uri + uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request TextDocumentFormatting where - pluginEnabled STextDocumentFormatting msgParams pluginDesc conf = +instance PluginMethod Request Method_TextDocumentFormatting where + pluginEnabled SMethod_TextDocumentFormatting msgParams pluginDesc conf = pluginResponsible uri pluginDesc && (PluginId (formattingProvider conf) == pid || PluginId (cabalFormattingProvider conf) == pid) where - uri = msgParams ^. J.textDocument . J.uri + uri = msgParams ^. L.textDocument . L.uri pid = pluginId pluginDesc -instance PluginMethod Request TextDocumentRangeFormatting where +instance PluginMethod Request Method_TextDocumentRangeFormatting where pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc && (PluginId (formattingProvider conf) == pid || PluginId (cabalFormattingProvider conf) == pid) where - uri = msgParams ^. J.textDocument . J.uri + uri = msgParams ^. L.textDocument . L.uri pid = pluginId pluginDesc -instance PluginMethod Request TextDocumentPrepareCallHierarchy where +instance PluginMethod Request Method_TextDocumentPrepareCallHierarchy where pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc && pluginEnabledConfig plcCallHierarchyOn (configForPlugin conf pluginDesc) where - uri = msgParams ^. J.textDocument . J.uri + uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request TextDocumentSelectionRange where +instance PluginMethod Request Method_TextDocumentSelectionRange where pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc && pluginEnabledConfig plcSelectionRangeOn (configForPlugin conf pluginDesc) where - uri = msgParams ^. J.textDocument . J.uri + uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request TextDocumentFoldingRange where +instance PluginMethod Request Method_TextDocumentFoldingRange where pluginEnabled _ msgParams pluginDesc conf = pluginResponsible uri pluginDesc && pluginEnabledConfig plcFoldingRangeOn (configForPlugin conf pluginDesc) where - uri = msgParams ^. J.textDocument . J.uri + uri = msgParams ^. L.textDocument . L.uri -instance PluginMethod Request CallHierarchyIncomingCalls where +instance PluginMethod Request Method_CallHierarchyIncomingCalls where -- This method has no URI parameter, thus no call to 'pluginResponsible' pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn (configForPlugin conf pluginDesc) -instance PluginMethod Request CallHierarchyOutgoingCalls where +instance PluginMethod Request Method_CallHierarchyOutgoingCalls where -- This method has no URI parameter, thus no call to 'pluginResponsible' pluginEnabled _ _ pluginDesc conf = pluginEnabledConfig plcCallHierarchyOn (configForPlugin conf pluginDesc) -instance PluginMethod Request CustomMethod where +instance PluginMethod Request (Method_CustomMethod m) where pluginEnabled _ _ _ _ = True --- -instance PluginRequestMethod TextDocumentDefinition where +instance PluginRequestMethod Method_TextDocumentDefinition where combineResponses _ _ _ _ (x :| _) = x -instance PluginRequestMethod TextDocumentTypeDefinition where +instance PluginRequestMethod Method_TextDocumentTypeDefinition where combineResponses _ _ _ _ (x :| _) = x -instance PluginRequestMethod TextDocumentDocumentHighlight where +instance PluginRequestMethod Method_TextDocumentDocumentHighlight where -instance PluginRequestMethod TextDocumentReferences where +instance PluginRequestMethod Method_TextDocumentReferences where -instance PluginRequestMethod WorkspaceSymbol where +instance PluginRequestMethod Method_WorkspaceSymbol where + -- TODO: combine WorkspaceSymbol. Currently all WorkspaceSymbols are dumped + -- as it is new of lsp-types 2.0.0.0 + combineResponses _ _ _ _ xs = InL $ mconcat $ takeLefts $ toList xs -instance PluginRequestMethod TextDocumentCodeLens where +instance PluginRequestMethod Method_TextDocumentCodeLens where -instance PluginRequestMethod TextDocumentRename where +instance PluginRequestMethod Method_TextDocumentRename where -instance PluginRequestMethod TextDocumentHover where - combineResponses _ _ _ _ (catMaybes . toList -> hs) = h +instance PluginRequestMethod Method_TextDocumentHover where + combineResponses _ _ _ _ (mapMaybe nullToMaybe . toList -> hs :: [Hover]) = + if null hs + then InR Null + else InL $ Hover (InL mcontent) r where - r = listToMaybe $ mapMaybe (^. range) hs - h = case foldMap (^. contents) hs of - HoverContentsMS (List []) -> Nothing - hh -> Just $ Hover hh r - -instance PluginRequestMethod TextDocumentDocumentSymbol where - combineResponses _ _ (ClientCapabilities _ tdc _ _ _) params xs = res + r = listToMaybe $ mapMaybe (^. L.range) hs + -- We are only taking MarkupContent here, because MarkedStrings have been + -- deprecated for a while and don't occur in the hls codebase + mcontent :: MarkupContent + mcontent = mconcat $ takeLefts $ map (^. L.contents) hs + +instance PluginRequestMethod Method_TextDocumentDocumentSymbol where + combineResponses _ _ (ClientCapabilities _ tdc _ _ _ _) params xs = res where - uri' = params ^. textDocument . uri + uri' = params ^. L.textDocument . L.uri supportsHierarchy = Just True == (tdc >>= _documentSymbol >>= _hierarchicalDocumentSymbolSupport) - dsOrSi = fmap toEither xs + dsOrSi :: [Either [SymbolInformation] [DocumentSymbol]] + dsOrSi = toEither <$> mapMaybe nullToMaybe' (toList xs) + res :: [SymbolInformation] |? ([DocumentSymbol] |? Null) res - | supportsHierarchy = InL $ sconcat $ fmap (either id (fmap siToDs)) dsOrSi - | otherwise = InR $ sconcat $ fmap (either (List . concatMap dsToSi) id) dsOrSi - siToDs (SymbolInformation name kind _tags dep (Location _uri range) cont) + | supportsHierarchy = InR $ InL $ concatMap (either (fmap siToDs) id) dsOrSi + | otherwise = InL $ concatMap (either id ( concatMap dsToSi)) dsOrSi + -- Is this actually a good conversion? It's what there was before, but some + -- things such as tags are getting lost + siToDs :: SymbolInformation -> DocumentSymbol + siToDs (SymbolInformation name kind _tags cont dep (Location _uri range) ) = DocumentSymbol name cont kind Nothing dep range range Nothing dsToSi = go Nothing 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) Nothing (ds ^. deprecated) loc parent + children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. L.children)) + loc = Location uri' (ds ^. L.range) + name' = ds ^. L.name + si = SymbolInformation name' (ds ^. L.kind) Nothing parent (ds ^. L.deprecated) loc in [si] <> children' -instance PluginRequestMethod CompletionItemResolve where +instance PluginRequestMethod Method_CompletionItemResolve where -- resolving completions can only change the detail, additionalTextEdit or documentation fields combineResponses _ _ _ _ (x :| xs) = go x xs where go :: CompletionItem -> [CompletionItem] -> CompletionItem go !comp [] = comp go !comp1 (comp2:xs) = go (comp1 - & J.detail .~ comp1 ^. J.detail <> comp2 ^. J.detail - & J.documentation .~ ((comp1 ^. J.documentation) <|> (comp2 ^. J.documentation)) -- difficult to write generic concatentation for docs - & J.additionalTextEdits .~ comp1 ^. J.additionalTextEdits <> comp2 ^. J.additionalTextEdits) + & L.detail .~ comp1 ^. L.detail <> comp2 ^. L.detail + & L.documentation .~ ((comp1 ^. L.documentation) <|> (comp2 ^. L.documentation)) -- difficult to write generic concatentation for docs + & L.additionalTextEdits .~ comp1 ^. L.additionalTextEdits <> comp2 ^. L.additionalTextEdits) xs -instance PluginRequestMethod TextDocumentCompletion where +instance PluginRequestMethod Method_TextDocumentCompletion where combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs where limit = maxCompletions conf - combine :: [List CompletionItem |? CompletionList] -> (List CompletionItem |? CompletionList) + combine :: [[CompletionItem] |? (CompletionList |? Null)] -> ([CompletionItem] |? (CompletionList |? Null)) combine cs = go True mempty cs + go :: Bool -> DList.DList CompletionItem -> [[CompletionItem] |? (CompletionList |? Null)] -> ([CompletionItem] |? (CompletionList |? Null)) go !comp acc [] = - InR (CompletionList comp (List $ DList.toList acc)) - go comp acc (InL (List ls) : rest) = + InR (InL (CompletionList comp Nothing ( DList.toList acc))) + go comp acc ((InL ls) : rest) = go comp (acc <> DList.fromList ls) rest - go comp acc (InR (CompletionList comp' (List ls)) : rest) = + go comp acc ( (InR (InL (CompletionList comp' _ ls))) : rest) = go (comp && comp') (acc <> DList.fromList ls) rest - + go comp acc ( (InR (InR Null)) : rest) = + go comp acc rest -- boolean disambiguators isCompleteResponse, isIncompleteResponse :: Bool isIncompleteResponse = True isCompleteResponse = False - - consumeCompletionResponse limit it@(InR (CompletionList _ (List xx))) = + consumeCompletionResponse :: Int -> ([CompletionItem] |? (CompletionList |? Null)) -> (Int, [CompletionItem] |? (CompletionList |? Null)) + consumeCompletionResponse limit it@(InR (InL (CompletionList _ _ 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, InR (CompletionList isIncompleteResponse (List xx'))) - consumeCompletionResponse n (InL (List xx)) = - consumeCompletionResponse n (InR (CompletionList isCompleteResponse (List xx))) - -instance PluginRequestMethod TextDocumentFormatting where + (xx', _) -> (0, InR (InL (CompletionList isIncompleteResponse Nothing xx'))) + consumeCompletionResponse n (InL xx) = + consumeCompletionResponse n (InR (InL (CompletionList isCompleteResponse Nothing xx))) + consumeCompletionResponse n (InR (InR Null)) = (n, InR (InR Null)) +instance PluginRequestMethod Method_TextDocumentFormatting where combineResponses _ _ _ _ (x :| _) = x -instance PluginRequestMethod TextDocumentRangeFormatting where +instance PluginRequestMethod Method_TextDocumentRangeFormatting where combineResponses _ _ _ _ (x :| _) = x -instance PluginRequestMethod TextDocumentPrepareCallHierarchy where +instance PluginRequestMethod Method_TextDocumentPrepareCallHierarchy where -instance PluginRequestMethod TextDocumentSelectionRange where +instance PluginRequestMethod Method_TextDocumentSelectionRange where combineResponses _ _ _ _ (x :| _) = x -instance PluginRequestMethod TextDocumentFoldingRange where +instance PluginRequestMethod Method_TextDocumentFoldingRange where combineResponses _ _ _ _ x = sconcat x -instance PluginRequestMethod CallHierarchyIncomingCalls where +instance PluginRequestMethod Method_CallHierarchyIncomingCalls where -instance PluginRequestMethod CallHierarchyOutgoingCalls where +instance PluginRequestMethod Method_CallHierarchyOutgoingCalls where -instance PluginRequestMethod CustomMethod where +instance PluginRequestMethod (Method_CustomMethod m) where combineResponses _ _ _ _ (x :| _) = x +takeLefts :: [a |? b] -> [a] +takeLefts = mapMaybe (\x -> [res | (InL res) <- Just x]) + +nullToMaybe' :: (a |? (b |? Null)) -> Maybe (a |? b) +nullToMaybe' (InL x) = Just $ InL x +nullToMaybe' (InR (InL x)) = Just $ InR x +nullToMaybe' (InR (InR _)) = Nothing -- --------------------------------------------------------------------- -- Plugin Notifications -- --------------------------------------------------------------------- -- | Plugin Notification methods. No specific methods at the moment, but -- might contain more in the future. -class PluginMethod Notification m => PluginNotificationMethod (m :: Method FromClient Notification) where +class PluginMethod Notification m => PluginNotificationMethod (m :: Method ClientToServer Notification) where -instance PluginMethod Notification TextDocumentDidOpen where +instance PluginMethod Notification Method_TextDocumentDidOpen where -instance PluginMethod Notification TextDocumentDidChange where +instance PluginMethod Notification Method_TextDocumentDidChange where -instance PluginMethod Notification TextDocumentDidSave where +instance PluginMethod Notification Method_TextDocumentDidSave where -instance PluginMethod Notification TextDocumentDidClose where +instance PluginMethod Notification Method_TextDocumentDidClose where -instance PluginMethod Notification WorkspaceDidChangeWatchedFiles where +instance PluginMethod Notification Method_WorkspaceDidChangeWatchedFiles where -- This method has no URI parameter, thus no call to 'pluginResponsible'. pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc -instance PluginMethod Notification WorkspaceDidChangeWorkspaceFolders where +instance PluginMethod Notification Method_WorkspaceDidChangeWorkspaceFolders where -- This method has no URI parameter, thus no call to 'pluginResponsible'. pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc -instance PluginMethod Notification WorkspaceDidChangeConfiguration where +instance PluginMethod Notification Method_WorkspaceDidChangeConfiguration where -- This method has no URI parameter, thus no call to 'pluginResponsible'. pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc -instance PluginMethod Notification Initialized where +instance PluginMethod Notification Method_Initialized where -- This method has no URI parameter, thus no call to 'pluginResponsible'. pluginEnabled _ _ desc conf = plcGlobalOn $ configForPlugin conf desc -instance PluginNotificationMethod TextDocumentDidOpen where +instance PluginNotificationMethod Method_TextDocumentDidOpen where -instance PluginNotificationMethod TextDocumentDidChange where +instance PluginNotificationMethod Method_TextDocumentDidChange where -instance PluginNotificationMethod TextDocumentDidSave where +instance PluginNotificationMethod Method_TextDocumentDidSave where -instance PluginNotificationMethod TextDocumentDidClose where +instance PluginNotificationMethod Method_TextDocumentDidClose where -instance PluginNotificationMethod WorkspaceDidChangeWatchedFiles where +instance PluginNotificationMethod Method_WorkspaceDidChangeWatchedFiles where -instance PluginNotificationMethod WorkspaceDidChangeWorkspaceFolders where +instance PluginNotificationMethod Method_WorkspaceDidChangeWorkspaceFolders where -instance PluginNotificationMethod WorkspaceDidChangeConfiguration where +instance PluginNotificationMethod Method_WorkspaceDidChangeConfiguration where -instance PluginNotificationMethod Initialized where +instance PluginNotificationMethod Method_Initialized where -- --------------------------------------------------------------------- -- | Methods which have a PluginMethod instance -data IdeMethod (m :: Method FromClient Request) = PluginRequestMethod m => IdeMethod (SMethod m) +data IdeMethod (m :: Method ClientToServer Request) = PluginRequestMethod m => IdeMethod (SMethod m) instance GEq IdeMethod where geq (IdeMethod a) (IdeMethod b) = geq a b instance GCompare IdeMethod where gcompare (IdeMethod a) (IdeMethod b) = gcompare a b -- | Methods which have a PluginMethod instance -data IdeNotification (m :: Method FromClient Notification) = PluginNotificationMethod m => IdeNotification (SMethod m) +data IdeNotification (m :: Method ClientToServer Notification) = PluginNotificationMethod m => IdeNotification (SMethod m) instance GEq IdeNotification where geq (IdeNotification a) (IdeNotification b) = geq a b instance GCompare IdeNotification where gcompare (IdeNotification a) (IdeNotification b) = gcompare a b -- | Combine handlers for the -newtype PluginHandler a (m :: Method FromClient Request) - = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either ResponseError (ResponseResult m)))) +newtype PluginHandler a (m :: Method ClientToServer Request) + = PluginHandler (PluginId -> a -> MessageParams m -> LspM Config (NonEmpty (Either ResponseError (MessageResult m)))) -newtype PluginNotificationHandler a (m :: Method FromClient Notification) +newtype PluginNotificationHandler a (m :: Method ClientToServer Notification) = PluginNotificationHandler (PluginId -> a -> VFS -> MessageParams m -> LspM Config ()) newtype PluginHandlers a = PluginHandlers (DMap IdeMethod (PluginHandler a)) @@ -751,7 +755,7 @@ instance Semigroup (PluginNotificationHandlers a) where instance Monoid (PluginNotificationHandlers a) where mempty = PluginNotificationHandlers mempty -type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config (Either ResponseError (ResponseResult m)) +type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config (Either ResponseError (MessageResult m)) type PluginNotificationMethodHandler a m = a -> VFS -> PluginId -> MessageParams m -> LspM Config () @@ -768,7 +772,7 @@ mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandl -- | Make a handler for plugins with no extra data mkPluginNotificationHandler :: PluginNotificationMethod m - => SClientMethod (m :: Method FromClient Notification) + => SClientMethod (m :: Method ClientToServer Notification) -> PluginNotificationMethodHandler ideState m -> PluginNotificationHandlers ideState mkPluginNotificationHandler m f @@ -870,9 +874,9 @@ data FormattingType = FormatText type FormattingMethod m = - ( J.HasOptions (MessageParams m) FormattingOptions - , J.HasTextDocument (MessageParams m) TextDocumentIdentifier - , ResponseResult m ~ List TextEdit + ( L.HasOptions (MessageParams m) FormattingOptions + , L.HasTextDocument (MessageParams m) TextDocumentIdentifier + , MessageResult m ~ ([TextEdit] |? Null) ) type FormattingHandler a @@ -881,11 +885,11 @@ type FormattingHandler a -> T.Text -> NormalizedFilePath -> FormattingOptions - -> LspM Config (Either ResponseError (List TextEdit)) + -> LspM Config (Either ResponseError ([TextEdit] |? Null)) mkFormattingHandlers :: forall a. FormattingHandler a -> PluginHandlers a -mkFormattingHandlers f = mkPluginHandler STextDocumentFormatting (provider STextDocumentFormatting) - <> mkPluginHandler STextDocumentRangeFormatting (provider STextDocumentRangeFormatting) +mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provider SMethod_TextDocumentFormatting) + <> mkPluginHandler SMethod_TextDocumentRangeFormatting (provider SMethod_TextDocumentRangeFormatting) where provider :: forall m. FormattingMethod m => SMethod m -> PluginMethodHandler a m provider m ide _pid params @@ -894,21 +898,21 @@ mkFormattingHandlers f = mkPluginHandler STextDocumentFormatting (provider SText case mf of Just vf -> do let typ = case m of - STextDocumentFormatting -> FormatText - STextDocumentRangeFormatting -> FormatRange (params ^. J.range) - _ -> error "mkFormattingHandlers: impossible" + SMethod_TextDocumentFormatting -> FormatText + SMethod_TextDocumentRangeFormatting -> FormatRange (params ^. L.range) + _ -> Prelude.error "mkFormattingHandlers: impossible" f ide typ (virtualFileText vf) nfp opts Nothing -> pure $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri | otherwise = pure $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri where - uri = params ^. J.textDocument . J.uri - opts = params ^. J.options + uri = params ^. L.textDocument . L.uri + opts = params ^. L.options -- --------------------------------------------------------------------- responseError :: T.Text -> ResponseError -responseError txt = ResponseError InvalidParams txt Nothing +responseError txt = ResponseError (InR ErrorCodes_InvalidParams) txt Nothing -- --------------------------------------------------------------------- @@ -928,8 +932,8 @@ 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 ^. J.textDocument . J.uri) +instance {-# OVERLAPPABLE #-} (L.HasTextDocument a doc, L.HasUri doc Uri) => HasTracing a where + traceWithSpan sp a = otSetUri sp (a ^. L.textDocument . L.uri) instance HasTracing Value instance HasTracing ExecuteCommandParams @@ -939,7 +943,7 @@ instance HasTracing DidChangeWatchedFilesParams where instance HasTracing DidChangeWorkspaceFoldersParams instance HasTracing DidChangeConfigurationParams instance HasTracing InitializeParams -instance HasTracing (Maybe InitializedParams) +instance HasTracing InitializedParams instance HasTracing WorkspaceSymbolParams where traceWithSpan sp (WorkspaceSymbolParams _ _ query) = setTag sp "query" (encodeUtf8 query) instance HasTracing CallHierarchyIncomingCallsParams @@ -953,10 +957,9 @@ pROCESS_ID :: T.Text pROCESS_ID = unsafePerformIO getPid mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [Value] -> Command -mkLspCommand plid cn title args' = Command title cmdId args +mkLspCommand plid cn title args = Command title cmdId args where cmdId = mkLspCmdId pROCESS_ID plid cn - args = List <$> args' mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text mkLspCmdId pid (PluginId plid) (CommandId cid) diff --git a/hls-plugin-api/test/Ide/PluginUtilsTest.hs b/hls-plugin-api/test/Ide/PluginUtilsTest.hs index f08821cd50..74c47d4906 100644 --- a/hls-plugin-api/test/Ide/PluginUtilsTest.hs +++ b/hls-plugin-api/test/Ide/PluginUtilsTest.hs @@ -5,13 +5,13 @@ module Ide.PluginUtilsTest ( tests ) where -import Data.Char (isPrint) -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Ide.Plugin.RangeMap as RangeMap -import Ide.PluginUtils (positionInRange, unescape) -import Language.LSP.Types (Position (..), Range (Range), UInt, - isSubrangeOf) +import Data.Char (isPrint) +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Ide.Plugin.RangeMap as RangeMap +import Ide.PluginUtils (positionInRange, unescape) +import Language.LSP.Protocol.Types (Position (..), Range (Range), + UInt, isSubrangeOf) import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck diff --git a/hls-test-utils/hls-test-utils.cabal b/hls-test-utils/hls-test-utils.cabal index e1b94070e3..7955abed48 100644 --- a/hls-test-utils/hls-test-utils.cabal +++ b/hls-test-utils/hls-test-utils.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-test-utils -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Utilities used in the tests of Haskell Language Server description: Please see the README on GitHub at @@ -41,13 +41,13 @@ library , directory , extra , filepath - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , hls-graph - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , lens - , lsp ^>=1.6.0.0 - , lsp-test ^>=0.14 - , lsp-types ^>=1.6.0.0 + , lsp ^>=2.0.0.0 + , lsp-test ^>=0.15 + , lsp-types ^>=2.0.0.1 , tasty , tasty-expected-failure , tasty-golden @@ -56,7 +56,7 @@ library , temporary , text , unordered-containers - + , row-types ghc-options: -Wall if flag(pedantic) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 82c49f1d4e..1864fdab49 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -1,15 +1,19 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} module Test.Hls ( module Test.Tasty.HUnit, module Test.Tasty, module Test.Tasty.ExpectedFailure, module Test.Hls.Util, - module Language.LSP.Types, + module Language.LSP.Protocol.Types, + module Language.LSP.Protocol.Message, module Language.LSP.Test, module Control.Monad.IO.Class, module Control.Applicative.Combinators, @@ -53,62 +57,63 @@ module Test.Hls where import Control.Applicative.Combinators -import Control.Concurrent.Async (async, cancel, wait) +import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Extra import Control.Exception.Base -import Control.Monad (guard, unless, void) -import Control.Monad.Extra (forM) +import Control.Lens.Extras (is) +import Control.Monad (guard, unless, void) +import Control.Monad.Extra (forM) import Control.Monad.IO.Class -import Data.Aeson (Result (Success), - Value (Null), fromJSON, - toJSON) -import qualified Data.Aeson as A -import Data.ByteString.Lazy (ByteString) -import Data.Default (def) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import Development.IDE (IdeState) -import Development.IDE.Main hiding (Log) -import qualified Development.IDE.Main as Ghcide -import qualified Development.IDE.Main as IDEMain -import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), - WaitForIdeRuleResult (ideResultSuccess)) -import qualified Development.IDE.Plugin.Test as Test -import Development.IDE.Types.Logger (Doc, Logger (Logger), - Pretty (pretty), - Priority (Debug), - Recorder (Recorder, logger_), - WithPriority (WithPriority, priority), - cfilter, cmapWithPrio, - makeDefaultStderrRecorder) +import Data.Aeson (Result (Success), + Value (Null), fromJSON, + toJSON) +import qualified Data.Aeson as A +import Data.ByteString.Lazy (ByteString) +import Data.Default (def) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (Proxy)) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Development.IDE (IdeState) +import Development.IDE.Main hiding (Log) +import qualified Development.IDE.Main as Ghcide +import qualified Development.IDE.Main as IDEMain +import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue), + WaitForIdeRuleResult (ideResultSuccess)) +import qualified Development.IDE.Plugin.Test as Test +import Development.IDE.Types.Logger (Doc, Logger (Logger), + Pretty (pretty), + Priority (Debug), + Recorder (Recorder, logger_), + WithPriority (WithPriority, priority), + cfilter, cmapWithPrio, + makeDefaultStderrRecorder) import Development.IDE.Types.Options import GHC.IO.Handle -import GHC.Stack (emptyCallStack) +import GHC.Stack (emptyCallStack) +import GHC.TypeLits import Ide.Types +import Language.LSP.Protocol.Capabilities +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (Null) import Language.LSP.Test -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import Language.LSP.Types.Capabilities (ClientCapabilities) -import Prelude hiding (log) -import System.Directory (getCurrentDirectory, - setCurrentDirectory) -import System.Environment (lookupEnv) +import Prelude hiding (log) +import System.Directory (getCurrentDirectory, + setCurrentDirectory) +import System.Environment (lookupEnv) import System.FilePath -import System.IO.Unsafe (unsafePerformIO) -import System.Process.Extra (createPipe) +import System.IO.Unsafe (unsafePerformIO) +import System.Process.Extra (createPipe) import System.Time.Extra import Test.Hls.Util -import Test.Tasty hiding (Timeout) +import Test.Tasty hiding (Timeout) import Test.Tasty.ExpectedFailure import Test.Tasty.Golden import Test.Tasty.HUnit import Test.Tasty.Ingredients.Rerun -import Test.Tasty.Runners (NumThreads (..)) +import Test.Tasty.Runners (NumThreads (..)) newtype Log = LogIDEMain IDEMain.Log @@ -415,7 +420,7 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurre -- | Wait for the next progress end step waitForProgressDone :: Session () waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | is _workDoneProgressEnd v-> Just () _ -> Nothing -- | Wait for all progress to be done @@ -425,7 +430,7 @@ waitForAllProgressDone = loop where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | is _workDoneProgressEnd v -> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop @@ -433,23 +438,23 @@ waitForAllProgressDone = loop -- | Wait for the build queue to be empty waitForBuildQueue :: Session Seconds waitForBuildQueue = do - let m = SCustomMethod "test" + let m = SMethod_CustomMethod (Proxy @"test") waitId <- sendRequest m (toJSON WaitForShakeQueue) (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId case resp of - ResponseMessage{_result=Right Null} -> return td + TResponseMessage{_result=Right Null} -> return td -- assume a ghcide binary lacking the WaitForShakeQueue method - _ -> return 0 + _ -> return 0 callTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b) callTestPlugin cmd = do - let cm = SCustomMethod "test" + let cm = SMethod_CustomMethod (Proxy @"test") waitId <- sendRequest cm (A.toJSON cmd) - ResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId + TResponseMessage{_result} <- skipManyTill anyMessage $ responseForId cm waitId return $ do e <- _result case A.fromJSON e of - A.Error err -> Left $ ResponseError InternalError (T.pack err) Nothing + A.Error err -> Left $ ResponseError (InR ErrorCodes_InternalError) (T.pack err) Nothing A.Success a -> pure a waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) @@ -464,7 +469,7 @@ getLastBuildKeys = callTestPlugin GetBuildKeysBuilt sendConfigurationChanged :: Value -> Session () sendConfigurationChanged config = - sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams config) + sendNotification SMethod_WorkspaceDidChangeConfiguration (DidChangeConfigurationParams config) waitForKickDone :: Session () waitForKickDone = void $ skipManyTill anyMessage nonTrivialKickDone @@ -473,14 +478,14 @@ waitForKickStart :: Session () waitForKickStart = void $ skipManyTill anyMessage nonTrivialKickStart nonTrivialKickDone :: Session () -nonTrivialKickDone = kick "done" >>= guard . not . null +nonTrivialKickDone = kick (Proxy @"kick/done") >>= guard . not . null nonTrivialKickStart :: Session () -nonTrivialKickStart = kick "start" >>= guard . not . null +nonTrivialKickStart = kick (Proxy @"kick/start") >>= guard . not . null -kick :: T.Text -> Session [FilePath] -kick msg = do - NotMess NotificationMessage{_params} <- customNotification $ "kick/" <> msg +kick :: KnownSymbol k => Proxy k -> Session [FilePath] +kick proxyMsg = do + NotMess TNotificationMessage{_params} <- customNotification proxyMsg case fromJSON _params of Success x -> return x other -> error $ "Failed to parse kick/done details: " <> show other diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index e654ee9660..d361b0a8ec 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -5,6 +5,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} module Test.Hls.Util ( -- * Test Capabilities codeActionSupportCaps @@ -54,15 +57,16 @@ import Control.Monad.IO.Class import qualified Data.Aeson as A import Data.Bool (bool) import Data.Default +import Data.Row +import Data.Proxy import Data.List.Extra (find) import qualified Data.Set as Set import qualified Data.Text as T import Development.IDE (GhcVersion (..), ghcVersion) import qualified Language.LSP.Test as Test -import Language.LSP.Types hiding (Reason (..)) -import qualified Language.LSP.Types.Capabilities as C -import Language.LSP.Types.Lens (textDocument) -import qualified Language.LSP.Types.Lens as L +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Message +import qualified Language.LSP.Protocol.Lens as L import System.Directory import System.FilePath import System.Info.Extra (isMac, isWindows) @@ -75,18 +79,18 @@ import Test.Tasty.ExpectedFailure (expectFailBecause, import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) -noLiteralCaps :: C.ClientCapabilities -noLiteralCaps = def & textDocument ?~ textDocumentCaps +noLiteralCaps :: ClientCapabilities +noLiteralCaps = def & L.textDocument ?~ textDocumentCaps where - textDocumentCaps = def { C._codeAction = Just codeActionCaps } + textDocumentCaps = def { _codeAction = Just codeActionCaps } codeActionCaps = CodeActionClientCapabilities (Just True) Nothing Nothing Nothing Nothing Nothing Nothing -codeActionSupportCaps :: C.ClientCapabilities -codeActionSupportCaps = def & textDocument ?~ textDocumentCaps +codeActionSupportCaps :: ClientCapabilities +codeActionSupportCaps = def & L.textDocument ?~ textDocumentCaps where - textDocumentCaps = def { C._codeAction = Just codeActionCaps } + textDocumentCaps = def { _codeAction = Just codeActionCaps } codeActionCaps = CodeActionClientCapabilities (Just True) (Just literalSupport) (Just True) Nothing Nothing Nothing Nothing - literalSupport = CodeActionLiteralSupport def + literalSupport = #codeActionKind .== (#valueSet .== []) -- --------------------------------------------------------------------- -- Environment specification for ignoring tests @@ -243,8 +247,8 @@ inspectCommand cars s = fromCommand <$> onMatch cars predicate err waitForDiagnosticsFrom :: TextDocumentIdentifier -> Test.Session [Diagnostic] waitForDiagnosticsFrom doc = do - diagsNot <- skipManyTill Test.anyMessage (Test.message STextDocumentPublishDiagnostics) - let (List diags) = diagsNot ^. L.params . L.diagnostics + diagsNot <- skipManyTill Test.anyMessage (Test.message SMethod_TextDocumentPublishDiagnostics) + let diags = diagsNot ^. L.params . L.diagnostics if doc ^. L.uri /= diagsNot ^. L.params . L.uri then waitForDiagnosticsFrom doc else return diags @@ -272,22 +276,22 @@ waitForDiagnosticsFromSourceWithTimeout timeout document source = do -- 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. - testId <- Test.sendRequest (SCustomMethod "test") A.Null + testId <- Test.sendRequest (SMethod_CustomMethod (Proxy @"test")) A.Null handleMessages testId where matches :: Diagnostic -> Bool matches d = d ^. L.source == Just (T.pack source) - handleMessages testId = handleDiagnostic testId <|> handleCustomMethodResponse testId <|> ignoreOthers testId + handleMessages testId = handleDiagnostic testId <|> handleMethod_CustomMethodResponse testId <|> ignoreOthers testId handleDiagnostic testId = do - diagsNot <- Test.message STextDocumentPublishDiagnostics + diagsNot <- Test.message SMethod_TextDocumentPublishDiagnostics let fileUri = diagsNot ^. L.params . L.uri - (List diags) = diagsNot ^. L.params . L.diagnostics + ( diags) = diagsNot ^. L.params . L.diagnostics res = filter matches diags if fileUri == document ^. L.uri && not (null res) then return res else handleMessages testId - handleCustomMethodResponse testId = do - _ <- Test.responseForId (SCustomMethod "test") testId + handleMethod_CustomMethodResponse testId = do + _ <- Test.responseForId (SMethod_CustomMethod (Proxy @"test")) testId pure [] ignoreOthers testId = void Test.anyMessage >> handleMessages testId diff --git a/plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal b/plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal index c346229338..384b8eaf61 100644 --- a/plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal +++ b/plugins/hls-alternate-number-format-plugin/hls-alternate-number-format-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-alternate-number-format-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Provide Alternate Number Formats plugin for Haskell Language Server description: Please see the README on GitHub at @@ -32,13 +32,13 @@ library , base >=4.12 && < 5 , containers , extra - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , ghc-boot-th , hls-graph - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , hie-compat , lens - , lsp ^>=1.6 + , lsp ^>=2.0.0.0 , mtl , regex-tdfa , syb @@ -64,7 +64,7 @@ test-suite tests , base >=4.12 && < 5 , filepath , hls-alternate-number-format-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , lsp , QuickCheck , regex-tdfa diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs index 3b90cec4fb..e64c626227 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs @@ -5,9 +5,9 @@ module Ide.Plugin.AlternateNumberFormat (descriptor, Log(..)) where import Control.Lens ((^.)) -import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Except (ExceptT) -import qualified Data.HashMap.Strict as HashMap +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Data.Map as Map import Data.Text (Text, unpack) import qualified Data.Text as T import Development.IDE (GetParsedModule (GetParsedModule), @@ -31,8 +31,9 @@ import qualified Ide.Plugin.RangeMap as RangeMap import Ide.PluginUtils (getNormalizedFilePath, handleMaybeM, pluginResponse) import Ide.Types -import Language.LSP.Types -import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types newtype Log = LogShake Shake.Log deriving Show @@ -42,7 +43,7 @@ instance Pretty Log where descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder pId = (defaultPluginDescriptor pId) - { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionHandler + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeActionHandler , pluginRules = collectLiteralsRule recorder } @@ -79,7 +80,7 @@ collectLiteralsRule recorder = define (cmapWithPrio LogShake recorder) $ \Collec litMap = RangeMap.fromList (realSrcSpanToRange . getSrcSpan) <$> lits pure ([], CLR <$> litMap <*> exts) -codeActionHandler :: PluginMethodHandler IdeState 'TextDocumentCodeAction +codeActionHandler :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = pluginResponse $ do nfp <- getNormalizedFilePath (docId ^. L.uri) CLR{..} <- requestLiterals pId state nfp @@ -90,18 +91,18 @@ codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = pluginRes literalPairs = map (\lit -> (lit, alternateFormat lit)) litsInRange -- make a code action for every literal and its' alternates (then flatten the result) actions = concatMap (\(lit, alts) -> map (mkCodeAction nfp lit enabledExtensions pragma) alts) literalPairs - pure $ List actions + pure $ InL $ actions where mkCodeAction :: NormalizedFilePath -> Literal -> [GhcExtension] -> NextPragmaInfo -> AlternateFormat -> Command |? CodeAction mkCodeAction nfp lit enabled npi af@(alt, ext) = InR CodeAction { _title = mkCodeActionTitle lit af enabled - , _kind = Just $ CodeActionUnknown "quickfix.literals.style" + , _kind = Just $ CodeActionKind_Custom "quickfix.literals.style" , _diagnostics = Nothing , _isPreferred = Nothing , _disabled = Nothing , _edit = Just $ mkWorkspaceEdit nfp edits , _command = Nothing - , _xdata = Nothing + , _data_ = Nothing } where edits = [TextEdit (realSrcSpanToRange $ getSrcSpan lit) alt] <> pragmaEdit @@ -112,7 +113,7 @@ codeActionHandler state pId (CodeActionParams _ _ docId currRange _) = pluginRes mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit mkWorkspaceEdit nfp edits = WorkspaceEdit changes Nothing Nothing where - changes = Just $ HashMap.fromList [(filePathToUri $ fromNormalizedFilePath nfp, List edits)] + changes = Just $ Map.fromList [(filePathToUri $ fromNormalizedFilePath nfp, edits)] mkCodeActionTitle :: Literal -> AlternateFormat -> [GhcExtension] -> Text mkCodeActionTitle lit (alt, ext) ghcExts diff --git a/plugins/hls-alternate-number-format-plugin/test/Main.hs b/plugins/hls-alternate-number-format-plugin/test/Main.hs index e3fa6607d5..5955247f7a 100644 --- a/plugins/hls-alternate-number-format-plugin/test/Main.hs +++ b/plugins/hls-alternate-number-format-plugin/test/Main.hs @@ -9,8 +9,8 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Ide.Plugin.AlternateNumberFormat as AlternateNumberFormat import qualified Ide.Plugin.Conversion as Conversion -import Language.LSP.Types (toEither) -import Language.LSP.Types.Lens (kind) +import Language.LSP.Protocol.Lens (kind) +import Language.LSP.Protocol.Types (toEither) import Properties.Conversion (conversions) import System.FilePath ((<.>), ()) import Test.Hls @@ -66,8 +66,8 @@ findAlternateNumberActions = pure . filter isAlternateNumberCodeAction . rights isAlternateNumberCodeAction CodeAction{_kind} = case _kind of Nothing -> False Just kind -> case kind of - CodeActionUnknown txt -> txt == "quickfix.literals.style" - _ -> False + CodeActionKind_Custom txt -> txt == "quickfix.literals.style" + _ -> False -- most helpers derived from explicit-imports-plugin Main Test file diff --git a/plugins/hls-cabal-fmt-plugin/hls-cabal-fmt-plugin.cabal b/plugins/hls-cabal-fmt-plugin/hls-cabal-fmt-plugin.cabal index d3cc9924e6..bf55ec31ad 100644 --- a/plugins/hls-cabal-fmt-plugin/hls-cabal-fmt-plugin.cabal +++ b/plugins/hls-cabal-fmt-plugin/hls-cabal-fmt-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-cabal-fmt-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Integration with the cabal-fmt code formatter description: Please see the README on GitHub at @@ -33,8 +33,8 @@ library , base >=4.12 && <5 , directory , filepath - , ghcide == 2.0.0.0 - , hls-plugin-api == 2.0.0.0 + , ghcide == 2.1.0.0 + , hls-plugin-api == 2.1.0.0 , lens , lsp-types , process @@ -55,7 +55,7 @@ test-suite tests , directory , filepath , hls-cabal-fmt-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 if flag(isolateTests) build-tool-depends: cabal-fmt:cabal-fmt ^>=0.1.6 diff --git a/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs b/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs index 9eb1f97654..807179872d 100644 --- a/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs +++ b/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs @@ -5,13 +5,14 @@ module Ide.Plugin.CabalFmt where import Control.Lens import Control.Monad.IO.Class -import qualified Data.Text as T -import Development.IDE hiding (pluginHandlers) +import qualified Data.Text as T +import Development.IDE hiding (pluginHandlers) import Ide.PluginUtils import Ide.Types -import Language.LSP.Types as J -import qualified Language.LSP.Types.Lens as J -import Prelude hiding (log) +import Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Prelude hiding (log) import System.Directory import System.Exit import System.FilePath @@ -46,7 +47,7 @@ descriptor recorder plId = provider :: Recorder (WithPriority Log) -> FormattingHandler IdeState provider recorder _ (FormatRange _) _ _ _ = do logWith recorder Info LogInvalidInvocationInfo - pure $ Left (ResponseError InvalidRequest "You cannot format a text-range using cabal-fmt." Nothing) + pure $ Left (ResponseError (InR ErrorCodes_InvalidRequest) "You cannot format a text-range using cabal-fmt." Nothing) provider recorder _ide FormatText contents nfp opts = liftIO $ do let cabalFmtArgs = [fp, "--indent", show tabularSize] x <- findExecutable "cabal-fmt" @@ -63,14 +64,14 @@ provider recorder _ide FormatText contents nfp opts = liftIO $ do case exitCode of ExitFailure code -> do log Error $ LogProcessInvocationFailure code - pure $ Left (ResponseError UnknownErrorCode "Failed to invoke cabal-fmt" Nothing) + pure $ Left (ResponseError (InR ErrorCodes_UnknownErrorCode) "Failed to invoke cabal-fmt" Nothing) ExitSuccess -> do let fmtDiff = makeDiffTextEdit contents (T.pack out) - pure $ Right fmtDiff + pure $ Right $ InL fmtDiff Nothing -> do log Error LogCabalFmtNotFound - pure $ Left (ResponseError InvalidRequest "No installation of cabal-fmt could be found. Please install it into your global environment." Nothing) + pure $ Left (ResponseError (InR ErrorCodes_InvalidRequest) "No installation of cabal-fmt could be found. Please install it into your global environment." Nothing) where fp = fromNormalizedFilePath nfp - tabularSize = opts ^. J.tabSize + tabularSize = opts ^. L.tabSize log = logWith recorder diff --git a/plugins/hls-cabal-plugin/hls-cabal-plugin.cabal b/plugins/hls-cabal-plugin/hls-cabal-plugin.cabal index e86c9f3108..e2ef02f8ec 100644 --- a/plugins/hls-cabal-plugin/hls-cabal-plugin.cabal +++ b/plugins/hls-cabal-plugin/hls-cabal-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hls-cabal-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Cabal integration plugin with Haskell Language Server description: Please see the README on GitHub at @@ -48,17 +48,17 @@ library , deepseq , directory , extra >=1.7.4 - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , hashable - , hls-plugin-api == 2.0.0.0 - , hls-graph == 2.0.0.0 - , lsp ^>=1.6.0.0 - , lsp-types ^>=1.6.0.0 + , hls-plugin-api == 2.1.0.0 + , hls-graph == 2.1.0.0 + , lsp ^>=2.0.0.0 + , lsp-types ^>=2.0.0.1 , regex-tdfa ^>=1.3.1 , stm , text , unordered-containers >=0.2.10.0 - + , containers hs-source-dirs: src default-language: Haskell2010 @@ -74,8 +74,9 @@ test-suite tests , filepath , ghcide , hls-cabal-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , lens , lsp-types , tasty-hunit , text + , row-types diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 913cb37ed6..cfa6190bb5 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -33,9 +33,10 @@ import qualified Ide.Plugin.Cabal.LicenseSuggest as LicenseSuggest import qualified Ide.Plugin.Cabal.Parse as Parse import Ide.Plugin.Config (Config) import Ide.Types +import qualified Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Types as LSP import Language.LSP.Server (LspM) -import Language.LSP.Types -import qualified Language.LSP.Types as LSP import qualified Language.LSP.VFS as VFS data Log @@ -68,30 +69,30 @@ instance Pretty Log where descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultCabalPluginDescriptor plId) { pluginRules = cabalRules recorder - , pluginHandlers = mkPluginHandler STextDocumentCodeAction licenseSuggestCodeAction + , pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCodeAction licenseSuggestCodeAction , pluginNotificationHandlers = mconcat - [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ + [ mkPluginNotificationHandler LSP.SMethod_TextDocumentDidOpen $ \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocOpened _uri addFileOfInterest recorder ide file Modified{firstOpen=True} restartCabalShakeSession (shakeExtras ide) vfs file "(opened)" - , mkPluginNotificationHandler LSP.STextDocumentDidChange $ + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ \ide vfs _ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocModified _uri addFileOfInterest recorder ide file Modified{firstOpen=False} restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" - , mkPluginNotificationHandler LSP.STextDocumentDidSave $ + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocSaved _uri addFileOfInterest recorder ide file OnDisk restartCabalShakeSession (shakeExtras ide) vfs file "(saved)" - , mkPluginNotificationHandler LSP.STextDocumentDidClose $ + , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocClosed _uri @@ -181,9 +182,9 @@ licenseSuggestCodeAction :: IdeState -> PluginId -> CodeActionParams - -> LspM Config (Either ResponseError (ResponseResult 'TextDocumentCodeAction)) -licenseSuggestCodeAction _ _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List diags}) = - pure $ Right $ List $ diags >>= (fmap InR . (LicenseSuggest.licenseErrorAction uri)) + -> LspM Config (Either LSP.ResponseError (LSP.MessageResult 'LSP.Method_TextDocumentCodeAction)) +licenseSuggestCodeAction _ _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=diags}) = + pure $ Right $ InL $ diags >>= (fmap InR . LicenseSuggest.licenseErrorAction uri) -- ---------------------------------------------------------------- -- Cabal file of Interest rules and global variable diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs index 2b077cfaf1..78ca21f236 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/Diagnostics.hs @@ -11,29 +11,30 @@ module Ide.Plugin.Cabal.Diagnostics ) where -import qualified Data.Text as T -import Development.IDE (FileDiagnostic, - ShowDiagnostic (ShowDiag)) -import Distribution.Fields (showPError, showPWarning) -import qualified Ide.Plugin.Cabal.Parse as Lib -import Ide.PluginUtils (extendNextLine) -import Language.LSP.Types (Diagnostic (..), - DiagnosticSeverity (..), - DiagnosticSource, NormalizedFilePath, - Position (Position), Range (Range), - fromNormalizedFilePath) +import qualified Data.Text as T +import Development.IDE (FileDiagnostic, + ShowDiagnostic (ShowDiag)) +import Distribution.Fields (showPError, showPWarning) +import qualified Ide.Plugin.Cabal.Parse as Lib +import Ide.PluginUtils (extendNextLine) +import Language.LSP.Protocol.Types (Diagnostic (..), + DiagnosticSeverity (..), + NormalizedFilePath, + Position (Position), + Range (Range), + fromNormalizedFilePath) -- | Produce a diagnostic from a Cabal parser error errorDiagnostic :: NormalizedFilePath -> Lib.PError -> FileDiagnostic errorDiagnostic fp err@(Lib.PError pos _) = - mkDiag fp "cabal" DsError (toBeginningOfNextLine pos) msg + mkDiag fp "cabal" DiagnosticSeverity_Error (toBeginningOfNextLine pos) msg where msg = T.pack $ showPError (fromNormalizedFilePath fp) err -- | Produce a diagnostic from a Cabal parser warning warningDiagnostic :: NormalizedFilePath -> Lib.PWarning -> FileDiagnostic warningDiagnostic fp warning@(Lib.PWarning _ pos _) = - mkDiag fp "cabal" DsWarning (toBeginningOfNextLine pos) msg + mkDiag fp "cabal" DiagnosticSeverity_Warning (toBeginningOfNextLine pos) msg where msg = T.pack $ showPWarning (fromNormalizedFilePath fp) warning @@ -64,7 +65,7 @@ positionFromCabalPosition (Lib.Position line column) = Position (fromIntegral li mkDiag :: NormalizedFilePath -- ^ Cabal file path - -> DiagnosticSource + -> T.Text -- ^ Where does the diagnostic come from? -> DiagnosticSeverity -- ^ Severity @@ -82,4 +83,6 @@ mkDiag file diagSource sev loc msg = (file, ShowDiag,) , _code = Nothing , _tags = Nothing , _relatedInformation = Nothing + , _codeDescription = Nothing + , _data_ = Nothing } diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs index 6165cfd135..5580f2b31d 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs @@ -12,11 +12,11 @@ module Ide.Plugin.Cabal.LicenseSuggest ) where -import qualified Data.HashMap.Strict as Map +import qualified Data.Map as Map import qualified Data.Text as T -import Language.LSP.Types (CodeAction (CodeAction), - CodeActionKind (CodeActionQuickFix), - Diagnostic (..), List (List), +import Language.LSP.Protocol.Types (CodeAction (CodeAction), + CodeActionKind (CodeActionKind_QuickFix), + Diagnostic (..), Position (Position), Range (Range), TextEdit (TextEdit), Uri, @@ -54,8 +54,8 @@ licenseErrorAction uri diag = -- We must also add a newline character to the replacement since the range returned by -- 'Ide.Plugin.Cabal.Diag.errorDiagnostic' ends at the beginning of the following line. tedit = [TextEdit (adjustRange $ _range diag) (suggestion <> "\n")] - edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing - in CodeAction title (Just CodeActionQuickFix) (Just $ List []) Nothing Nothing (Just edit) Nothing Nothing + edit = WorkspaceEdit (Just $ Map.singleton uri tedit) Nothing Nothing + in CodeAction title (Just CodeActionKind_QuickFix) (Just []) Nothing Nothing (Just edit) Nothing Nothing -- | License name of every license supported by cabal licenseNames :: [T.Text] diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index 9fa843347d..d67cb3b724 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -2,6 +2,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeOperators #-} module Main ( main @@ -11,11 +12,12 @@ import Control.Lens ((^.)) import Control.Monad (guard) import qualified Data.ByteString as BS import Data.Either (isRight) +import Data.Row import qualified Data.Text as Text import Ide.Plugin.Cabal import Ide.Plugin.Cabal.LicenseSuggest (licenseErrorSuggestion) import qualified Ide.Plugin.Cabal.Parse as Lib -import qualified Language.LSP.Types.Lens as J +import qualified Language.LSP.Protocol.Lens as L import System.FilePath import Test.Hls @@ -79,16 +81,16 @@ pluginTests = testGroup "Plugin Tests" unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] liftIO $ do length diags @?= 1 - unknownLicenseDiag ^. J.range @?= Range (Position 3 24) (Position 4 0) - unknownLicenseDiag ^. J.severity @?= Just DsError + unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) + unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error , runCabalTestCaseSession "Clears diagnostics" "" $ do doc <- openDoc "invalid.cabal" "cabal" diags <- waitForDiagnosticsFrom doc unknownLicenseDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] liftIO $ do length diags @?= 1 - unknownLicenseDiag ^. J.range @?= Range (Position 3 24) (Position 4 0) - unknownLicenseDiag ^. J.severity @?= Just DsError + unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) + unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error _ <- applyEdit doc $ TextEdit (Range (Position 3 20) (Position 4 0)) "BSD-3-Clause\n" newDiags <- waitForDiagnosticsFrom doc liftIO $ newDiags @?= [] @@ -105,14 +107,16 @@ pluginTests = testGroup "Plugin Tests" expectNoMoreDiagnostics 1 cabalDoc "parsing" let theRange = Range (Position 3 20) (Position 3 23) -- Invalid license - changeDoc cabalDoc [TextDocumentContentChangeEvent (Just theRange) Nothing "MIT3"] + changeDoc cabalDoc [TextDocumentContentChangeEvent $ InL $ #range .== theRange + .+ #rangeLength .== Nothing + .+ #text .== "MIT3"] cabalDiags <- waitForDiagnosticsFrom cabalDoc unknownLicenseDiag <- liftIO $ inspectDiagnostic cabalDiags ["Unknown SPDX license identifier: 'MIT3'"] expectNoMoreDiagnostics 1 hsDoc "typechecking" liftIO $ do length cabalDiags @?= 1 - unknownLicenseDiag ^. J.range @?= Range (Position 3 24) (Position 4 0) - unknownLicenseDiag ^. J.severity @?= Just DsError + unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) + unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error ] , testGroup "Code Actions" [ runCabalTestCaseSession "BSD-3" "" $ do @@ -121,8 +125,8 @@ pluginTests = testGroup "Plugin Tests" reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'BSD3'"] liftIO $ do length diags @?= 1 - reduceDiag ^. J.range @?= Range (Position 3 24) (Position 4 0) - reduceDiag ^. J.severity @?= Just DsError + reduceDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) + reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Error [codeAction] <- getLicenseAction "BSD-3-Clause" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0)) executeCodeAction codeAction contents <- documentContents doc @@ -143,8 +147,8 @@ pluginTests = testGroup "Plugin Tests" reduceDiag <- liftIO $ inspectDiagnostic diags ["Unknown SPDX license identifier: 'APAHE'"] liftIO $ do length diags @?= 1 - reduceDiag ^. J.range @?= Range (Position 3 25) (Position 4 0) - reduceDiag ^. J.severity @?= Just DsError + reduceDiag ^. L.range @?= Range (Position 3 25) (Position 4 0) + reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Error [codeAction] <- getLicenseAction "Apache-2.0" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0)) executeCodeAction codeAction contents <- documentContents doc diff --git a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal index 5e9bfc5f68..2a4d881f10 100644 --- a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-call-hierarchy-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Call hierarchy plugin for Haskell Language Server description: Please see the README on GitHub at @@ -33,9 +33,9 @@ library , base >=4.12 && <5 , containers , extra - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , hiedb - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , lens , lsp >=1.2.0.1 , sqlite-simple @@ -59,7 +59,7 @@ test-suite tests , extra , filepath , hls-call-hierarchy-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , ghcide-test-utils , lens , lsp diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs index 3e0da1afde..de5dac99d8 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy.hs @@ -3,12 +3,12 @@ module Ide.Plugin.CallHierarchy (descriptor) where import Development.IDE import qualified Ide.Plugin.CallHierarchy.Internal as X import Ide.Types -import Language.LSP.Types +import Language.LSP.Protocol.Message descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { Ide.Types.pluginHandlers = - mkPluginHandler STextDocumentPrepareCallHierarchy X.prepareCallHierarchy - <> mkPluginHandler SCallHierarchyIncomingCalls X.incomingCalls - <> mkPluginHandler SCallHierarchyOutgoingCalls X.outgoingCalls + mkPluginHandler SMethod_TextDocumentPrepareCallHierarchy X.prepareCallHierarchy + <> mkPluginHandler SMethod_CallHierarchyIncomingCalls X.incomingCalls + <> mkPluginHandler SMethod_CallHierarchyOutgoingCalls X.outgoingCalls } diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index 2b23688fd3..162ab108ce 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -33,18 +33,19 @@ import Ide.PluginUtils (getNormalizedFilePath, handleMaybe, pluginResponse, throwPluginError) import Ide.Types -import Language.LSP.Types -import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import Text.Read (readMaybe) -- | Render prepare call hierarchy request. -prepareCallHierarchy :: PluginMethodHandler IdeState TextDocumentPrepareCallHierarchy +prepareCallHierarchy :: PluginMethodHandler IdeState Method_TextDocumentPrepareCallHierarchy prepareCallHierarchy state _ param = pluginResponse $ do nfp <- getNormalizedFilePath (param ^. L.textDocument ^. L.uri) items <- liftIO $ runAction "CallHierarchy.prepareHierarchy" state $ prepareCallHierarchyItem nfp (param ^. L.position) - pure $ List <$> pure items + pure $ InL items prepareCallHierarchyItem :: NormalizedFilePath -> Position -> Action [CallHierarchyItem] prepareCallHierarchyItem nfp pos = use GetHieAst nfp >>= \case @@ -79,33 +80,33 @@ construct nfp hf (ident, contexts, ssp) | Just (RecField RecFieldDecl _) <- recFieldInfo contexts -- ignored type span - = Just $ mkCallHierarchyItem' ident SkField ssp ssp + = Just $ mkCallHierarchyItem' ident SymbolKind_Field ssp ssp | isJust (matchBindInfo contexts) && isNothing (valBindInfo contexts) - = Just $ mkCallHierarchyItem' ident SkFunction ssp ssp + = Just $ mkCallHierarchyItem' ident SymbolKind_Function ssp ssp | Just ctx <- valBindInfo contexts = Just $ case ctx of - ValBind _ _ span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp + ValBind _ _ span -> mkCallHierarchyItem' ident SymbolKind_Function (renderSpan span) ssp _ -> mkCallHierarchyItem' ident skUnknown ssp ssp | Just ctx <- declInfo contexts = Just $ case ctx of - Decl ClassDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp - Decl ConDec span -> mkCallHierarchyItem' ident SkConstructor (renderSpan span) ssp - Decl DataDec span -> mkCallHierarchyItem' ident SkStruct (renderSpan span) ssp - Decl FamDec span -> mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp - Decl InstDec span -> mkCallHierarchyItem' ident SkInterface (renderSpan span) ssp - Decl SynDec span -> mkCallHierarchyItem' ident SkTypeParameter (renderSpan span) ssp + Decl ClassDec span -> mkCallHierarchyItem' ident SymbolKind_Interface (renderSpan span) ssp + Decl ConDec span -> mkCallHierarchyItem' ident SymbolKind_Constructor (renderSpan span) ssp + Decl DataDec span -> mkCallHierarchyItem' ident SymbolKind_Struct (renderSpan span) ssp + Decl FamDec span -> mkCallHierarchyItem' ident SymbolKind_Function (renderSpan span) ssp + Decl InstDec span -> mkCallHierarchyItem' ident SymbolKind_Interface (renderSpan span) ssp + Decl SynDec span -> mkCallHierarchyItem' ident SymbolKind_TypeParameter (renderSpan span) ssp _ -> mkCallHierarchyItem' ident skUnknown ssp ssp | Just (ClassTyDecl span) <- classTyDeclInfo contexts - = Just $ mkCallHierarchyItem' ident SkMethod (renderSpan span) ssp + = Just $ mkCallHierarchyItem' ident SymbolKind_Method (renderSpan span) ssp | Just (PatternBind _ _ span) <- patternBindInfo contexts - = Just $ mkCallHierarchyItem' ident SkFunction (renderSpan span) ssp + = Just $ mkCallHierarchyItem' ident SymbolKind_Function (renderSpan span) ssp - | Just _ <- useInfo contexts = Just $ mkCallHierarchyItem' ident SkInterface ssp ssp + | Just _ <- useInfo contexts = Just $ mkCallHierarchyItem' ident SymbolKind_Interface ssp ssp | Just _ <- tyDeclInfo contexts = renderTyDecl @@ -115,7 +116,9 @@ construct nfp hf (ident, contexts, ssp) renderSpan _ = ssp -- https://github.com/haskell/lsp/blob/e11b7c09658610f6d815d04db08a64e7cf6b4467/lsp-types/src/Language/LSP/Types/DocumentSymbol.hs#L97 - skUnknown = SkUnknown 27 -- 27 is the first unused number while ToJSON + -- There is no longer an unknown symbol, thus using SymbolKind_Function + -- as this is the call-hierarchy plugin + skUnknown = SymbolKind_Function mkCallHierarchyItem' = mkCallHierarchyItem nfp @@ -165,15 +168,12 @@ mkSymbol = \case -------------- Incoming calls and outgoing calls --------------------- ---------------------------------------------------------------------- -deriving instance Ord SymbolKind -deriving instance Ord SymbolTag -deriving instance Ord CallHierarchyItem #if !MIN_VERSION_aeson(1,5,2) deriving instance Ord Value #endif -- | Render incoming calls request. -incomingCalls :: PluginMethodHandler IdeState CallHierarchyIncomingCalls +incomingCalls :: PluginMethodHandler IdeState Method_CallHierarchyIncomingCalls incomingCalls state pluginId param = pluginResponse $ do calls <- liftIO $ runAction "CallHierarchy.incomingCalls" state @@ -182,13 +182,13 @@ incomingCalls state pluginId param = pluginResponse $ do Q.incomingCalls mkCallHierarchyIncomingCall (mergeCalls CallHierarchyIncomingCall L.from) - pure $ Just $ List calls + pure $ InL $ calls where mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall) mkCallHierarchyIncomingCall = mkCallHierarchyCall CallHierarchyIncomingCall -- | Render outgoing calls request. -outgoingCalls :: PluginMethodHandler IdeState CallHierarchyOutgoingCalls +outgoingCalls :: PluginMethodHandler IdeState Method_CallHierarchyOutgoingCalls outgoingCalls state pluginId param = pluginResponse $ do calls <- liftIO $ runAction "CallHierarchy.outgoingCalls" state @@ -197,11 +197,10 @@ outgoingCalls state pluginId param = pluginResponse $ do Q.outgoingCalls mkCallHierarchyOutgoingCall (mergeCalls CallHierarchyOutgoingCall L.to) - pure $ Just $ List calls + pure $ InL $ calls where mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall) mkCallHierarchyOutgoingCall = mkCallHierarchyCall CallHierarchyOutgoingCall - -- | Merge calls from the same place mergeCalls constructor target = concatMap merge @@ -210,10 +209,10 @@ mergeCalls constructor target = where merge [] = [] merge calls@(call:_) = - let ranges = concatMap ((\(List x) -> x) . (^. L.fromRanges)) calls - in [constructor (call ^. target) (List ranges)] + let ranges = concatMap (^. L.fromRanges) calls + in [constructor (call ^. target) ranges] -mkCallHierarchyCall :: (CallHierarchyItem -> List Range -> a) -> Vertex -> Action (Maybe a) +mkCallHierarchyCall :: (CallHierarchyItem -> [Range] -> a) -> Vertex -> Action (Maybe a) mkCallHierarchyCall mk v@Vertex{..} = do let pos = Position (fromIntegral $ sl - 1) (fromIntegral $ sc - 1) nfp = toNormalizedFilePath' hieSrc @@ -225,7 +224,7 @@ mkCallHierarchyCall mk v@Vertex{..} = do prepareCallHierarchyItem nfp pos >>= \case - [item] -> pure $ Just $ mk item (List [range]) + [item] -> pure $ Just $ mk item [range] _ -> do ShakeExtras{withHieDb} <- getShakeExtras sps <- liftIO (withHieDb (`Q.getSymbolPosition` v)) @@ -235,7 +234,7 @@ mkCallHierarchyCall mk v@Vertex{..} = do nfp (Position (fromIntegral $ psl x - 1) (fromIntegral $ psc x - 1)) case items of - [item] -> pure $ Just $ mk item (List [range]) + [item] -> pure $ Just $ mk item [range] _ -> pure Nothing _ -> pure Nothing @@ -259,10 +258,10 @@ queryCalls item queryFunc makeFunc merge | otherwise = pure mempty where uri = item ^. L.uri - xdata = item ^. L.xdata + xdata = item ^. L.data_ pos = item ^. (L.selectionRange . L.start) - getSymbol nfp = case item ^. L.xdata of + getSymbol nfp = case item ^. L.data_ of Just xdata -> case fromJSON xdata of A.Success (symbolStr :: String) -> maybe (getSymbolFromAst nfp pos) (pure . pure) $ readMaybe symbolStr A.Error _ -> getSymbolFromAst nfp pos diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index d1b455c741..678b970e57 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -5,22 +5,22 @@ module Main (main) where -import Control.Lens (set, (^.)) +import Control.Lens (set, (^.)) import Control.Monad.Extra import Data.Aeson -import Data.Functor ((<&>)) -import Data.List (sort, tails) -import qualified Data.Map as M -import qualified Data.Text as T +import Data.Functor ((<&>)) +import Data.List (sort, tails) +import qualified Data.Map as M +import qualified Data.Text as T import Development.IDE.Test import Ide.Plugin.CallHierarchy -import qualified Language.LSP.Test as Test -import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Test as Test import System.Directory.Extra import System.FilePath import qualified System.IO.Extra import Test.Hls -import Test.Hls.Util (withCanonicalTempDir) +import Test.Hls.Util (withCanonicalTempDir) plugin :: PluginTestDescriptor () plugin = mkPluginTestDescriptor' descriptor "call-hierarchy" @@ -41,68 +41,68 @@ prepareCallHierarchyTests = let contents = T.unlines ["a=3"] range = mkRange 0 0 0 3 selRange = mkRange 0 0 0 1 - expected = mkCallHierarchyItemV "a" SkFunction range selRange + expected = mkCallHierarchyItemV "a" SymbolKind_Function range selRange oneCaseWithCreate contents 0 0 expected , testCase "function" $ do let contents = T.unlines ["a=(+)"] range = mkRange 0 0 0 5 selRange = mkRange 0 0 0 1 - expected = mkCallHierarchyItemV "a" SkFunction range selRange + expected = mkCallHierarchyItemV "a" SymbolKind_Function range selRange oneCaseWithCreate contents 0 0 expected , testCase "datatype" $ do let contents = T.unlines ["data A=A"] range = mkRange 0 0 0 8 selRange = mkRange 0 5 0 6 - expected = mkCallHierarchyItemT "A" SkStruct range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Struct range selRange oneCaseWithCreate contents 0 5 expected , testCase "data constructor" $ do let contents = T.unlines ["data A=A"] range = mkRange 0 7 0 8 selRange = mkRange 0 7 0 8 - expected = mkCallHierarchyItemC "A" SkConstructor range selRange + expected = mkCallHierarchyItemC "A" SymbolKind_Constructor range selRange oneCaseWithCreate contents 0 7 expected -- , testCase "record" $ do -- let contents = T.unlines ["data A=A{a::Int}"] -- range = mkRange 0 9 0 10 -- selRange = mkRange 0 9 0 10 --- expected = mkCallHierarchyItemV "a" SkField range selRange +-- expected = mkCallHierarchyItemV "a" SymbolKind_Field range selRange -- oneCaseWithCreate contents 0 9 expected , testCase "type operator" $ do let contents = T.unlines ["{-# LANGUAGE TypeOperators #-}", "type (><)=Maybe"] range = mkRange 1 0 1 15 selRange = mkRange 1 5 1 9 - expected = mkCallHierarchyItemT "><" SkTypeParameter range selRange + expected = mkCallHierarchyItemT "><" SymbolKind_TypeParameter range selRange oneCaseWithCreate contents 1 5 expected , testCase "type class" $ do let contents = T.unlines ["class A a where a :: a -> Int"] range = mkRange 0 0 0 29 selRange = mkRange 0 6 0 7 - expected = mkCallHierarchyItemT "A" SkInterface range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Interface range selRange oneCaseWithCreate contents 0 6 expected , testCase "type class method" $ do let contents = T.unlines ["class A a where a :: a -> Int"] range = mkRange 0 16 0 29 selRange = mkRange 0 16 0 17 - expected = mkCallHierarchyItemV "a" SkMethod range selRange + expected = mkCallHierarchyItemV "a" SymbolKind_Method range selRange oneCaseWithCreate contents 0 16 expected , testCase "type class instance" $ do let contents = T.unlines ["class A a where", "instance A () where"] range = mkRange 1 9 1 10 selRange = mkRange 1 9 1 10 - expected = mkCallHierarchyItemT "A" SkInterface range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Interface range selRange oneCaseWithCreate contents 1 9 expected , testGroup "type family" [ testCase "1" $ do let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "type family A"] range = mkRange 1 0 1 13 selRange = mkRange 1 12 1 13 - expected = mkCallHierarchyItemT "A" SkFunction range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange oneCaseWithCreate contents 1 12 expected , testCase "2" $ do let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "type family A a"] range = mkRange 1 0 1 15 selRange = mkRange 1 12 1 13 - expected = mkCallHierarchyItemT "A" SkFunction range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange oneCaseWithCreate contents 1 12 expected ] , testCase "type family instance" $ do @@ -113,20 +113,20 @@ prepareCallHierarchyTests = ] range = mkRange 2 14 2 23 selRange = mkRange 2 14 2 15 - expected = mkCallHierarchyItemT "A" SkInterface range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Interface range selRange oneCaseWithCreate contents 2 14 expected , testGroup "data family" [ testCase "1" $ do let contents = T.unlines ["{-# LANGUAGE TypeFamilies #-}", "data family A"] range = mkRange 1 0 1 11 selRange = mkRange 1 12 1 13 - expected = mkCallHierarchyItemT "A" SkFunction range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange oneCaseWithCreate contents 1 12 expected , testCase "2" $ do let contents = T.unlines [ "{-# LANGUAGE TypeFamilies #-}" , "data family A a"] range = mkRange 1 0 1 11 selRange = mkRange 1 12 1 13 - expected = mkCallHierarchyItemT "A" SkFunction range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Function range selRange oneCaseWithCreate contents 1 12 expected ] , testCase "data family instance" $ do @@ -137,25 +137,25 @@ prepareCallHierarchyTests = ] range = mkRange 2 14 2 24 selRange = mkRange 2 14 2 15 - expected = mkCallHierarchyItemT "A" SkInterface range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_Interface range selRange oneCaseWithCreate contents 2 14 expected , testCase "pattern" $ do let contents = T.unlines ["Just x = Just 3"] range = mkRange 0 0 0 15 selRange = mkRange 0 5 0 6 - expected = mkCallHierarchyItemV "x" SkFunction range selRange + expected = mkCallHierarchyItemV "x" SymbolKind_Function range selRange oneCaseWithCreate contents 0 5 expected , testCase "pattern with type signature" $ do let contents = T.unlines ["{-# LANGUAGE ScopedTypeVariables #-}", "a :: () = ()"] range = mkRange 1 0 1 12 selRange = mkRange 1 0 1 1 - expected = mkCallHierarchyItemV "a" SkFunction range selRange + expected = mkCallHierarchyItemV "a" SymbolKind_Function range selRange oneCaseWithCreate contents 1 0 expected , testCase "type synonym" $ do let contents = T.unlines ["type A=Bool"] range = mkRange 0 0 0 11 selRange = mkRange 0 5 0 6 - expected = mkCallHierarchyItemT "A" SkTypeParameter range selRange + expected = mkCallHierarchyItemT "A" SymbolKind_TypeParameter range selRange oneCaseWithCreate contents 0 5 expected , testCase "GADT" $ do let contents = T.unlines @@ -164,20 +164,20 @@ prepareCallHierarchyTests = ] range = mkRange 1 13 1 26 selRange = mkRange 1 13 1 14 - expected = mkCallHierarchyItemC "A" SkConstructor range selRange + expected = mkCallHierarchyItemC "A" SymbolKind_Constructor range selRange oneCaseWithCreate contents 1 13 expected , testGroup "type signature" [ testCase "next line" $ do let contents = T.unlines ["a::Int", "a=3"] range = mkRange 1 0 1 3 selRange = mkRange 1 0 1 1 - expected = mkCallHierarchyItemV "a" SkFunction range selRange + expected = mkCallHierarchyItemV "a" SymbolKind_Function range selRange oneCaseWithCreate contents 0 0 expected , testCase "multi functions" $ do let contents = T.unlines [ "a,b::Int", "a=3", "b=4"] range = mkRange 2 0 2 3 selRange = mkRange 2 0 2 1 - expected = mkCallHierarchyItemV "b" SkFunction range selRange + expected = mkCallHierarchyItemV "b" SymbolKind_Function range selRange oneCaseWithCreate contents 0 2 expected ] , testCase "multi pattern" $ do @@ -187,7 +187,7 @@ prepareCallHierarchyTests = ] range = mkRange 1 0 1 1 selRange = mkRange 1 0 1 1 - expected = mkCallHierarchyItemV "f" SkFunction range selRange + expected = mkCallHierarchyItemV "f" SymbolKind_Function range selRange oneCaseWithCreate contents 1 0 expected ] @@ -201,11 +201,11 @@ incomingCallsTests = doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] waitForIndex (testDataDir "A.hs") [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) - let expected = [CallHierarchyIncomingCall item (List [mkRange 1 2 1 3])] + let expected = [CallHierarchyIncomingCall item [mkRange 1 2 1 3]] Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 0) >>= \case [item] -> do - let itemNoData = set L.xdata Nothing item + let itemNoData = set L.data_ Nothing item Test.incomingCalls (mkIncomingCallsParam itemNoData) >>= \res -> liftIO $ sort expected @=? sort res _ -> liftIO $ assertFailure "Not exactly one element" @@ -326,11 +326,11 @@ outgoingCallsTests = doc <- createDoc "A.hs" "haskell" $ T.unlines ["a=3", "b=a"] waitForIndex (dir "A.hs") [item] <- Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 0 1) - let expected = [CallHierarchyOutgoingCall item (List [mkRange 1 2 1 3])] + let expected = [CallHierarchyOutgoingCall item [mkRange 1 2 1 3]] Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc 1 0) >>= \case [item] -> do - let itemNoData = set L.xdata Nothing item + let itemNoData = set L.data_ Nothing item Test.outgoingCalls (mkOutgoingCallsParam itemNoData) >>= \res -> liftIO $ sort expected @=? sort res _ -> liftIO $ assertFailure "Not exactly one element" @@ -421,8 +421,6 @@ outgoingCallsTests = ] ] -deriving instance Ord CallHierarchyIncomingCall -deriving instance Ord CallHierarchyOutgoingCall incomingCallTestCase :: T.Text -> Int -> Int -> [(Int, Int)] -> [Range] -> Assertion incomingCallTestCase contents queryX queryY positions ranges = withCanonicalTempDir $ \dir -> @@ -530,10 +528,10 @@ mkCallHierarchyItemT = mkCallHierarchyItem' "t" mkCallHierarchyItemV = mkCallHierarchyItem' "v" mkCallHierarchyIncomingCall :: (CallHierarchyItem, Range) -> CallHierarchyIncomingCall -mkCallHierarchyIncomingCall (item, range) = CallHierarchyIncomingCall item (List [range]) +mkCallHierarchyIncomingCall (item, range) = CallHierarchyIncomingCall item [range] mkCallHierarchyOutgoingCall :: (CallHierarchyItem, Range) -> CallHierarchyOutgoingCall -mkCallHierarchyOutgoingCall (item, range) = CallHierarchyOutgoingCall item (List [range]) +mkCallHierarchyOutgoingCall (item, range) = CallHierarchyOutgoingCall item [range] testDataDir :: FilePath testDataDir = "test" "testdata" diff --git a/plugins/hls-change-type-signature-plugin/hls-change-type-signature-plugin.cabal b/plugins/hls-change-type-signature-plugin/hls-change-type-signature-plugin.cabal index 9fea7be4f6..8e30a0a9c2 100644 --- a/plugins/hls-change-type-signature-plugin/hls-change-type-signature-plugin.cabal +++ b/plugins/hls-change-type-signature-plugin/hls-change-type-signature-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-change-type-signature-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Change a declarations type signature with a Code Action description: Please see the README on GitHub at @@ -28,15 +28,15 @@ library hs-source-dirs: src build-depends: , base >=4.12 && < 5 - , ghcide == 2.0.0.0 - , hls-plugin-api == 2.0.0.0 + , ghcide == 2.1.0.0 + , hls-plugin-api == 2.1.0.0 , lsp-types , regex-tdfa , syb , text , transformers , unordered-containers - + , containers ghc-options: -Wall default-language: Haskell2010 default-extensions: @@ -61,7 +61,7 @@ test-suite tests , base >=4.12 && < 5 , filepath , hls-change-type-signature-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , lsp , QuickCheck , regex-tdfa diff --git a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs index 5374761a14..5e28cf34d7 100644 --- a/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs +++ b/plugins/hls-change-type-signature-plugin/src/Ide/Plugin/ChangeTypeSignature.hs @@ -10,7 +10,7 @@ import Control.Monad (guard) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (ExceptT) import Data.Foldable (asum) -import qualified Data.HashMap.Strict as Map +import qualified Data.Map as Map import Data.Maybe (mapMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -28,18 +28,19 @@ import Ide.Types (PluginDescriptor (..), PluginMethodHandler, defaultPluginDescriptor, mkPluginHandler) -import Language.LSP.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import Text.Regex.TDFA ((=~)) descriptor :: PluginId -> PluginDescriptor IdeState -descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler STextDocumentCodeAction (codeActionHandler plId) } +descriptor plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeActionHandler plId) } -codeActionHandler :: PluginId -> PluginMethodHandler IdeState 'TextDocumentCodeAction -codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext (List diags) _} = pluginResponse $ do +codeActionHandler :: PluginId -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction +codeActionHandler plId ideState _ CodeActionParams {_textDocument = TextDocumentIdentifier uri, _context = CodeActionContext diags _ _} = pluginResponse $ do nfp <- getNormalizedFilePath uri decls <- getDecls plId ideState nfp let actions = mapMaybe (generateAction plId uri decls) diags - pure $ List actions + pure $ InL actions getDecls :: MonadIO m => PluginId -> IdeState -> NormalizedFilePath -> ExceptT String m [LHsDecl GhcPs] getDecls (PluginId changeTypeSignatureId) state = handleMaybeM "Could not get Parsed Module" @@ -146,15 +147,16 @@ stripSignature (T.filter (/= '\n') -> sig) = if T.isInfixOf " => " sig else T.strip $ snd $ T.breakOnEnd " :: " sig changeSigToCodeAction :: PluginId -> Uri -> ChangeSignature -> Command |? CodeAction -changeSigToCodeAction (PluginId changeTypeSignatureId) uri ChangeSignature{..} = InR CodeAction { _title = mkChangeSigTitle declName actualType - , _kind = Just (CodeActionUnknown ("quickfix." <> changeTypeSignatureId)) - , _diagnostics = Just $ List [diagnostic] - , _isPreferred = Nothing - , _disabled = Nothing - , _edit = Just $ mkChangeSigEdit uri declSrcSpan (mkNewSignature declName actualType) - , _command = Nothing - , _xdata = Nothing - } +changeSigToCodeAction (PluginId changeTypeSignatureId) uri ChangeSignature{..} = + InR CodeAction { _title = mkChangeSigTitle declName actualType + , _kind = Just (CodeActionKind_Custom ("quickfix." <> changeTypeSignatureId)) + , _diagnostics = Just [diagnostic] + , _isPreferred = Nothing + , _disabled = Nothing + , _edit = Just $ mkChangeSigEdit uri declSrcSpan (mkNewSignature declName actualType) + , _command = Nothing + , _data_ = Nothing + } mkChangeSigTitle :: Text -> Text -> Text mkChangeSigTitle declName actualType = "Change signature for ‘" <> declName <> "’ to: " <> actualType @@ -162,7 +164,7 @@ mkChangeSigTitle declName actualType = "Change signature for ‘" <> declName <> mkChangeSigEdit :: Uri -> RealSrcSpan -> Text -> WorkspaceEdit mkChangeSigEdit uri ss replacement = let txtEdit = TextEdit (realSrcSpanToRange ss) replacement - changes = Just $ Map.singleton uri (List [txtEdit]) + changes = Just $ Map.singleton uri [txtEdit] in WorkspaceEdit changes Nothing Nothing mkNewSignature :: Text -> Text -> Text diff --git a/plugins/hls-class-plugin/hls-class-plugin.cabal b/plugins/hls-class-plugin/hls-class-plugin.cabal index 93941d7c3a..bf1b48d9e8 100644 --- a/plugins/hls-class-plugin/hls-class-plugin.cabal +++ b/plugins/hls-class-plugin/hls-class-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-class-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Class/instance management plugin for Haskell Language Server @@ -39,10 +39,10 @@ library , deepseq , extra , ghc - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , ghc-boot-th , hls-graph - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , lens , lsp , text @@ -74,7 +74,8 @@ test-suite tests , ghcide , hls-class-plugin , hls-plugin-api - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , lens , lsp-types + , row-types , text diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index 5eed650a17..418f55a590 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs @@ -1,18 +1,18 @@ module Ide.Plugin.Class (descriptor, Log(..)) where -import Development.IDE (IdeState, Recorder, WithPriority) +import Development.IDE (IdeState, Recorder, + WithPriority) import Ide.Plugin.Class.CodeAction import Ide.Plugin.Class.CodeLens import Ide.Plugin.Class.Types import Ide.Types -import Language.LSP.Types - +import Language.LSP.Protocol.Message descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginCommands = commands plId , pluginRules = rules recorder - , pluginHandlers = mkPluginHandler STextDocumentCodeAction (codeAction recorder) - <> mkPluginHandler STextDocumentCodeLens codeLens + , pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (codeAction recorder) + <> mkPluginHandler SMethod_TextDocumentCodeLens codeLens } commands :: PluginId -> [PluginCommand IdeState] diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs index 3af9ae8ce2..3ec194f762 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -34,15 +34,16 @@ import Ide.Plugin.Class.Utils import qualified Ide.Plugin.Config import Ide.PluginUtils import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (Null) import Language.LSP.Server -import Language.LSP.Types -import qualified Language.LSP.Types.Lens as J addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do caps <- getClientCapabilities pluginResponse $ do - nfp <- getNormalizedFilePath (verTxtDocId ^. J.uri) + nfp <- getNormalizedFilePath (verTxtDocId ^. L.uri) pm <- handleMaybeM "Unable to GetParsedModule" $ liftIO $ runAction "classplugin.addMethodPlaceholders.GetParsedModule" state @@ -60,17 +61,17 @@ addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do then mergeEdit (workspaceEdit caps old new) pragmaInsertion else workspaceEdit caps old new - void $ lift $ sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + void $ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) pure Null where toTextDocumentEdit edit = - TextDocumentEdit verTxtDocId (List [InL edit]) + TextDocumentEdit (verTxtDocId ^.re _versionedTextDocumentIdentifier) [InL edit] mergeEdit :: WorkspaceEdit -> [TextEdit] -> WorkspaceEdit mergeEdit WorkspaceEdit{..} edits = WorkspaceEdit { _documentChanges = - (\(List x) -> List $ x ++ map (InL . toTextDocumentEdit) edits) + (\x -> x ++ map (InL . toTextDocumentEdit) edits) <$> _documentChanges , .. } @@ -81,17 +82,17 @@ addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do -- | -- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is -- sensitive to the format of diagnostic messages from GHC. -codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState TextDocumentCodeAction +codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginResponse $ do verTxtDocId <- lift $ getVersionedTextDoc docId - nfp <- getNormalizedFilePath (verTxtDocId ^. J.uri) + nfp <- getNormalizedFilePath (verTxtDocId ^. L.uri) actions <- join <$> mapM (mkActions nfp verTxtDocId) methodDiags - pure $ List actions + pure $ InL actions where - List diags = context ^. J.diagnostics + diags = context ^. L.diagnostics - ghcDiags = filter (\d -> d ^. J.source == Just "typecheck") diags - methodDiags = filter (\d -> isClassMethodWarning (d ^. J.message)) ghcDiags + ghcDiags = filter (\d -> d ^. L.source == Just "typecheck") diags + methodDiags = filter (\d -> isClassMethodWarning (d ^. L.message)) ghcDiags mkActions :: NormalizedFilePath @@ -104,8 +105,8 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe . runAction "classplugin.findClassIdentifier.GetHieAst" state $ useWithStale GetHieAst docPath instancePosition <- handleMaybe "No range" $ - fromCurrentRange pmap range ^? _Just . J.start - & fmap (J.character -~ 1) + fromCurrentRange pmap range ^? _Just . L.start + & fmap (L.character -~ 1) ident <- findClassIdentifier ast instancePosition cls <- findClassFromIdentifier docPath ident InstanceBindTypeSigsResult sigs <- handleMaybeM "Unable to GetInstanceBindTypeSigs" @@ -121,7 +122,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe $ fmap (second (filter (\(bind, _) -> bind `notElem` implemented))) $ mkMethodGroups range sigs cls where - range = diag ^. J.range + range = diag ^. L.range mkMethodGroups :: Range -> [InstanceBindTypeSig] -> Class -> [MethodGroup] mkMethodGroups range sigs cls = minimalDef <> [allClassMethods] @@ -142,15 +143,16 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe title = "Add placeholders for " <> name titleWithSig = title <> " with signature(s)" + mkCmdParams :: [(T.Text, T.Text)] -> Bool -> [Value] mkCmdParams methodGroup withSig = - [toJSON (AddMinimalMethodsParams verTxtDocId range (List methodGroup) withSig)] + [toJSON (AddMinimalMethodsParams verTxtDocId range methodGroup withSig)] mkCodeAction title cmd = InR $ CodeAction title - (Just CodeActionQuickFix) - (Just (List [])) + (Just CodeActionKind_QuickFix) + (Just []) Nothing Nothing Nothing diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs index 1b3b4f10f3..fe8af4b812 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -19,11 +19,12 @@ import Ide.Plugin.Class.Types import Ide.Plugin.Class.Utils import Ide.PluginUtils import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (Null) import Language.LSP.Server (sendRequest) -import Language.LSP.Types -import qualified Language.LSP.Types.Lens as J -codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens +codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens codeLens state plId CodeLensParams{..} = pluginResponse $ do nfp <- getNormalizedFilePath uri (tmr, _) <- handleMaybeM "Unable to typecheck" @@ -60,9 +61,9 @@ codeLens state plId CodeLensParams{..} = pluginResponse $ do $ makeEdit range title mp codeLens = makeLens <$> mapMaybe getRangeWithSig targetSigs - pure $ List codeLens + pure $ InL codeLens where - uri = _textDocument ^. J.uri + uri = _textDocument ^. L.uri -- Match Binds with their signatures -- We try to give every `InstanceBindTypeSig` a `SrcSpan`, @@ -121,7 +122,7 @@ codeLens state plId CodeLensParams{..} = pluginResponse $ do workspaceEdit pragmaInsertion edits = WorkspaceEdit - (pure [(uri, List $ edits ++ pragmaInsertion)]) + (pure [(uri, edits ++ pragmaInsertion)]) Nothing Nothing @@ -132,8 +133,8 @@ codeLens state plId CodeLensParams{..} = pluginResponse $ do makeEdit :: Range -> T.Text -> PositionMapping -> [TextEdit] makeEdit range bind mp = - let startPos = range ^. J.start - insertChar = startPos ^. J.character + let startPos = range ^. L.start + insertChar = startPos ^. L.character insertRange = Range startPos startPos in case toCurrentRange mp insertRange of Just rg -> [TextEdit rg (bind <> "\n" <> T.replicate (fromIntegral insertChar) " ")] @@ -141,5 +142,5 @@ codeLens state plId CodeLensParams{..} = pluginResponse $ do codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit codeLensCommandHandler _ wedit = do - _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) return $ Right Null diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs index dc2128397d..90ccc6b578 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs @@ -12,7 +12,6 @@ import Ide.Plugin.Class.Types import Ide.Plugin.Class.Utils import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers -import Language.LSP.Types #if MIN_VERSION_ghc(9,2,0) import Data.Either.Extra (eitherToMaybe) @@ -22,13 +21,14 @@ import Control.Monad (foldM) import qualified Data.Map.Strict as Map import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs) import Language.Haskell.GHC.ExactPrint.Utils (rs) +import Language.LSP.Protocol.Types (Range) #endif makeEditText :: Monad m => ParsedModule -> DynFlags -> AddMinimalMethodsParams -> MaybeT m (T.Text, T.Text) -- addMethodDecls :: ParsedSource -> [(LHsDecl GhcPs, LHsDecl GhcPs)] -> Range -> Bool -> TransformT Identity (Located HsModule) #if MIN_VERSION_ghc(9,2,0) makeEditText pm df AddMinimalMethodsParams{..} = do - List mDecls <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup + mDecls <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup let ps = makeDeltaAst $ pm_parsed_source pm old = T.pack $ exactPrint ps (ps', _, _) = runTransform (addMethodDecls ps mDecls range withSig) @@ -76,7 +76,7 @@ addMethodDecls ps mDecls range withSig #else makeEditText pm df AddMinimalMethodsParams{..} = do - List (unzip -> (mAnns, mDecls)) <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup + (unzip -> (mAnns, mDecls)) <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup let ps = pm_parsed_source pm anns = relativiseApiAnns ps (pm_annotations pm) old = T.pack $ exactPrint ps anns diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs index ac1a4e02b3..220682487c 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -20,7 +20,7 @@ import Development.IDE.Graph.Classes import GHC.Generics import Ide.Plugin.Class.Utils import Ide.Types -import Language.LSP.Types (VersionedTextDocumentIdentifier) +import Language.LSP.Protocol.Types (VersionedTextDocumentIdentifier) typeLensCommandId :: CommandId typeLensCommandId = "classplugin.typelens" @@ -35,7 +35,7 @@ defaultIndent = 2 data AddMinimalMethodsParams = AddMinimalMethodsParams { verTxtDocId :: VersionedTextDocumentIdentifier , range :: Range - , methodGroup :: List (T.Text, T.Text) + , methodGroup :: [(T.Text, T.Text)] -- ^ (name text, signature text) , withSig :: Bool } diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs index 31dbd021a2..98aba3cfc7 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs @@ -14,7 +14,7 @@ import Development.IDE.GHC.Compat.Util import Development.IDE.Spans.Pragmas (getNextPragmaInfo, insertNewPragma) import Ide.PluginUtils -import Language.LSP.Types +import Language.LSP.Protocol.Types -- | All instance bindings are started with `$c` bindingPrefix :: IsString s => s diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index 586b117cb9..7b21c3da21 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} @@ -9,12 +10,15 @@ module Main ( main ) where -import Control.Lens (Prism', prism', (^.), (^..), (^?)) -import Control.Monad (void) +import Control.Lens (Prism', prism', (^.), (^..), + (^?)) +import Control.Monad (void) import Data.Maybe -import qualified Data.Text as T -import qualified Ide.Plugin.Class as Class -import qualified Language.LSP.Types.Lens as J +import Data.Row ((.==)) +import qualified Data.Text as T +import qualified Ide.Plugin.Class as Class +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message import System.FilePath import Test.Hls @@ -78,19 +82,17 @@ codeActionTests = testGroup ] , testCase "Update text document version" $ runSessionWithServer classPlugin testDataDir $ do doc <- createDoc "Version.hs" "haskell" "module Version where" - ver1 <- (^.J.version) <$> getVersionedDoc doc - liftIO $ ver1 @?= Just 0 + ver1 <- (^. L.version) <$> getVersionedDoc doc + liftIO $ ver1 @?= 0 -- Change the doc to ensure the version is not 0 changeDoc doc - [ TextDocumentContentChangeEvent - Nothing - Nothing - (T.unlines ["module Version where", "data A a = A a", "instance Functor A where"]) + [ TextDocumentContentChangeEvent . InR . (.==) #text $ + T.unlines ["module Version where", "data A a = A a", "instance Functor A where"] ] - ver2 <- (^.J.version) <$> getVersionedDoc doc + ver2 <- (^. L.version) <$> getVersionedDoc doc _ <- waitForDiagnostics - liftIO $ ver2 @?= Just 1 + liftIO $ ver2 @?= 1 -- Execute the action and see what the version is action <- head . concatMap (^.. _CACodeAction) <$> getAllCodeActions doc @@ -109,7 +111,7 @@ codeLensTests = testGroup runSessionWithServer classPlugin testDataDir $ do doc <- openDoc "CodeLensSimple.hs" "haskell" lens <- getCodeLenses doc - let titles = map (^. J.title) $ mapMaybe (^. J.command) lens + let titles = map (^. L.title) $ mapMaybe (^. L.command) lens liftIO $ titles @?= [ "(==) :: B -> B -> Bool" , "(==) :: A -> A -> Bool" @@ -146,8 +148,8 @@ goldenCodeLens :: TestName -> FilePath -> Int -> TestTree goldenCodeLens title path idx = goldenWithHaskellDoc classPlugin title testDataDir path "expected" "hs" $ \doc -> do lens <- getCodeLenses doc - executeCommand $ fromJust $ (lens !! idx) ^. J.command - void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) + executeCommand $ fromJust $ (lens !! idx) ^. L.command + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) goldenWithClass ::TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree goldenWithClass title path desc act = @@ -164,7 +166,7 @@ expectCodeActionsAvailable title path actionTitles = doc <- openDoc (path <.> "hs") "haskell" _ <- waitForDiagnosticsFromSource doc "typecheck" caResults <- getAllCodeActions doc - liftIO $ map (^? _CACodeAction . J.title) caResults + liftIO $ map (^? _CACodeAction . L.title) caResults @?= expectedActions where expectedActions = Just <$> actionTitles diff --git a/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal b/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal index d9aa40627c..1e2dfeccad 100644 --- a/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal +++ b/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-code-range-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: HLS Plugin to support smart selection range and Folding range @@ -37,9 +37,9 @@ library , containers , deepseq , extra - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , hashable - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , lens , lsp , mtl @@ -62,9 +62,9 @@ test-suite tests , bytestring , containers , filepath - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , hls-code-range-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , lens , lsp , lsp-test diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs index d6dfd2820a..57a40f8411 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} - +{-# LANGUAGE TypeOperators #-} module Ide.Plugin.CodeRange ( descriptor , Log @@ -48,25 +48,24 @@ import Ide.Types (PluginDescriptor (pluginH PluginId, defaultPluginDescriptor, mkPluginHandler) -import Language.LSP.Server (LspM, LspT) -import Language.LSP.Types (FoldingRange (..), +import Language.LSP.Protocol.Message (ResponseError, + SMethod (SMethod_TextDocumentFoldingRange, SMethod_TextDocumentSelectionRange)) +import Language.LSP.Protocol.Types (FoldingRange (..), FoldingRangeParams (..), - List (List), - NormalizedFilePath, + NormalizedFilePath, Null, Position (..), Range (_start), - ResponseError, - SMethod (STextDocumentFoldingRange, STextDocumentSelectionRange), SelectionRange (..), SelectionRangeParams (..), TextDocumentIdentifier (TextDocumentIdentifier), - Uri) + Uri, type (|?) (InL)) +import Language.LSP.Server (LspM, LspT) import Prelude hiding (log, span) descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentSelectionRange (selectionRangeHandler recorder) - <> mkPluginHandler STextDocumentFoldingRange (foldingRangeHandler recorder) + { pluginHandlers = mkPluginHandler SMethod_TextDocumentSelectionRange (selectionRangeHandler recorder) + <> mkPluginHandler SMethod_TextDocumentFoldingRange (foldingRangeHandler recorder) , pluginRules = codeRangeRule (cmapWithPrio LogRules recorder) } @@ -78,14 +77,14 @@ instance Pretty Log where LogRules codeRangeLog -> pretty codeRangeLog LogBadDependency rule -> pretty $ "bad dependency: " <> show rule -foldingRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError (List FoldingRange)) +foldingRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> FoldingRangeParams -> LspM c (Either ResponseError ([FoldingRange] |? Null)) foldingRangeHandler recorder ide _ FoldingRangeParams{..} = do pluginResponse $ do filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ toNormalizedFilePath' <$> uriToFilePath' uri foldingRanges <- mapExceptT runAction' $ getFoldingRanges filePath - pure . List $ foldingRanges + pure . InL $ foldingRanges where uri :: Uri TextDocumentIdentifier uri = _textDocument @@ -107,20 +106,20 @@ getFoldingRanges file = do codeRange <- maybeToExceptT (FoldingRangeBadDependency GetCodeRange) . MaybeT $ use GetCodeRange file pure $ findFoldingRanges codeRange -selectionRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError (List SelectionRange)) +selectionRangeHandler :: Recorder (WithPriority Log) -> IdeState -> PluginId -> SelectionRangeParams -> LspM c (Either ResponseError ([SelectionRange] |? Null)) selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do pluginResponse $ do filePath <- ExceptT . pure . maybeToEither "fail to convert uri to file path" $ toNormalizedFilePath' <$> uriToFilePath' uri - fmap List . mapExceptT runIdeAction' . getSelectionRanges filePath $ positions + fmap id . mapExceptT runIdeAction' . getSelectionRanges filePath $ positions where uri :: Uri TextDocumentIdentifier uri = _textDocument positions :: [Position] - List positions = _positions + positions = _positions - runIdeAction' :: IdeAction (Either SelectionRangeError [SelectionRange]) -> LspT c IO (Either String [SelectionRange]) + runIdeAction' :: IdeAction (Either SelectionRangeError ([SelectionRange] |? Null)) -> LspT c IO (Either String ([SelectionRange] |? Null)) runIdeAction' action = do result <- liftIO $ runIdeAction "SelectionRange" (shakeExtras ide) action case result of @@ -129,7 +128,7 @@ selectionRangeHandler recorder ide _ SelectionRangeParams{..} = do logWith recorder Warning $ LogBadDependency rule -- This might happen if the HieAst is not ready, -- so we give it a default value instead of throwing an error - pure $ Right [] + pure $ Right $ InL [] SelectionRangeInputPositionMappingFailure -> pure $ Left "failed to apply position mapping to input positions" SelectionRangeOutputPositionMappingFailure -> pure $ @@ -140,7 +139,7 @@ data SelectionRangeError = forall rule. Show rule => SelectionRangeBadDependency | SelectionRangeInputPositionMappingFailure | SelectionRangeOutputPositionMappingFailure -getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT SelectionRangeError IdeAction [SelectionRange] +getSelectionRanges :: NormalizedFilePath -> [Position] -> ExceptT SelectionRangeError IdeAction ([SelectionRange] |? Null) getSelectionRanges file positions = do (codeRange, positionMapping) <- maybeToExceptT (SelectionRangeBadDependency GetCodeRange) . MaybeT $ useWithStaleFast GetCodeRange file @@ -156,7 +155,7 @@ getSelectionRanges file positions = do -- 'positionMapping' should be applied to the output ranges before returning them maybeToExceptT SelectionRangeOutputPositionMappingFailure . MaybeT . pure $ - traverse (toCurrentSelectionRange positionMapping) selectionRanges + InL <$> traverse (toCurrentSelectionRange positionMapping) selectionRanges -- | Find 'Position' in 'CodeRange'. This can fail, if the given position is not covered by the 'CodeRange'. findPosition :: Position -> CodeRange -> Maybe SelectionRange @@ -221,7 +220,7 @@ createFoldingRange :: CodeRange -> Maybe FoldingRange createFoldingRange (CodeRange (Range (Position lineStart charStart) (Position lineEnd charEnd)) _ ck) = do -- Type conversion of codeRangeKind to FoldingRangeKind let frk = crkToFrk ck - Just (FoldingRange lineStart (Just charStart) lineEnd (Just charEnd) (Just frk)) + Just (FoldingRange lineStart (Just charStart) lineEnd (Just charEnd) (Just frk) Nothing) -- | Likes 'toCurrentPosition', but works on 'SelectionRange' toCurrentSelectionRange :: PositionMapping -> SelectionRange -> Maybe SelectionRange diff --git a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs index 311984a403..ffcbc75e7d 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs @@ -53,8 +53,9 @@ import Ide.Plugin.CodeRange.ASTPreProcess (CustomNodeType (..), PreProcessEnv (..), isCustomNode, preProcessAST) -import Language.LSP.Types (FoldingRangeKind (FoldingRangeComment, FoldingRangeImports, FoldingRangeRegion)) -import Language.LSP.Types.Lens (HasEnd (end), +import Language.LSP.Protocol.Types (FoldingRangeKind (FoldingRangeKind_Comment, FoldingRangeKind_Imports, FoldingRangeKind_Region)) + +import Language.LSP.Protocol.Lens (HasEnd (end), HasStart (start)) import Prelude hiding (log) @@ -195,6 +196,6 @@ handleError recorder action' = do -- | Maps type CodeRangeKind to FoldingRangeKind crkToFrk :: CodeRangeKind -> FoldingRangeKind crkToFrk crk = case crk of - CodeKindComment -> FoldingRangeComment - CodeKindImports -> FoldingRangeImports - CodeKindRegion -> FoldingRangeRegion + CodeKindComment -> FoldingRangeKind_Comment + CodeKindImports -> FoldingRangeKind_Imports + CodeKindRegion -> FoldingRangeKind_Region diff --git a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs index 1157b03930..627dc28493 100644 --- a/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs +++ b/plugins/hls-code-range-plugin/test/Ide/Plugin/CodeRangeTest.hs @@ -73,17 +73,17 @@ testTree = (mkCodeRange (Position 1 1) (Position 5 10) [ mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindRegion ] CodeKindRegion) - [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeRegion)], + [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeKind_Region) Nothing], testCase "Test Code Kind Comment" $ check (mkCodeRange (Position 1 1) (Position 5 10) [ mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindComment ] CodeKindRegion) - [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeComment)], + [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeKind_Comment) Nothing], testCase "Test Code Kind Import" $ check (mkCodeRange (Position 1 1) (Position 5 10) [ mkCodeRange (Position 1 2) (Position 3 6) [] CodeKindImports ] CodeKindRegion) - [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeImports)], + [FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeKind_Imports) Nothing], -- Test for Code Portions with children testCase "Test Children" $ check @@ -93,9 +93,9 @@ testTree = ] CodeKindRegion, mkCodeRange (Position 3 7) (Position 5 10) [] CodeKindRegion ] CodeKindRegion) - [ FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeRegion), - FoldingRange 1 (Just 3) 1 (Just 5) (Just FoldingRangeRegion), - FoldingRange 3 (Just 7) 5 (Just 10) (Just FoldingRangeRegion) + [ FoldingRange 1 (Just 2) 3 (Just 6) (Just FoldingRangeKind_Region) Nothing, + FoldingRange 1 (Just 3) 1 (Just 5) (Just FoldingRangeKind_Region) Nothing, + FoldingRange 3 (Just 7) 5 (Just 10) (Just FoldingRangeKind_Region) Nothing ] ], @@ -109,10 +109,10 @@ testTree = -- General tests testCase "Test General Code Block" $ check (mkCodeRange (Position 1 1) (Position 5 10) [] CodeKindRegion) - (Just (FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeRegion))), + (Just (FoldingRange 1 (Just 1) 5 (Just 10) (Just FoldingRangeKind_Region) Nothing)), -- If a range has the same start and end line it need not be folded so Nothing is expected testCase "Test Same Start Line" $ check (mkCodeRange (Position 1 1) (Position 1 10) [] CodeKindRegion) - (Just (FoldingRange 1 (Just 1) 1 (Just 10) (Just FoldingRangeRegion))) + (Just (FoldingRange 1 (Just 1) 1 (Just 10) (Just FoldingRangeKind_Region) Nothing)) ] ] diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index 2b5f018e4f..a1948ce51a 100644 --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -14,7 +14,9 @@ import Development.IDE.Types.Logger (Priority (Debug), import Ide.Plugin.CodeRange (Log, descriptor) import qualified Ide.Plugin.CodeRange.RulesTest import qualified Ide.Plugin.CodeRangeTest -import Language.LSP.Types.Lens +import Language.LSP.Protocol.Lens +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import System.FilePath ((<.>), ()) import Test.Hls @@ -41,10 +43,10 @@ selectionRangeGoldenTest :: TestName -> [(UInt, UInt)] -> TestTree selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do res <- runSessionWithServer plugin testDataDir $ do doc <- openDoc (testName <.> "hs") "haskell" - resp <- request STextDocumentSelectionRange $ SelectionRangeParams Nothing Nothing doc - (List $ fmap (uncurry Position . (\(x, y) -> (x-1, y-1))) positions) + resp <- request SMethod_TextDocumentSelectionRange $ SelectionRangeParams Nothing Nothing doc + $ fmap (uncurry Position . (\(x, y) -> (x-1, y-1))) positions let res = resp ^. result - pure $ fmap showSelectionRangesForTest res + pure $ fmap (showSelectionRangesForTest . absorbNull) res case res of Left err -> assertFailure (show err) Right golden -> pure golden @@ -52,8 +54,8 @@ selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDi testDataDir :: FilePath testDataDir = "test" "testdata" "selection-range" - showSelectionRangesForTest :: List SelectionRange -> ByteString - showSelectionRangesForTest (List selectionRanges) = LBSChar8.intercalate "\n" $ fmap showSelectionRangeForTest selectionRanges + showSelectionRangesForTest :: [SelectionRange] -> ByteString + showSelectionRangesForTest selectionRanges = LBSChar8.intercalate "\n" $ fmap showSelectionRangeForTest selectionRanges showSelectionRangeForTest :: SelectionRange -> ByteString showSelectionRangeForTest selectionRange = go True (Just selectionRange) @@ -70,9 +72,9 @@ foldingRangeGoldenTest :: TestName -> TestTree foldingRangeGoldenTest testName = goldenGitDiff testName (testDataDir testName <.> "golden" <.> "txt") $ do res <- runSessionWithServer plugin testDataDir $ do doc <- openDoc (testName <.> "hs") "haskell" - resp <- request STextDocumentFoldingRange $ FoldingRangeParams Nothing Nothing doc + resp <- request SMethod_TextDocumentFoldingRange $ FoldingRangeParams Nothing Nothing doc let res = resp ^. result - pure $ fmap showFoldingRangesForTest res + pure $ fmap (showFoldingRangesForTest . absorbNull) res case res of Left err -> assertFailure (show err) @@ -82,11 +84,11 @@ foldingRangeGoldenTest testName = goldenGitDiff testName (testDataDir testN testDataDir :: FilePath testDataDir = "test" "testdata" "folding-range" - showFoldingRangesForTest :: List FoldingRange -> ByteString - showFoldingRangesForTest (List foldingRanges) = LBSChar8.intercalate "\n" $ fmap showFoldingRangeForTest foldingRanges + showFoldingRangesForTest :: [FoldingRange] -> ByteString + showFoldingRangesForTest foldingRanges = (LBSChar8.intercalate "\n" $ fmap showFoldingRangeForTest foldingRanges) `LBSChar8.snoc` '\n' showFoldingRangeForTest :: FoldingRange -> ByteString - showFoldingRangeForTest f@(FoldingRange sl (Just sc) el (Just ec) (Just frk)) = "((" <> showLBS sl <>", "<> showLBS sc <> ")" <> " : " <> "(" <> showLBS el <>", "<> showLBS ec<> ")) : " <> showFRK frk + showFoldingRangeForTest f@(FoldingRange sl (Just sc) el (Just ec) (Just frk) _) = "((" <> showLBS sl <>", "<> showLBS sc <> ")" <> " : " <> "(" <> showLBS el <>", "<> showLBS ec<> ")) : " <> showFRK frk showLBS = fromString . show showFRK = fromString . show diff --git a/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt index b7af2a60a0..98399f4847 100644 --- a/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt +++ b/plugins/hls-code-range-plugin/test/testdata/folding-range/Function.golden.txt @@ -1,41 +1,41 @@ -((2, 16) : (2, 22)) : FoldingRangeRegion -((4, 0) : (7, 21)) : FoldingRangeRegion -((4, 0) : (4, 25)) : FoldingRangeRegion -((4, 0) : (4, 6)) : FoldingRangeRegion -((4, 10) : (4, 25)) : FoldingRangeRegion -((4, 10) : (4, 17)) : FoldingRangeRegion -((4, 21) : (4, 25)) : FoldingRangeRegion -((5, 0) : (7, 21)) : FoldingRangeRegion -((5, 0) : (5, 6)) : FoldingRangeRegion -((5, 7) : (5, 8)) : FoldingRangeRegion -((5, 9) : (7, 21)) : FoldingRangeRegion -((5, 11) : (7, 21)) : FoldingRangeRegion -((5, 14) : (5, 28)) : FoldingRangeRegion -((5, 14) : (5, 23)) : FoldingRangeRegion -((5, 14) : (5, 15)) : FoldingRangeRegion -((5, 16) : (5, 21)) : FoldingRangeRegion -((5, 22) : (5, 23)) : FoldingRangeRegion -((5, 24) : (5, 26)) : FoldingRangeRegion -((5, 27) : (5, 28)) : FoldingRangeRegion -((6, 16) : (6, 20)) : FoldingRangeRegion -((7, 16) : (7, 21)) : FoldingRangeRegion -((9, 0) : (12, 20)) : FoldingRangeRegion -((9, 0) : (9, 24)) : FoldingRangeRegion -((9, 0) : (9, 5)) : FoldingRangeRegion -((9, 9) : (9, 24)) : FoldingRangeRegion -((9, 9) : (9, 16)) : FoldingRangeRegion -((9, 20) : (9, 24)) : FoldingRangeRegion -((10, 0) : (12, 20)) : FoldingRangeRegion -((10, 0) : (10, 5)) : FoldingRangeRegion -((10, 6) : (10, 7)) : FoldingRangeRegion -((10, 8) : (12, 20)) : FoldingRangeRegion -((10, 10) : (12, 20)) : FoldingRangeRegion -((10, 13) : (10, 27)) : FoldingRangeRegion -((10, 13) : (10, 22)) : FoldingRangeRegion -((10, 13) : (10, 14)) : FoldingRangeRegion -((10, 15) : (10, 20)) : FoldingRangeRegion -((10, 21) : (10, 22)) : FoldingRangeRegion -((10, 23) : (10, 25)) : FoldingRangeRegion -((10, 26) : (10, 27)) : FoldingRangeRegion -((11, 16) : (11, 21)) : FoldingRangeRegion -((12, 16) : (12, 20)) : FoldingRangeRegion \ No newline at end of file +((2, 16) : (2, 22)) : FoldingRangeKind_Region +((4, 0) : (7, 21)) : FoldingRangeKind_Region +((4, 0) : (4, 25)) : FoldingRangeKind_Region +((4, 0) : (4, 6)) : FoldingRangeKind_Region +((4, 10) : (4, 25)) : FoldingRangeKind_Region +((4, 10) : (4, 17)) : FoldingRangeKind_Region +((4, 21) : (4, 25)) : FoldingRangeKind_Region +((5, 0) : (7, 21)) : FoldingRangeKind_Region +((5, 0) : (5, 6)) : FoldingRangeKind_Region +((5, 7) : (5, 8)) : FoldingRangeKind_Region +((5, 9) : (7, 21)) : FoldingRangeKind_Region +((5, 11) : (7, 21)) : FoldingRangeKind_Region +((5, 14) : (5, 28)) : FoldingRangeKind_Region +((5, 14) : (5, 23)) : FoldingRangeKind_Region +((5, 14) : (5, 15)) : FoldingRangeKind_Region +((5, 16) : (5, 21)) : FoldingRangeKind_Region +((5, 22) : (5, 23)) : FoldingRangeKind_Region +((5, 24) : (5, 26)) : FoldingRangeKind_Region +((5, 27) : (5, 28)) : FoldingRangeKind_Region +((6, 16) : (6, 20)) : FoldingRangeKind_Region +((7, 16) : (7, 21)) : FoldingRangeKind_Region +((9, 0) : (12, 20)) : FoldingRangeKind_Region +((9, 0) : (9, 24)) : FoldingRangeKind_Region +((9, 0) : (9, 5)) : FoldingRangeKind_Region +((9, 9) : (9, 24)) : FoldingRangeKind_Region +((9, 9) : (9, 16)) : FoldingRangeKind_Region +((9, 20) : (9, 24)) : FoldingRangeKind_Region +((10, 0) : (12, 20)) : FoldingRangeKind_Region +((10, 0) : (10, 5)) : FoldingRangeKind_Region +((10, 6) : (10, 7)) : FoldingRangeKind_Region +((10, 8) : (12, 20)) : FoldingRangeKind_Region +((10, 10) : (12, 20)) : FoldingRangeKind_Region +((10, 13) : (10, 27)) : FoldingRangeKind_Region +((10, 13) : (10, 22)) : FoldingRangeKind_Region +((10, 13) : (10, 14)) : FoldingRangeKind_Region +((10, 15) : (10, 20)) : FoldingRangeKind_Region +((10, 21) : (10, 22)) : FoldingRangeKind_Region +((10, 23) : (10, 25)) : FoldingRangeKind_Region +((10, 26) : (10, 27)) : FoldingRangeKind_Region +((11, 16) : (11, 21)) : FoldingRangeKind_Region +((12, 16) : (12, 20)) : FoldingRangeKind_Region diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 401c43c785..fa33dd99ff 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-eval-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Eval plugin for Haskell Language Server description: Please see the README on GitHub at @@ -66,10 +66,10 @@ library , ghc , ghc-boot-th , ghc-paths - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , hashable , hls-graph - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , lens , lsp , lsp-types @@ -111,7 +111,8 @@ test-suite tests , filepath , hls-eval-plugin , hls-plugin-api - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , lens , lsp-types , text + , row-types diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs index c00022fd13..f5e9ec6b1d 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -11,19 +11,19 @@ module Ide.Plugin.Eval ( Log(..) ) where -import Development.IDE (IdeState) -import Development.IDE.Types.Logger (Pretty (pretty), Recorder, - WithPriority, cmapWithPrio) -import qualified Ide.Plugin.Eval.CodeLens as CL +import Development.IDE (IdeState) +import Development.IDE.Types.Logger (Pretty (pretty), Recorder, + WithPriority, cmapWithPrio) +import qualified Ide.Plugin.Eval.CodeLens as CL import Ide.Plugin.Eval.Config -import Ide.Plugin.Eval.Rules (rules) -import qualified Ide.Plugin.Eval.Rules as EvalRules -import Ide.Types (ConfigDescriptor (..), - PluginDescriptor (..), PluginId, - defaultConfigDescriptor, - defaultPluginDescriptor, - mkCustomConfig, mkPluginHandler) -import Language.LSP.Types +import Ide.Plugin.Eval.Rules (rules) +import qualified Ide.Plugin.Eval.Rules as EvalRules +import Ide.Types (ConfigDescriptor (..), + PluginDescriptor (..), PluginId, + defaultConfigDescriptor, + defaultPluginDescriptor, + mkCustomConfig, mkPluginHandler) +import Language.LSP.Protocol.Message newtype Log = LogEvalRules EvalRules.Log deriving Show @@ -35,7 +35,7 @@ instance Pretty Log where descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeLens CL.codeLens + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens CL.codeLens , pluginCommands = [CL.evalCommand plId] , pluginRules = rules (cmapWithPrio LogEvalRules recorder) , pluginConfigDescriptor = defaultConfigDescriptor diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs index 10efbd05c3..846d8ce160 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs @@ -6,28 +6,28 @@ -- | Expression execution module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, propSetup, testCheck, asStatements,myExecStmt) where -import Control.Lens ((^.)) +import Control.Lens ((^.)) import Control.Monad.IO.Class -import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff) -import qualified Data.List.NonEmpty as NE -import Data.String (IsString) -import qualified Data.Text as T +import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff) +import qualified Data.List.NonEmpty as NE +import Data.String (IsString) +import qualified Data.Text as T import Development.IDE.GHC.Compat -import Development.IDE.Types.Location (Position (..), Range (..)) -import GHC (ExecOptions, ExecResult (..), - execStmt) -import Ide.Plugin.Eval.Types (Language (Plain), Loc, - Located (..), - Section (sectionLanguage), - Test (..), Txt, locate, - locate0) -import Language.LSP.Types.Lens (line, start) -import System.IO.Extra (newTempFile, readFile') +import GHC (ExecOptions, ExecResult (..), + execStmt) +import Ide.Plugin.Eval.Types (Language (Plain), Loc, + Located (..), + Section (sectionLanguage), + Test (..), Txt, locate, locate0) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types (Position (Position), + Range (Range)) +import System.IO.Extra (newTempFile, readFile') -- | Return the ranges of the expression and result parts of the given test testRanges :: Test -> (Range, Range) testRanges tst = - let startLine = testRange tst ^. start.line + let startLine = testRange tst ^. L.start . L.line (fromIntegral -> exprLines, fromIntegral -> resultLines) = testLengths tst resLine = startLine + exprLines in ( Range @@ -72,7 +72,7 @@ testLengths (Property _ r _) = (1, length r) type Statement = Loc String asStatements :: Test -> [Statement] -asStatements lt = locate $ Located (fromIntegral $ testRange lt ^. start.line) (asStmts lt) +asStatements lt = locate $ Located (fromIntegral $ testRange lt ^. L.start . L.line) (asStmts lt) asStmts :: Test -> [Txt] asStmts (Example e _ _) = NE.toList e diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 32fe788701..2287200697 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -29,42 +29,41 @@ import Control.Exception (try) import qualified Control.Exception as E import Control.Lens (_1, _3, ix, (%~), (<&>), (^.)) -import Control.Monad (guard, - void, when) +import Control.Monad (guard, void, + when) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (ExceptT (..)) import Data.Aeson (toJSON) import Data.Char (isSpace) import Data.Foldable (toList) -import qualified Data.HashMap.Strict as HashMap import Data.List (dropWhileEnd, find, intercalate, intersperse) +import qualified Data.Map as Map import Data.Maybe (catMaybes) import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as T import Data.Typeable (Typeable) -import Development.IDE.Core.RuleTypes - ( NeedsCompilation(NeedsCompilation), - LinkableResult(linkableHomeMod), - tmrTypechecked, - TypeCheck(..)) -import Development.IDE.Core.Rules ( runAction, IdeState ) -import Development.IDE.Core.Shake - ( useWithStale_, - use_, - uses_ ) -import Development.IDE.GHC.Util - ( printOutputable, evalGhcEnv, modifyDynFlags ) -import Development.IDE.Types.Location - ( toNormalizedFilePath', uriToFilePath' ) +import Development.IDE.Core.Rules (IdeState, + runAction) +import Development.IDE.Core.RuleTypes (LinkableResult (linkableHomeMod), + NeedsCompilation (NeedsCompilation), + TypeCheck (..), + tmrTypechecked) +import Development.IDE.Core.Shake (useWithStale_, + use_, uses_) import Development.IDE.GHC.Compat hiding (typeKind, unitState) import Development.IDE.GHC.Compat.Util (GhcException, OverridingBool (..)) +import Development.IDE.GHC.Util (evalGhcEnv, + modifyDynFlags, + printOutputable) import Development.IDE.Import.DependencyInformation (reachableModules) +import Development.IDE.Types.Location (toNormalizedFilePath', + uriToFilePath') import GHC (ClsInst, ExecOptions (execLineNumber, execSourceFile), FamInst, @@ -75,24 +74,23 @@ import GHC (ClsInst, exprType, getInfo, getInteractiveDynFlags, - isImport, isStmt, parseName, + isImport, isStmt, + parseName, pprFamInst, pprInstance, typeKind) -import Development.IDE.Core.RuleTypes - ( ModSummaryResult(msrModSummary), - GetModSummary(GetModSummary), - GhcSessionDeps(GhcSessionDeps), - GetDependencyInformation(GetDependencyInformation), - GetLinkable(GetLinkable) ) -import Development.IDE.Core.Shake ( VFSModified(VFSUnmodified) ) -import Development.IDE.Types.HscEnvEq ( HscEnvEq(hscEnv) ) -import qualified Development.IDE.GHC.Compat.Core as Compat - ( InteractiveImport(IIModule) ) -import qualified Development.IDE.GHC.Compat.Core as SrcLoc - ( unLoc, HasSrcSpan(getLoc) ) +import Development.IDE.Core.RuleTypes (GetDependencyInformation (GetDependencyInformation), + GetLinkable (GetLinkable), + GetModSummary (GetModSummary), + GhcSessionDeps (GhcSessionDeps), + ModSummaryResult (msrModSummary)) +import Development.IDE.Core.Shake (VFSModified (VFSUnmodified)) +import qualified Development.IDE.GHC.Compat.Core as Compat (InteractiveImport (IIModule)) +import qualified Development.IDE.GHC.Compat.Core as SrcLoc (HasSrcSpan (getLoc), + unLoc) +import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) #if MIN_VERSION_ghc(9,2,0) #endif import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) @@ -127,17 +125,16 @@ import Ide.PluginUtils (handleMaybe, handleMaybeM, pluginResponse) import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import Language.LSP.Server -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length)) -import Language.LSP.Types.Lens (end, line) import Language.LSP.VFS (virtualFileText) {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. -} -codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens +codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens codeLens st plId CodeLensParams{_textDocument} = let dbg = logWith st perf = timed dbg @@ -171,7 +168,7 @@ codeLens st plId CodeLensParams{_textDocument} = args = EvalParams (setupSections ++ [section]) _textDocument ident cmd' = (cmd :: Command) - { _arguments = Just (List [toJSON args]) + { _arguments = Just [toJSON args] , _title = if trivial resultRange then "Evaluate..." @@ -192,7 +189,7 @@ codeLens st plId CodeLensParams{_textDocument} = , "lenses." ] - return $ List lenses + return $ InL lenses where trivial (Range p p') = p == p' @@ -234,7 +231,7 @@ runEvalCmd plId st EvalParams{..} = evalGhcEnv final_hscEnv $ do runTests evalCfg (st, fp) tests - let workspaceEditsMap = HashMap.fromList [(_uri, List $ addFinalReturn mdlText edits)] + let workspaceEditsMap = Map.fromList [(_uri, addFinalReturn mdlText edits)] let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing Nothing return workspaceEdits @@ -355,12 +352,12 @@ runTests EvalConfig{..} e@(_st, _) tests = do asEdit :: Format -> Test -> [Text] -> TextEdit asEdit (MultiLine commRange) test resultLines -- A test in a block comment, ending with @-\}@ without newline in-between. - | testRange test ^. end.line == commRange ^. end . line + | testRange test ^. L.end . L.line == commRange ^. L.end . L.line = TextEdit (Range - (testRange test ^. end) - (resultRange test ^. end) + (testRange test ^. L.end) + (resultRange test ^. L.end) ) ("\n" <> T.unlines (resultLines <> ["-}"])) asEdit _ test resultLines = diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index 5a4d3f71b5..b638c159bd 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -33,14 +33,11 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Data.Text as T import Data.Void (Void) -import Development.IDE (Position, - Range (Range)) -import Development.IDE.Types.Location (Position (..)) import GHC.Generics hiding (UInt, to) import Ide.Plugin.Eval.Types -import Language.LSP.Types (UInt) -import Language.LSP.Types.Lens (character, end, line, - start) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types + import qualified Text.Megaparsec as P import Text.Megaparsec import Text.Megaparsec.Char (alphaNumChar, char, @@ -73,7 +70,7 @@ data BlockEnv = BlockEnv { isLhs :: Bool , blockRange :: Range } - deriving (Read, Show, Eq, Ord) + deriving (Show, Eq, Ord) makeLensesWith (lensRules & lensField .~ mappingNamer (pure . (++ "L"))) @@ -109,7 +106,7 @@ data CommentFlavour = Vanilla | HaddockNext | HaddockPrev | Named String -- | Single line or block comments? data CommentStyle = Line | Block Range - deriving (Read, Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic) makePrisms ''CommentStyle @@ -124,8 +121,8 @@ commentsToSections isLHS Comments {..} = ( \lcs -> let theRan = Range - (view start $ fst $ NE.head lcs) - (view end $ fst $ NE.last lcs) + (view L.start $ fst $ NE.head lcs) + (view L.end $ fst $ NE.last lcs) in case parseMaybe lineGroupP $ NE.toList lcs of Nothing -> mempty Just (mls, rs) -> @@ -147,8 +144,8 @@ commentsToSections isLHS Comments {..} = -- non-zero base indentation level! ( \pos _ -> if isLHS - then pos ^. start . character == 2 - else pos ^. start . character == 0 + then pos ^. L.start . L.character == 2 + else pos ^. L.start . L.character == 0 ) lineComments (blockSeed, blockSetupSeeds) = @@ -205,7 +202,7 @@ parseBlockMaybe isLhs blockRange p i = st { statePosState = (statePosState st) - { pstateSourcePos = positionToSourcePos $ blockRange ^. start + { pstateSourcePos = positionToSourcePos $ blockRange ^. L.start } } p @@ -330,8 +327,8 @@ positionToSourcePos :: Position -> SourcePos positionToSourcePos pos = P.SourcePos { sourceName = "" - , sourceLine = P.mkPos $ fromIntegral $ 1 + pos ^. line - , sourceColumn = P.mkPos $ fromIntegral $ 1 + pos ^. character + , sourceLine = P.mkPos $ fromIntegral $ 1 + pos ^. L.line + , sourceColumn = P.mkPos $ fromIntegral $ 1 + pos ^. L.character } sourcePosToPosition :: SourcePos -> Position @@ -420,7 +417,7 @@ exampleLinesGP = convexHullRange :: NonEmpty Range -> Range convexHullRange nes = - Range (NE.head nes ^. start) (NE.last nes ^. end) + Range (NE.head nes ^. L.start) (NE.last nes ^. L.end) exampleLineGP :: LineGroupParser (Range, ExampleLine) exampleLineGP = @@ -568,5 +565,5 @@ contiguousGroupOn toLineCol = foldr step [] groupLineComments :: Map Range a -> [NonEmpty (Range, a)] groupLineComments = - contiguousGroupOn (fst >>> view start >>> view line &&& view character) + contiguousGroupOn (fst >>> view L.start >>> view L.line &&& view L.character) . Map.toList diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs index 26d410e18a..e6fccc7523 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Types.hs @@ -41,7 +41,7 @@ import Data.String (IsString (..)) import Development.IDE (Range, RuleResult) import Development.IDE.Graph.Classes import GHC.Generics (Generic) -import Language.LSP.Types (TextDocumentIdentifier) +import Language.LSP.Protocol.Types (TextDocumentIdentifier) import qualified Text.Megaparsec as P -- | A thing with a location attached. diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs index 2b8c41ec2e..f8e44fa19e 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-} -- |Debug utilities @@ -13,25 +13,30 @@ module Ide.Plugin.Eval.Util ( logWith, ) where -import Control.Exception (SomeException, evaluate, fromException) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) -import Data.Aeson (Value (Null)) -import Data.String (IsString (fromString)) -import qualified Data.Text as T -import Development.IDE (IdeState, Priority (..), - ideLogger, logPriority) -import Development.IDE.GHC.Compat.Util (MonadCatch, catch, bagToList) +import Control.Exception (SomeException, evaluate, + fromException) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Except (ExceptT (..), + runExceptT) +import Data.Aeson (Value (Null)) +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import Development.IDE (IdeState, Priority (..), + ideLogger, logPriority) import Development.IDE.GHC.Compat.Outputable -import GHC.Exts (toList) -import GHC.Stack (HasCallStack, callStack, - srcLocFile, srcLocStartCol, - srcLocStartLine) +import Development.IDE.GHC.Compat.Util (MonadCatch, bagToList, + catch) +import GHC.Exts (toList) +import GHC.Stack (HasCallStack, callStack, + srcLocFile, + srcLocStartCol, + srcLocStartLine) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (Null) import Language.LSP.Server -import Language.LSP.Types -import System.FilePath (takeExtension) -import System.Time.Extra (duration, showDuration) -import UnliftIO.Exception (catchAny) +import System.FilePath (takeExtension) +import System.Time.Extra (duration, showDuration) +import UnliftIO.Exception (catchAny) timed :: MonadIO m => (t -> String -> m a) -> t -> m b -> m b timed out name op = do @@ -67,9 +72,9 @@ response' act = do `catchAny` showErr case res of Left e -> - return $ Left (ResponseError InternalError (fromString e) Nothing) + return $ Left (ResponseError (InR ErrorCodes_InternalError) (fromString e) Nothing) Right a -> do - _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ()) + _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ()) return $ Right Null gStrictTry :: (MonadIO m, MonadCatch m) => m b -> m (Either String b) diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index 26ab573a73..d903421d4f 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -1,30 +1,33 @@ {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} - module Main ( main ) where -import Control.Lens (_Just, folded, preview, toListOf, - view, (^..)) -import Data.Aeson (Value (Object), fromJSON, object, - toJSON, (.=)) -import Data.Aeson.Types (Pair, Result (Success)) -import Data.List (isInfixOf) -import Data.List.Extra (nubOrdOn) -import qualified Data.Map as Map -import qualified Data.Text as T -import Ide.Plugin.Config (Config) -import qualified Ide.Plugin.Config as Plugin -import qualified Ide.Plugin.Eval as Eval -import Ide.Plugin.Eval.Types (EvalParams (..), Section (..), - testOutput) -import Ide.Types (IdePlugins (IdePlugins)) -import Language.LSP.Types.Lens (arguments, command, range, title) -import System.FilePath (()) +import Control.Lens (_Just, folded, preview, + toListOf, view, (^..)) +import Data.Aeson (Value (Object), fromJSON, + object, toJSON, (.=)) +import Data.Aeson.Types (Pair, Result (Success)) +import Data.List (isInfixOf) +import Data.List.Extra (nubOrdOn) +import qualified Data.Map as Map +import Data.Row +import qualified Data.Text as T +import Ide.Plugin.Config (Config) +import qualified Ide.Plugin.Config as Plugin +import qualified Ide.Plugin.Eval as Eval +import Ide.Plugin.Eval.Types (EvalParams (..), Section (..), + testOutput) +import Ide.Types (IdePlugins (IdePlugins)) +import Language.LSP.Protocol.Lens (arguments, command, range, + title) +import Language.LSP.Protocol.Message hiding (error) +import System.FilePath (()) import Test.Hls main :: IO () @@ -249,14 +252,14 @@ executeLensesBackwards doc = do nubOrdOn actSectionId [c | CodeLens{_command = Just c} <- codeLenses] actSectionId :: Command -> Int -actSectionId Command{_arguments = Just (List [fromJSON -> Success EvalParams{..}])} = evalId +actSectionId Command{_arguments = Just [fromJSON -> Success EvalParams{..}]} = evalId actSectionId _ = error "Invalid CodeLens" -- Execute command and wait for result executeCmd :: Command -> Session () executeCmd cmd = do executeCommand cmd - _ <- skipManyTill anyMessage (message SWorkspaceApplyEdit) + _ <- skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) -- liftIO $ print _resp pure () @@ -269,7 +272,7 @@ evalLenses path = runSessionWithServer evalPlugin testDataDir $ do codeLensTestOutput :: CodeLens -> [String] codeLensTestOutput codeLens = do CodeLens { _command = Just command } <- [codeLens] - Command { _arguments = Just (List args) } <- [command] + Command { _arguments = Just args } <- [command] Success EvalParams { sections = sections } <- fromJSON @EvalParams <$> args Section { sectionTests = sectionTests } <- sections testOutput =<< sectionTests @@ -304,7 +307,7 @@ evalInFile fp e expected = runSessionWithServer evalPlugin testDataDir $ do doc <- openDoc fp "haskell" origin <- documentContents doc let withEval = origin <> e - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing withEval] + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ withEval] executeLensesBackwards doc result <- fmap T.strip . T.stripPrefix withEval <$> documentContents doc liftIO $ result @?= Just (T.strip expected) diff --git a/plugins/hls-explicit-fixity-plugin/hls-explicit-fixity-plugin.cabal b/plugins/hls-explicit-fixity-plugin/hls-explicit-fixity-plugin.cabal index fb6594d823..ae09d4569c 100644 --- a/plugins/hls-explicit-fixity-plugin/hls-explicit-fixity-plugin.cabal +++ b/plugins/hls-explicit-fixity-plugin/hls-explicit-fixity-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-explicit-fixity-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Show fixity explicitly while hovering description: Please see the README on GitHub at @@ -30,9 +30,9 @@ library , deepseq , extra , ghc - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , hashable - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , lsp >=1.2.0.1 , text , transformers @@ -55,5 +55,5 @@ test-suite tests , base , filepath , hls-explicit-fixity-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , text diff --git a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs index 29b30a94c2..db483d469d 100644 --- a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs +++ b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs @@ -32,18 +32,19 @@ import Ide.PluginUtils (getNormalizedFilePath, handleMaybeM, pluginResponse) import Ide.Types hiding (pluginId) -import Language.LSP.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder pluginId = (defaultPluginDescriptor pluginId) { pluginRules = fixityRule recorder - , pluginHandlers = mkPluginHandler STextDocumentHover hover + , pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hover -- Make this plugin has a lower priority than ghcide's plugin to ensure -- type info display first. , pluginPriority = ghcideNotificationsPluginPriority - 1 } -hover :: PluginMethodHandler IdeState TextDocumentHover +hover :: PluginMethodHandler IdeState Method_TextDocumentHover hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = pluginResponse $ do nfp <- getNormalizedFilePath uri handleMaybeM "ExplicitFixity: Unable to get fixity" $ liftIO $ runIdeAction "ExplicitFixity" (shakeExtras state) $ runMaybeT $ do @@ -51,7 +52,7 @@ hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = pluginResponse (HAR{hieAst}, mapping) <- useE GetHieAst nfp let ns = getNamesAtPoint hieAst pos mapping fs = mapMaybe (\n -> (n,) <$> M.lookup n fixmap) ns - pure $ toHover $ fs + pure $ maybeToNull $ toHover $ fs where toHover :: [(Name, Fixity)] -> Maybe Hover toHover [] = Nothing @@ -60,7 +61,7 @@ hover state _ (HoverParams (TextDocumentIdentifier uri) pos _) = pluginResponse contents = T.intercalate "\n\n" $ fixityText <$> fixities -- Append to the previous hover content contents' = "\n" <> sectionSeparator <> contents - in Just $ Hover (HoverContents $ unmarkedUpContent contents') Nothing + in Just $ Hover (InL (mkPlainText contents')) Nothing fixityText :: (Name, Fixity) -> T.Text fixityText (name, Fixity _ precedence direction) = diff --git a/plugins/hls-explicit-fixity-plugin/test/Main.hs b/plugins/hls-explicit-fixity-plugin/test/Main.hs index c62f368e6d..344f155202 100644 --- a/plugins/hls-explicit-fixity-plugin/test/Main.hs +++ b/plugins/hls-explicit-fixity-plugin/test/Main.hs @@ -59,11 +59,11 @@ hoverTest' docName title pos expected = testCase title $ runSessionWithServer pl case h of Nothing -> liftIO $ assertFailure "No hover" Just (Hover contents _) -> case contents of - HoverContentsMS _ -> liftIO $ assertFailure "Unexpected content type" - HoverContents (MarkupContent mk txt) -> do + InL (MarkupContent mk txt) -> do liftIO $ assertBool ("Failed to find `" <> T.unpack expected <> "` in hover message: " <> T.unpack txt) $ expected `T.isInfixOf` txt + _ -> liftIO $ assertFailure "Unexpected content type" closeDoc doc testDataDir :: FilePath diff --git a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal index 62e3b85b90..94e6e807e4 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hls-explicit-imports-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Explicit imports plugin for Haskell Language Server description: Please see the README on GitHub at @@ -29,9 +29,9 @@ library , containers , deepseq , ghc - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , hls-graph - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , lsp , text , unordered-containers @@ -53,4 +53,5 @@ test-suite tests , filepath , hls-explicit-imports-plugin , hls-test-utils + , lsp-types , text diff --git a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs index 331eb72d91..741d3a87c3 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -40,8 +40,9 @@ import Development.IDE.Types.Logger as Logger (Pretty (pretty) import GHC.Generics (Generic) import Ide.PluginUtils (mkLspCommand) import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (Null) import Language.LSP.Server -import Language.LSP.Types importCommandId :: CommandId importCommandId = "ImportLensCommand" @@ -75,9 +76,9 @@ descriptorForModules recorder pred plId = pluginRules = minimalImportsRule recorder, pluginHandlers = mconcat [ -- This plugin provides code lenses - mkPluginHandler STextDocumentCodeLens $ lensProvider pred + mkPluginHandler SMethod_TextDocumentCodeLens $ lensProvider pred -- This plugin provides code actions - , mkPluginHandler STextDocumentCodeAction $ codeActionProvider pred + , mkPluginHandler SMethod_TextDocumentCodeAction $ codeActionProvider pred ] } @@ -95,7 +96,7 @@ newtype ImportCommandParams = ImportCommandParams WorkspaceEdit runImportCommand :: CommandFunction IdeState ImportCommandParams runImportCommand _state (ImportCommandParams edit) = do -- This command simply triggers a workspace edit! - _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) return (Right Null) -- | For every implicit import statement, return a code lens of the corresponding explicit import @@ -108,7 +109,7 @@ runImportCommand _state (ImportCommandParams edit) = do -- the provider should produce one code lens associated to the import statement: -- -- > import Data.List (intercalate, sortBy) -lensProvider :: (ModuleName -> Bool) -> PluginMethodHandler IdeState TextDocumentCodeLens +lensProvider :: (ModuleName -> Bool) -> PluginMethodHandler IdeState Method_TextDocumentCodeLens lensProvider pred state -- ghcide state, used to retrieve typechecking artifacts @@ -129,15 +130,15 @@ lensProvider | (imp, Just minImport) <- minImports, Just edit <- [mkExplicitEdit pred posMapping imp minImport] ] - return $ Right (List $ catMaybes commands) + return $ Right $ InL $ catMaybes commands _ -> - return $ Right (List []) + return $ Right $ InL [] | otherwise = - return $ Right (List []) + return $ Right $ InL [] -- | If there are any implicit imports, provide one code action to turn them all -- into explicit imports. -codeActionProvider :: (ModuleName -> Bool) -> PluginMethodHandler IdeState TextDocumentCodeAction +codeActionProvider :: (ModuleName -> Bool) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionProvider pred ideState _pId (CodeActionParams _ _ docId range _context) | TextDocumentIdentifier {_uri} <- docId, Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = liftIO $ @@ -150,7 +151,7 @@ codeActionProvider pred ideState _pId (CodeActionParams _ _ docId range _context any (within range) rangesImports _ -> False if not insideImport - then return (Right (List [])) + then return (Right (InL [])) else do minImports <- runAction "MinimalImports" ideState $ use MinimalImports nfp let edits = @@ -161,19 +162,19 @@ codeActionProvider pred ideState _pId (CodeActionParams _ _ docId range _context ] caExplicitImports = InR CodeAction {..} _title = "Make all imports explicit" - _kind = Just CodeActionQuickFix + _kind = Just CodeActionKind_QuickFix _command = Nothing _edit = Just WorkspaceEdit {_changes, _documentChanges, _changeAnnotations} - _changes = Just $ HashMap.singleton _uri $ List edits + _changes = Just $ Map.singleton _uri edits _documentChanges = Nothing _diagnostics = Nothing _isPreferred = Nothing _disabled = Nothing - _xdata = Nothing + _data_ = Nothing _changeAnnotations = Nothing - return $ Right $ List [caExplicitImports | not (null edits)] + return $ Right $ InL [caExplicitImports | not (null edits)] | otherwise = - return $ Right $ List [] + return $ Right $ InL [] -------------------------------------------------------------------------------- @@ -298,10 +299,10 @@ generateLens pId uri importEdit@TextEdit {_range, _newText} = do let title = abbreviateImportTitle _newText -- the code lens has no extra data - _xdata = Nothing + _data_ = Nothing -- an edit that replaces the whole declaration with the explicit one edit = WorkspaceEdit (Just editsMap) Nothing Nothing - editsMap = HashMap.fromList [(uri, List [importEdit])] + editsMap = Map.fromList [(uri, [importEdit])] -- the command argument is simply the edit _arguments = Just [toJSON $ ImportCommandParams edit] -- create the command diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index c52f1f7d33..6a5303ecba 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -8,11 +8,12 @@ module Main ( main ) where -import Data.Foldable (find, forM_) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Ide.Plugin.ExplicitImports as ExplicitImports -import System.FilePath ((<.>), ()) +import Data.Foldable (find, forM_) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Ide.Plugin.ExplicitImports as ExplicitImports +import Language.LSP.Protocol.Message +import System.FilePath ((<.>), ()) import Test.Hls explicitImportsPlugin :: PluginTestDescriptor ExplicitImports.Log @@ -95,7 +96,7 @@ isExplicitImports _ = False executeCmd :: Command -> Session () executeCmd cmd = do executeCommand cmd - _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) + _resp <- skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) -- liftIO $ print _resp return () diff --git a/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal b/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal index b6acfbeaf8..1045fa5782 100644 --- a/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal +++ b/plugins/hls-explicit-record-fields-plugin/hls-explicit-record-fields-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hls-explicit-record-fields-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Explicit record fields plugin for Haskell Language Server description: Please see the README on GitHub at @@ -29,8 +29,8 @@ library -- other-extensions: build-depends: , base >=4.12 && <5 - , ghcide == 2.0.0.0 - , hls-plugin-api == 2.0.0.0 + , ghcide == 2.1.0.0 + , hls-plugin-api == 2.1.0.0 , lsp , lens , hls-graph diff --git a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs index 7600daa671..d5d30de168 100644 --- a/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs +++ b/plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs @@ -21,7 +21,7 @@ import Control.Monad.Trans.Except (ExceptT) import Data.Functor ((<&>)) import Data.Generics (GenericQ, everything, extQ, mkQ) -import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map as Map import Data.Maybe (fromMaybe, isJust, listToMaybe, maybeToList) import Data.Text (Text) @@ -69,17 +69,16 @@ import Ide.Types (PluginDescriptor (..), PluginMethodHandler, defaultPluginDescriptor, mkPluginHandler) -import Language.LSP.Types (CodeAction (..), - CodeActionKind (CodeActionRefactorRewrite), +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (Method (..), SMethod (..)) +import Language.LSP.Protocol.Types (CodeAction (..), + CodeActionKind (CodeActionKind_RefactorRewrite), CodeActionParams (..), - Command, List (..), - Method (..), SMethod (..), - TextEdit (..), + Command, TextEdit (..), WorkspaceEdit (WorkspaceEdit), fromNormalizedUri, normalizedFilePathToUri, - type (|?) (InR)) -import qualified Language.LSP.Types.Lens as L + type (|?) (InL, InR)) data Log @@ -95,29 +94,29 @@ instance Pretty Log where descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider , pluginRules = collectRecordsRule recorder *> collectNamesRule } -codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction +codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = pluginResponse $ do nfp <- getNormalizedFilePath (docId ^. L.uri) pragma <- getFirstPragma pId ideState nfp CRR recMap exts <- collectRecords' ideState nfp let actions = map (mkCodeAction nfp exts pragma) (RangeMap.filterByRange range recMap) - pure $ List actions + pure $ InL actions where mkCodeAction :: NormalizedFilePath -> [Extension] -> NextPragmaInfo -> RenderedRecordInfo -> Command |? CodeAction mkCodeAction nfp exts pragma rec = InR CodeAction { _title = mkCodeActionTitle exts - , _kind = Just CodeActionRefactorRewrite + , _kind = Just CodeActionKind_RefactorRewrite , _diagnostics = Nothing , _isPreferred = Nothing , _disabled = Nothing , _edit = Just $ mkWorkspaceEdit nfp edits , _command = Nothing - , _xdata = Nothing + , _data_ = Nothing } where edits = mkTextEdit rec : maybeToList pragmaEdit @@ -133,7 +132,7 @@ codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = pluginRes mkWorkspaceEdit :: NormalizedFilePath -> [TextEdit] -> WorkspaceEdit mkWorkspaceEdit nfp edits = WorkspaceEdit changes Nothing Nothing where - changes = Just $ HashMap.singleton (fromNormalizedUri (normalizedFilePathToUri nfp)) (List edits) + changes = Just $ Map.singleton (fromNormalizedUri (normalizedFilePathToUri nfp)) edits mkCodeActionTitle :: [Extension] -> Text mkCodeActionTitle exts = diff --git a/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal b/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal index e98f55a1db..5c5e8ceecb 100644 --- a/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal +++ b/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-floskell-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Integration with the Floskell code formatter description: Please see the README on GitHub at @@ -28,9 +28,9 @@ library build-depends: , base >=4.12 && <5 , floskell ^>=0.10 - , ghcide == 2.0.0.0 - , hls-plugin-api == 2.0.0.0 - , lsp-types ^>=1.6 + , ghcide == 2.1.0.0 + , hls-plugin-api == 2.1.0.0 + , lsp-types ^>=2.0.0.1 , text , transformers @@ -48,4 +48,4 @@ test-suite tests , base , filepath , hls-floskell-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 diff --git a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs index e59e0e9e92..2c8f6fb92e 100644 --- a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs +++ b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs @@ -6,14 +6,14 @@ module Ide.Plugin.Floskell ) where import Control.Monad.IO.Class -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import Development.IDE hiding (pluginHandlers) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Development.IDE hiding (pluginHandlers) import Floskell import Ide.PluginUtils import Ide.Types -import Language.LSP.Types +import Language.LSP.Protocol.Types -- --------------------------------------------------------------------- @@ -37,7 +37,7 @@ provider _ideState typ contents fp _ = liftIO $ do result = reformat config (Just file) . TL.encodeUtf8 $ TL.fromStrict selectedContents case result of Left err -> pure $ Left $ responseError $ T.pack $ "floskellCmd: " ++ err - Right new -> pure $ Right $ List [TextEdit range . TL.toStrict $ TL.decodeUtf8 new] + Right new -> pure $ Right $ InL [TextEdit range . TL.toStrict $ TL.decodeUtf8 new] -- | Find Floskell Config, user and system wide or provides a default style. -- Every directory of the filepath will be searched to find a user configuration. diff --git a/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal b/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal index ef7fe6d2dc..e220eaa9aa 100644 --- a/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal +++ b/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-fourmolu-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Integration with the Fourmolu code formatter description: Please see the README on GitHub at @@ -32,11 +32,11 @@ library build-depends: , base >=4.12 && <5 , filepath - , fourmolu ^>=0.3 || ^>=0.4 || ^>= 0.6 || ^>= 0.7 || ^>= 0.8 || ^>= 0.9 || ^>= 0.10 || ^>= 0.11 || ^>= 0.12 || ^>= 0.13 + , fourmolu ^>=0.3 || ^>=0.4 || ^>= 0.6 || ^>= 0.7 || ^>= 0.8 || ^>= 0.9 || ^>= 0.10 || ^>= 0.11 || ^>= 0.12 , ghc , ghc-boot-th - , ghcide == 2.0.0.0 - , hls-plugin-api == 2.0.0.0 + , ghcide == 2.1.0.0 + , hls-plugin-api == 2.1.0.0 , lens , lsp , process-extras >= 0.7.1 @@ -63,5 +63,5 @@ test-suite tests , filepath , hls-fourmolu-plugin , hls-plugin-api - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , lsp-test diff --git a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs index dd358f8334..37288dfc8c 100644 --- a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs +++ b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE LambdaCase #-} @@ -5,7 +6,6 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE CPP #-} module Ide.Plugin.Fourmolu ( descriptor, @@ -30,9 +30,10 @@ import Ide.Plugin.Fourmolu.Shim import Ide.Plugin.Properties import Ide.PluginUtils (makeDiffTextEdit) import Ide.Types +import Language.LSP.Protocol.Lens (HasTabSize (tabSize)) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import Language.LSP.Server hiding (defaultConfig) -import Language.LSP.Types hiding (line) -import Language.LSP.Types.Lens (HasTabSize (tabSize)) import Ormolu import System.Exit import System.FilePath @@ -95,13 +96,13 @@ provider recorder plId ideState typ contents fp fo = withIndefiniteProgress titl case exitCode of ExitSuccess -> do logWith recorder Debug $ StdErr err - pure . Right $ makeDiffTextEdit contents out + pure . Right $ InL $ makeDiffTextEdit contents out ExitFailure n -> do logWith recorder Info $ StdErr err pure . Left . responseError $ "Fourmolu failed with exit code " <> T.pack (show n) else do let format fourmoluConfig = - bimap (mkError . show) (makeDiffTextEdit contents) + bimap (mkError . show) (InL . makeDiffTextEdit contents) #if MIN_VERSION_fourmolu(0,11,0) <$> try @OrmoluException (ormolu config fp' contents) #else @@ -128,9 +129,9 @@ provider recorder plId ideState typ contents fp fo = withIndefiniteProgress titl logWith recorder Info $ NoConfigPath searchDirs format emptyConfig ConfigParseError f err -> do - sendNotification SWindowShowMessage $ + sendNotification SMethod_WindowShowMessage $ ShowMessageParams - { _xtype = MtError + { _type_ = MessageType_Error , _message = errorMessage } return . Left $ responseError errorMessage diff --git a/plugins/hls-fourmolu-plugin/test/Main.hs b/plugins/hls-fourmolu-plugin/test/Main.hs index fea8e86427..20506aefb6 100644 --- a/plugins/hls-fourmolu-plugin/test/Main.hs +++ b/plugins/hls-fourmolu-plugin/test/Main.hs @@ -6,9 +6,9 @@ module Main import Data.Aeson import Data.Functor import Ide.Plugin.Config -import qualified Ide.Plugin.Fourmolu as Fourmolu +import qualified Ide.Plugin.Fourmolu as Fourmolu +import Language.LSP.Protocol.Types import Language.LSP.Test -import Language.LSP.Types import System.FilePath import Test.Hls diff --git a/plugins/hls-gadt-plugin/hls-gadt-plugin.cabal b/plugins/hls-gadt-plugin/hls-gadt-plugin.cabal index 9a60580f30..62bda28301 100644 --- a/plugins/hls-gadt-plugin/hls-gadt-plugin.cabal +++ b/plugins/hls-gadt-plugin/hls-gadt-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-gadt-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Convert to GADT syntax plugin description: Please see the README on GitHub at @@ -30,10 +30,10 @@ library , containers , extra , ghc - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , ghc-boot-th , ghc-exactprint - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , hls-refactor-plugin , lens , lsp >=1.2.0.1 @@ -59,7 +59,7 @@ test-suite tests , base , filepath , hls-gadt-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , lens , lsp , lsp-test diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs index 150094bd07..93c1805d82 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -8,14 +8,14 @@ {-# LANGUAGE ViewPatterns #-} module Ide.Plugin.GADT (descriptor) where -import Control.Monad.Trans.Class -import Control.Monad.IO.Class import Control.Lens ((^.)) import Control.Monad.Except +import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Data.Aeson (FromJSON, ToJSON, Value (Null), toJSON) import Data.Either.Extra (maybeToEither) -import qualified Data.HashMap.Lazy as HashMap +import qualified Data.Map as Map import qualified Data.Text as T import Development.IDE import Development.IDE.GHC.Compat @@ -27,14 +27,15 @@ import GHC.Generics (Generic) import Ide.Plugin.GHC import Ide.PluginUtils import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (Null) import Language.LSP.Server (sendRequest) -import Language.LSP.Types -import qualified Language.LSP.Types.Lens as L descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { Ide.Types.pluginHandlers = - mkPluginHandler STextDocumentCodeAction codeActionHandler + mkPluginHandler SMethod_TextDocumentCodeAction codeActionHandler , pluginCommands = [PluginCommand toGADTSyntaxCommandId "convert data decl to GADT syntax" (toGADTCommand plId)] } @@ -67,37 +68,37 @@ toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = pluginResponse $ do let insertEdit = [insertNewPragma pragma GADTs | all (`notElem` exts) [GADTSyntax, GADTs]] _ <- lift $ sendRequest - SWorkspaceApplyEdit + SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing (workSpaceEdit nfp (TextEdit range txt : insertEdit))) (\_ -> pure ()) pure Null where workSpaceEdit nfp edits = WorkspaceEdit - (pure $ HashMap.fromList + (pure $ Map.fromList [(filePathToUri $ fromNormalizedFilePath nfp, - List edits)]) + edits)]) Nothing Nothing -codeActionHandler :: PluginMethodHandler IdeState TextDocumentCodeAction +codeActionHandler :: PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionHandler state plId (CodeActionParams _ _ doc range _) = pluginResponse $ do nfp <- getNormalizedFilePath (doc ^. L.uri) (inRangeH98Decls, _) <- getInRangeH98DeclsAndExts state range nfp let actions = map (mkAction . printOutputable . tcdLName . unLoc) inRangeH98Decls - pure $ List actions + pure $ InL actions where mkAction :: T.Text -> Command |? CodeAction mkAction name = InR CodeAction{..} where _title = "Convert \"" <> name <> "\" to GADT syntax" - _kind = Just CodeActionRefactorRewrite + _kind = Just CodeActionKind_RefactorRewrite _diagnostics = Nothing _isPreferred = Nothing _disabled = Nothing _edit = Nothing _command = Just $ mkLspCommand plId toGADTSyntaxCommandId _title (Just [toJSON mkParam]) - _xdata = Nothing + _data_ = Nothing mkParam = ToGADTParams (doc ^. L.uri) range diff --git a/plugins/hls-gadt-plugin/test/Main.hs b/plugins/hls-gadt-plugin/test/Main.hs index 7460eec245..a84a8fe991 100644 --- a/plugins/hls-gadt-plugin/test/Main.hs +++ b/plugins/hls-gadt-plugin/test/Main.hs @@ -74,8 +74,8 @@ isGADTCodeAction :: CodeAction -> Bool isGADTCodeAction CodeAction{..} = case _kind of Nothing -> False Just kind -> case kind of - CodeActionRefactorRewrite -> True - _ -> False + CodeActionKind_RefactorRewrite -> True + _ -> False testDataDir :: FilePath testDataDir = "test" "testdata" diff --git a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal index 3a90aecb58..8f67ca315e 100644 --- a/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal +++ b/plugins/hls-haddock-comments-plugin/hls-haddock-comments-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-haddock-comments-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Haddock comments plugin for Haskell Language Server description: Please see the README on GitHub at @@ -40,8 +40,8 @@ library , containers , ghc , ghc-exactprint < 1 - , ghcide == 2.0.0.0 - , hls-plugin-api == 2.0.0.0 + , ghcide == 2.1.0.0 + , hls-plugin-api == 2.1.0.0 , hls-refactor-plugin , lsp-types , text @@ -68,5 +68,5 @@ test-suite tests , base , filepath , hls-haddock-comments-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , text diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs index 2e9f4a5149..c5eb1f1592 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -12,7 +12,6 @@ module Ide.Plugin.HaddockComments (descriptor, E.Log) where import Control.Monad (join, when) import Control.Monad.IO.Class import Control.Monad.Trans.Class (lift) -import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import qualified Data.Text as T import Development.IDE hiding (pluginHandlers) @@ -27,25 +26,26 @@ import Ide.Types import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs) import Language.Haskell.GHC.ExactPrint.Utils -import Language.LSP.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types ----------------------------------------------------------------------------- descriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider } -codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction -codeActionProvider ideState _pId (CodeActionParams _ _ (TextDocumentIdentifier uri) range CodeActionContext {_diagnostics = List diags}) = +codeActionProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction +codeActionProvider ideState _pId (CodeActionParams _ _ (TextDocumentIdentifier uri) range CodeActionContext {_diagnostics = diags}) = do - let noErr = and $ (/= Just DsError) . _severity <$> diags + let noErr = and $ (/= Just DiagnosticSeverity_Error) . _severity <$> diags nfp = uriToNormalizedFilePath $ toNormalizedUri uri (join -> pm) <- liftIO $ runAction "HaddockComments.GetAnnotatedParsedSource" ideState $ use GetAnnotatedParsedSource `traverse` nfp let locDecls = hsmodDecls . unLoc . astA <$> pm anns = annsA <$> pm edits = [gen locDecls anns range | noErr, gen <- genList] - return $ Right $ List [InR $ toAction title uri edit | (Just (title, edit)) <- edits] + return $ Right $ InL [InR $ toAction title uri edit | (Just (title, edit)) <- edits] genList :: [Maybe [LHsDecl GhcPs] -> Maybe Anns -> Range -> Maybe (T.Text, TextEdit)] genList = @@ -114,15 +114,15 @@ toAction :: T.Text -> Uri -> TextEdit -> CodeAction toAction title uri edit = CodeAction {..} where _title = title - _kind = Just CodeActionQuickFix + _kind = Just CodeActionKind_QuickFix _diagnostics = Nothing _command = Nothing - _changes = Just $ HashMap.singleton uri $ List [edit] + _changes = Just $ Map.singleton uri [edit] _documentChanges = Nothing _edit = Just WorkspaceEdit {..} _isPreferred = Nothing _disabled = Nothing - _xdata = Nothing + _data_ = Nothing _changeAnnotations = Nothing diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index 035d951f04..e149a4256a 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-hlint-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Hlint integration plugin with Haskell Language Server description: Please see the README on GitHub at @@ -47,10 +47,10 @@ library , extra , filepath , ghc-exactprint >=0.6.3.4 - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , hashable , hlint < 3.6 - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , lens , lsp , refact @@ -92,7 +92,8 @@ test-suite tests , filepath , hls-hlint-plugin , hls-plugin-api - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , lens , lsp-types + , row-types , text diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 2c657a10c6..1c4c4ee445 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -50,6 +50,7 @@ import Data.Aeson.Types (FromJSON (. import qualified Data.ByteString as BS import Data.Hashable import qualified Data.HashMap.Strict as Map +import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -120,16 +121,15 @@ import Ide.Types hiding (Config) import Language.Haskell.HLint as Hlint hiding (Error) +import qualified Language.LSP.Protocol.Lens as LSP +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (Null) +import qualified Language.LSP.Protocol.Types as LSP import Language.LSP.Server (ProgressCancellable (Cancellable), getVersionedTextDoc, sendRequest, withIndefiniteProgress) -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import qualified Language.LSP.Types as LSP -import qualified Language.LSP.Types.Lens as LSP import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Spans.Pragmas (LineSplitTextEdits (LineSplitTextEdits), @@ -193,7 +193,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId) [ PluginCommand "applyOne" "Apply a single hint" (applyOneCmd recorder) , PluginCommand "applyAll" "Apply all hints to the file" (applyAllCmd recorder) ] - , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeActionProvider + , pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider , pluginConfigDescriptor = defaultConfigDescriptor { configHasDiagnostics = True , configCustomConfig = mkCustomConfig properties @@ -244,13 +244,15 @@ rules recorder plugin = do ideaToDiagnostic idea = LSP.Diagnostic { _range = srcSpanToRange $ ideaSpan idea - , _severity = Just LSP.DsInfo + , _severity = Just LSP.DiagnosticSeverity_Information -- we are encoding the fact that idea has refactorings in diagnostic code , _code = Just (InR $ T.pack $ codePre ++ ideaHint idea) , _source = Just "hlint" , _message = idea2Message idea , _relatedInformation = Nothing , _tags = Nothing + , _codeDescription = Nothing + , _data_ = Nothing } where codePre = if null $ ideaRefactoring idea then "" else "refact:" @@ -268,12 +270,14 @@ rules recorder plugin = do parseErrorToDiagnostic (Hlint.ParseError l msg contents) = LSP.Diagnostic { _range = srcSpanToRange l - , _severity = Just LSP.DsInfo + , _severity = Just LSP.DiagnosticSeverity_Information , _code = Just (InR "parser") , _source = Just "hlint" , _message = T.unlines [T.pack msg,T.pack contents] , _relatedInformation = Nothing , _tags = Nothing + , _codeDescription = Nothing + , _data_ = Nothing } -- This one is defined in Development.IDE.GHC.Error but here @@ -404,13 +408,13 @@ runGetModSummaryAction :: IdeState -> NormalizedFilePath -> IO (Maybe ModSummary runGetModSummaryAction ideState normalizedFilePath = runHlintAction ideState normalizedFilePath "Hlint.GetModSummary" GetModSummary -- --------------------------------------------------------------------- -codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction +codeActionProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context) | let TextDocumentIdentifier uri = documentId , Just docNormalizedFilePath <- uriToNormalizedFilePath (toNormalizedUri uri) = do verTxtDocId <- getVersionedTextDoc documentId - liftIO $ fmap (Right . LSP.List . map LSP.InR) $ do + liftIO $ fmap (Right . InL . map LSP.InR) $ do allDiagnostics <- atomically $ getDiagnostics ideState let numHintsInDoc = length @@ -437,21 +441,21 @@ codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context) else pure singleHintCodeActions | otherwise - = pure $ Right $ LSP.List [] + = pure $ Right $ InL [] where applyAllAction verTxtDocId = let args = Just [toJSON verTxtDocId] cmd = mkLspCommand pluginId "applyAll" "Apply all hints" args - in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionQuickFix) Nothing Nothing Nothing Nothing (Just cmd) Nothing + in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionKind_QuickFix) Nothing Nothing Nothing Nothing (Just cmd) Nothing -- |Some hints do not have an associated refactoring - validCommand (LSP.Diagnostic _ _ (Just (InR code)) (Just "hlint") _ _ _) = + validCommand (LSP.Diagnostic _ _ (Just (InR code)) _ (Just "hlint") _ _ _ _) = "refact:" `T.isPrefixOf` code validCommand _ = False - LSP.List diags = context ^. LSP.diagnostics + diags = context ^. LSP.diagnostics -- | Convert a hlint diagnostic into an apply and an ignore code action -- if applicable @@ -464,7 +468,7 @@ diagnosticToCodeActions dynFlags fileContents pluginId verTxtDocId diagnostic , let suppressHintTextEdits = mkSuppressHintTextEdits dynFlags fileContents hint , let suppressHintWorkspaceEdit = LSP.WorkspaceEdit - (Just (Map.singleton (verTxtDocId ^. LSP.uri) (List suppressHintTextEdits))) + (Just (M.singleton (verTxtDocId ^. LSP.uri) suppressHintTextEdits)) Nothing Nothing = catMaybes @@ -484,13 +488,13 @@ mkCodeAction :: T.Text -> LSP.Diagnostic -> Maybe LSP.WorkspaceEdit -> Maybe LSP mkCodeAction title diagnostic workspaceEdit command isPreferred = LSP.CodeAction { _title = title - , _kind = Just LSP.CodeActionQuickFix - , _diagnostics = Just (LSP.List [diagnostic]) + , _kind = Just LSP.CodeActionKind_QuickFix + , _diagnostics = Just [diagnostic] , _isPreferred = Just isPreferred , _disabled = Nothing , _edit = workspaceEdit , _command = command - , _xdata = Nothing + , _data_ = Nothing } mkSuppressHintTextEdits :: DynFlags -> T.Text -> T.Text -> [LSP.TextEdit] @@ -525,7 +529,7 @@ applyAllCmd recorder ide verTxtDocId = do case res of Left err -> pure $ Left (responseError (T.pack $ "hlint:applyAll: " ++ show err)) Right fs -> do - _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ()) + _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ()) pure $ Right Null -- --------------------------------------------------------------------- @@ -556,7 +560,7 @@ applyOneCmd recorder ide (AOP verTxtDocId pos title) = do case res of Left err -> pure $ Left (responseError (T.pack $ "hlint:applyOne: " ++ show err)) Right fs -> do - _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ()) + _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing fs) (\_ -> pure ()) pure $ Right Null applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either String WorkspaceEdit) diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 17ba75046c..a0790c89bf 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeOperators #-} @@ -6,20 +7,21 @@ module Main ( main ) where -import Control.Lens ((^.)) -import Control.Monad (when) -import Data.Aeson (Value (..), object, toJSON, (.=)) -import Data.Functor (void) -import Data.List (find) -import qualified Data.Map as Map -import Data.Maybe (fromJust, isJust) -import qualified Data.Text as T -import Ide.Plugin.Config (Config (..), PluginConfig (..)) -import qualified Ide.Plugin.Config as Plugin -import qualified Ide.Plugin.Hlint as HLint -import Ide.Types (PluginId) -import qualified Language.LSP.Types.Lens as L -import System.FilePath (()) +import Control.Lens ((^.)) +import Control.Monad (when) +import Data.Aeson (Value (..), object, toJSON, (.=)) +import Data.Functor (void) +import Data.List (find) +import qualified Data.Map as Map +import Data.Maybe (fromJust, isJust) +import Data.Row ((.+), (.==)) +import qualified Data.Text as T +import Ide.Plugin.Config (Config (..), PluginConfig (..)) +import qualified Ide.Plugin.Config as Plugin +import qualified Ide.Plugin.Hlint as HLint +import Ide.Types (PluginId) +import qualified Language.LSP.Protocol.Lens as L +import System.FilePath (()) import Test.Hls main :: IO () @@ -77,7 +79,7 @@ suggestionsTests = liftIO $ do length diags @?= 2 -- "Eta Reduce" and "Redundant Id" reduceDiag ^. L.range @?= Range (Position 1 0) (Position 1 12) - reduceDiag ^. L.severity @?= Just DsInfo + reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Information reduceDiag ^. L.code @?= Just (InR "refact:Eta reduce") reduceDiag ^. L.source @?= Just "hlint" @@ -123,15 +125,16 @@ suggestionsTests = doc <- openDoc "Base.hs" "haskell" testHlintDiagnostics doc - let change = TextDocumentContentChangeEvent - (Just (Range (Position 1 8) (Position 1 12))) - Nothing "x" + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 1 8) (Position 1 12) + .+ #rangeLength .== Nothing + .+ #text .== "x" changeDoc doc [change] expectNoMoreDiagnostics 3 doc "hlint" - let change' = TextDocumentContentChangeEvent - (Just (Range (Position 1 8) (Position 1 12))) - Nothing "id x" + let change' = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 1 8) (Position 1 12) + .+ #rangeLength .== Nothing + .+ #text .== "id x" + changeDoc doc [change'] testHlintDiagnostics doc @@ -323,7 +326,7 @@ configTests = testGroup "hlint plugin config" [ liftIO $ do length diags' @?= 1 d ^. L.range @?= Range (Position 1 10) (Position 1 21) - d ^. L.severity @?= Just DsInfo + d ^. L.severity @?= Just DiagnosticSeverity_Information ] testDir :: FilePath diff --git a/plugins/hls-module-name-plugin/hls-module-name-plugin.cabal b/plugins/hls-module-name-plugin/hls-module-name-plugin.cabal index f0e7a60e4a..167575e510 100644 --- a/plugins/hls-module-name-plugin/hls-module-name-plugin.cabal +++ b/plugins/hls-module-name-plugin/hls-module-name-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-module-name-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Module name plugin for Haskell Language Server description: Please see the README on GitHub at @@ -30,10 +30,11 @@ library build-depends: , aeson , base >=4.12 && <5 + , containers , directory , filepath - , ghcide == 2.0.0.0 - , hls-plugin-api == 2.0.0.0 + , ghcide == 2.1.0.0 + , hls-plugin-api == 2.1.0.0 , lsp , text , transformers @@ -52,4 +53,4 @@ test-suite tests , base , filepath , hls-module-name-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs index 9bca69854c..f9336920da 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -23,10 +23,10 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe import Data.Aeson (Value (Null), toJSON) import Data.Char (isLower) -import qualified Data.HashMap.Strict as HashMap import Data.List (intercalate, isPrefixOf, minimumBy) import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map import Data.Maybe (fromMaybe, maybeToList) import Data.Ord (comparing) import Data.String (IsString) @@ -53,11 +53,9 @@ import Development.IDE.GHC.Compat (GenLocated (L), pm_parsed_source, unLoc) import Development.IDE.Types.Logger (Pretty (..)) import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (Null) import Language.LSP.Server -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) import Language.LSP.VFS (virtualFileText) import System.Directory (makeAbsolute) import System.FilePath (dropExtension, normalise, @@ -69,7 +67,7 @@ import System.FilePath (dropExtension, normalise, descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeLens (codeLens recorder) + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens (codeLens recorder) , pluginCommands = [PluginCommand updateModuleNameCommand "set name of module to match with file path" (command recorder)] } @@ -77,9 +75,9 @@ updateModuleNameCommand :: IsString p => p updateModuleNameCommand = "updateModuleName" -- | Generate code lenses -codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'TextDocumentCodeLens +codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens codeLens recorder state pluginId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = - Right . List . maybeToList . (asCodeLens <$>) <$> action recorder state uri + Right . InL . maybeToList . (asCodeLens <$>) <$> action recorder state uri where asCodeLens :: Action -> CodeLens asCodeLens Replace{..} = CodeLens aRange (Just cmd) Nothing @@ -93,9 +91,9 @@ command recorder state uri = do forM_ actMaybe $ \Replace{..} -> let -- | Convert an Action to the corresponding edit operation - edit = WorkspaceEdit (Just . HashMap.singleton aUri $ List [TextEdit aRange aCode]) Nothing Nothing + edit = WorkspaceEdit (Just $ Map.singleton aUri [TextEdit aRange aCode]) Nothing Nothing in - void $ sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (const (pure ())) + void $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (const (pure ())) pure $ Right Null -- | A source code change diff --git a/plugins/hls-module-name-plugin/test/Main.hs b/plugins/hls-module-name-plugin/test/Main.hs index 840bf4ee06..3ad306adc0 100644 --- a/plugins/hls-module-name-plugin/test/Main.hs +++ b/plugins/hls-module-name-plugin/test/Main.hs @@ -21,22 +21,22 @@ tests = [ goldenWithModuleName "Add module header to empty module" "TEmptyModule" $ \doc -> do [CodeLens { _command = Just c }] <- getCodeLenses doc executeCommand c - void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) , goldenWithModuleName "Fix wrong module name" "TWrongModuleName" $ \doc -> do [CodeLens { _command = Just c }] <- getCodeLenses doc executeCommand c - void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) , goldenWithModuleName "Must infer module name as Main, if the file name starts with a lowercase" "mainlike" $ \doc -> do [CodeLens { _command = Just c }] <- getCodeLenses doc executeCommand c - void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) , goldenWithModuleName "Fix wrong module name in nested directory" "subdir/TWrongModuleName" $ \doc -> do [CodeLens { _command = Just c }] <- getCodeLenses doc executeCommand c - void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) , testCase "Should not show code lens if the module name is correct" $ runSessionWithServer moduleNamePlugin testDataDir $ do doc <- openDoc "CorrectName.hs" "haskell" @@ -47,7 +47,7 @@ tests = , goldenWithModuleName "Fix#3047" "canonicalize/Lib/A" $ \doc -> do [CodeLens { _command = Just c }] <- getCodeLenses doc executeCommand c - void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) , testCase "Keep stale lens even if parse failed" $ do runSessionWithServer moduleNamePlugin testDataDir $ do doc <- openDoc "Stale.hs" "haskell" diff --git a/plugins/hls-ormolu-plugin/hls-ormolu-plugin.cabal b/plugins/hls-ormolu-plugin/hls-ormolu-plugin.cabal index 7bc6beea6e..15ecbc9b0e 100644 --- a/plugins/hls-ormolu-plugin/hls-ormolu-plugin.cabal +++ b/plugins/hls-ormolu-plugin/hls-ormolu-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-ormolu-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Integration with the Ormolu code formatter description: Please see the README on GitHub at @@ -32,8 +32,8 @@ library , filepath , ghc , ghc-boot-th - , ghcide == 2.0.0.0 - , hls-plugin-api == 2.0.0.0 + , ghcide == 2.1.0.0 + , hls-plugin-api == 2.1.0.0 , lens , lsp , ormolu ^>=0.1.2 || ^>= 0.2 || ^>= 0.3 || ^>= 0.5 @@ -53,6 +53,6 @@ test-suite tests , base , filepath , hls-ormolu-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , lsp-types , ormolu diff --git a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs index d34fc837bc..dc9c46cd76 100644 --- a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs +++ b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs @@ -2,7 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} - +{-# LANGUAGE TypeOperators #-} module Ide.Plugin.Ormolu ( descriptor , provider @@ -21,8 +21,9 @@ import qualified Development.IDE.GHC.Compat.Util as S import GHC.LanguageExtensions.Type import Ide.PluginUtils import Ide.Types hiding (Config) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import Language.LSP.Server hiding (defaultConfig) -import Language.LSP.Types import Ormolu import System.FilePath (takeFileName) @@ -75,9 +76,9 @@ provider ideState typ contents fp _ = withIndefiniteProgress title Cancellable $ where title = T.pack $ "Formatting " <> takeFileName (fromNormalizedFilePath fp) - ret :: Either SomeException T.Text -> Either ResponseError (List TextEdit) + ret :: Either SomeException T.Text -> Either ResponseError ([TextEdit] |? Null) ret (Left err) = Left . responseError . T.pack $ "ormoluCmd: " ++ show err - ret (Right new) = Right $ makeDiffTextEdit contents new + ret (Right new) = Right $ InL $ makeDiffTextEdit contents new fromDyn :: D.DynFlags -> [DynOption] fromDyn df = diff --git a/plugins/hls-ormolu-plugin/test/Main.hs b/plugins/hls-ormolu-plugin/test/Main.hs index f395b6a2d3..bacb9daa30 100644 --- a/plugins/hls-ormolu-plugin/test/Main.hs +++ b/plugins/hls-ormolu-plugin/test/Main.hs @@ -4,8 +4,8 @@ module Main ( main ) where -import qualified Ide.Plugin.Ormolu as Ormolu -import Language.LSP.Types +import qualified Ide.Plugin.Ormolu as Ormolu +import Language.LSP.Protocol.Types import System.FilePath import Test.Hls diff --git a/plugins/hls-overloaded-record-dot-plugin/hls-overloaded-record-dot-plugin.cabal b/plugins/hls-overloaded-record-dot-plugin/hls-overloaded-record-dot-plugin.cabal index d39f780614..8010c90f26 100644 --- a/plugins/hls-overloaded-record-dot-plugin/hls-overloaded-record-dot-plugin.cabal +++ b/plugins/hls-overloaded-record-dot-plugin/hls-overloaded-record-dot-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hls-overloaded-record-dot-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Overloaded record dot plugin for Haskell Language Server description: Please see the README on GitHub at diff --git a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs index 0fa03b7b31..5dc7ea586b 100644 --- a/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs +++ b/plugins/hls-overloaded-record-dot-plugin/src/Ide/Plugin/OverloadedRecordDot.hs @@ -18,7 +18,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Except (ExceptT) import Data.Generics (GenericQ, everything, everythingBut, mkQ) -import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map as Map import Data.Maybe (mapMaybe, maybeToList) import Data.Text (Text) import Development.IDE (IdeState, @@ -76,18 +76,17 @@ import Ide.Types (PluginDescriptor (..), PluginMethodHandler, defaultPluginDescriptor, mkPluginHandler) -import Language.LSP.Types (CodeAction (..), - CodeActionKind (CodeActionRefactorRewrite), +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (Method (..), + SMethod (..)) +import Language.LSP.Protocol.Types (CodeAction (..), + CodeActionKind (CodeActionKind_RefactorRewrite), CodeActionParams (..), - Command, List (..), - Method (..), - SMethod (..), - TextEdit (..), + Command, TextEdit (..), WorkspaceEdit (WorkspaceEdit), fromNormalizedUri, normalizedFilePathToUri, - type (|?) (InR)) -import qualified Language.LSP.Types.Lens as L + type (|?) (..)) data Log = LogShake Shake.Log | LogCollectedRecordSelectors [RecordSelectorExpr] @@ -140,11 +139,11 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = - mkPluginHandler STextDocumentCodeAction codeActionProvider + mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider , pluginRules = collectRecSelsRule recorder } -codeActionProvider :: PluginMethodHandler IdeState 'TextDocumentCodeAction +codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) = pluginResponse $ do nfp <- getNormalizedFilePath (caDocId ^. L.uri) @@ -156,9 +155,9 @@ codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) = else Just $ insertNewPragma pragma OverloadedRecordDot edits crs = convertRecordSelectors crs : maybeToList pragmaEdit changes crs = - Just $ HashMap.singleton (fromNormalizedUri + Just $ Map.singleton (fromNormalizedUri (normalizedFilePathToUri nfp)) - (List (edits crs)) + (edits crs) mkCodeAction crs = InR CodeAction { -- We pass the record selector to the title function, so that -- we can have the name of the record selector in the title of @@ -167,16 +166,16 @@ codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) = -- selectors, the disadvantage is we need to print out the -- name of the record selector which will decrease performance _title = mkCodeActionTitle exts crs - , _kind = Just CodeActionRefactorRewrite + , _kind = Just CodeActionKind_RefactorRewrite , _diagnostics = Nothing , _isPreferred = Nothing , _disabled = Nothing , _edit = Just $ WorkspaceEdit (changes crs) Nothing Nothing , _command = Nothing - , _xdata = Nothing + , _data_ = Nothing } actions = map mkCodeAction (RangeMap.filterByRange caRange crsMap) - pure $ List actions + pure $ InL actions where mkCodeActionTitle :: [Extension] -> RecordSelectorExpr-> Text mkCodeActionTitle exts (RecordSelectorExpr _ se _) = diff --git a/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal b/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal index 947b1f808c..3017eb3944 100644 --- a/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal +++ b/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-pragmas-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Pragmas plugin for Haskell Language Server description: Please see the README on GitHub at @@ -30,8 +30,8 @@ library , extra , fuzzy , ghc - , ghcide == 2.0.0.0 - , hls-plugin-api == 2.0.0.0 + , ghcide == 2.1.0.0 + , hls-plugin-api == 2.1.0.0 , lens , lsp , text @@ -53,7 +53,7 @@ test-suite tests , base , filepath , hls-pragmas-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , lens , lsp-types , text diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index 3769271107..bd37f36a8c 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -19,8 +19,8 @@ module Ide.Plugin.Pragmas import Control.Lens hiding (List) import Control.Monad.IO.Class (MonadIO (liftIO)) -import qualified Data.HashMap.Strict as H import Data.List.Extra (nubOrdOn) +import qualified Data.Map as M import Data.Maybe (catMaybes) import qualified Data.Text as T import Development.IDE @@ -28,9 +28,10 @@ import Development.IDE.GHC.Compat import Development.IDE.Plugin.Completions (ghcideCompletionsPluginPriority) import qualified Development.IDE.Spans.Pragmas as Pragmas import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Message as LSP +import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP -import qualified Language.LSP.Types as J -import qualified Language.LSP.Types.Lens as J import qualified Language.LSP.VFS as VFS import qualified Text.Fuzzy as Fuzzy @@ -38,19 +39,19 @@ import qualified Text.Fuzzy as Fuzzy suggestPragmaDescriptor :: PluginId -> PluginDescriptor IdeState suggestPragmaDescriptor plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler J.STextDocumentCodeAction suggestPragmaProvider + { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCodeAction suggestPragmaProvider , pluginPriority = defaultPluginPriority + 1000 } completionDescriptor :: PluginId -> PluginDescriptor IdeState completionDescriptor plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler J.STextDocumentCompletion completion + { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCompletion completion , pluginPriority = ghcideCompletionsPluginPriority + 1 } suggestDisableWarningDescriptor :: PluginId -> PluginDescriptor IdeState suggestDisableWarningDescriptor plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler J.STextDocumentCodeAction suggestDisableWarningProvider + { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCodeAction suggestDisableWarningProvider -- #3636 Suggestions to disable warnings should appear last. , pluginPriority = 0 } @@ -62,16 +63,16 @@ type PragmaEdit = (T.Text, Pragma) data Pragma = LangExt T.Text | OptGHC T.Text deriving (Show, Eq, Ord) -suggestPragmaProvider :: PluginMethodHandler IdeState 'J.TextDocumentCodeAction +suggestPragmaProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction suggestPragmaProvider = mkCodeActionProvider suggest -suggestDisableWarningProvider :: PluginMethodHandler IdeState 'J.TextDocumentCodeAction +suggestDisableWarningProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction suggestDisableWarningProvider = mkCodeActionProvider $ const suggestDisableWarning -mkCodeActionProvider :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'J.TextDocumentCodeAction -mkCodeActionProvider mkSuggest state _plId (J.CodeActionParams _ _ docId _ (J.CodeActionContext (J.List diags) _monly)) - | let J.TextDocumentIdentifier{ _uri = uri } = docId - , Just normalizedFilePath <- J.uriToNormalizedFilePath $ toNormalizedUri uri = do +mkCodeActionProvider :: (Maybe DynFlags -> Diagnostic -> [PragmaEdit]) -> PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction +mkCodeActionProvider mkSuggest state _plId (LSP.CodeActionParams _ _ docId _ (LSP.CodeActionContext diags _monly _)) + | let LSP.TextDocumentIdentifier{ _uri = uri } = docId + , Just normalizedFilePath <- LSP.uriToNormalizedFilePath $ toNormalizedUri uri = do -- ghc session to get some dynflags even if module isn't parsed ghcSession <- liftIO $ runAction "Pragmas.GhcSession" state $ useWithStale GhcSession normalizedFilePath (_, fileContents) <- liftIO $ runAction "Pragmas.GetFileContents" state $ getFileContents normalizedFilePath @@ -83,17 +84,17 @@ mkCodeActionProvider mkSuggest state _plId (J.CodeActionParams _ _ docId _ (J.Co let nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents pedits = (nubOrdOn snd . concat $ mkSuggest parsedModuleDynFlags <$> diags) in - pure $ Right $ List $ pragmaEditToAction uri nextPragmaInfo <$> pedits - Nothing -> pure $ Right $ List [] - | otherwise = pure $ Right $ List [] + pure $ Right $ LSP.InL $ pragmaEditToAction uri nextPragmaInfo <$> pedits + Nothing -> pure $ Right $ LSP.InL [] + | otherwise = pure $ Right $ LSP.InL [] -- | Add a Pragma to the given URI at the top of the file. -- It is assumed that the pragma name is a valid pragma, -- thus, not validated. -pragmaEditToAction :: Uri -> Pragmas.NextPragmaInfo -> PragmaEdit -> (J.Command J.|? J.CodeAction) +pragmaEditToAction :: Uri -> Pragmas.NextPragmaInfo -> PragmaEdit -> (LSP.Command LSP.|? LSP.CodeAction) pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdits } (title, p) = - J.InR $ J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) Nothing Nothing (Just edit) Nothing Nothing + LSP.InR $ LSP.CodeAction title (Just LSP.CodeActionKind_QuickFix) (Just []) Nothing Nothing (Just edit) Nothing Nothing where render (OptGHC x) = "{-# OPTIONS_GHC -Wno-" <> x <> " #-}\n" render (LangExt x) = "{-# LANGUAGE " <> x <> " #-}\n" @@ -103,13 +104,13 @@ pragmaEditToAction uri Pragmas.NextPragmaInfo{ nextPragmaLine, lineSplitTextEdit -- edits in reverse order than lsp (tried in both coc.nvim and vscode) textEdits = if | Just (Pragmas.LineSplitTextEdits insertTextEdit deleteTextEdit) <- lineSplitTextEdits - , let J.TextEdit{ _range, _newText } = insertTextEdit -> - [J.TextEdit _range (render p <> _newText), deleteTextEdit] - | otherwise -> [J.TextEdit pragmaInsertRange (render p)] + , let LSP.TextEdit{ _range, _newText } = insertTextEdit -> + [LSP.TextEdit _range (render p <> _newText), deleteTextEdit] + | otherwise -> [LSP.TextEdit pragmaInsertRange (render p)] edit = - J.WorkspaceEdit - (Just $ H.singleton uri (J.List textEdits)) + LSP.WorkspaceEdit + (Just $ M.singleton uri textEdits) Nothing Nothing @@ -121,7 +122,7 @@ suggest dflags diag = suggestDisableWarning :: Diagnostic -> [PragmaEdit] suggestDisableWarning Diagnostic {_code} - | Just (J.InR (T.stripPrefix "-W" -> Just w)) <- _code + | Just (LSP.InR (T.stripPrefix "-W" -> Just w)) <- _code , w `notElem` warningBlacklist = pure ("Disable \"" <> w <> "\" warnings", OptGHC w) | otherwise = [] @@ -194,21 +195,21 @@ allPragmas = flags :: [T.Text] flags = map (T.pack . stripLeading '-') $ flagsForCompletion False -completion :: PluginMethodHandler IdeState 'J.TextDocumentCompletion +completion :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCompletion completion _ide _ complParams = do - let (J.TextDocumentIdentifier uri) = complParams ^. J.textDocument - position = complParams ^. J.position + let (LSP.TextDocumentIdentifier uri) = complParams ^. L.textDocument + position = complParams ^. L.position contents <- LSP.getVirtualFile $ toNormalizedUri uri - fmap (Right . J.InL) $ case (contents, uriToFilePath' uri) of + fmap (Right . LSP.InL) $ case (contents, uriToFilePath' uri) of (Just cnts, Just _path) -> - J.List . result <$> VFS.getCompletionPrefix position cnts + result <$> VFS.getCompletionPrefix position cnts where result (Just pfix) | "{-# language" `T.isPrefixOf` line = map buildCompletion (Fuzzy.simpleFilter (VFS.prefixText pfix) allPragmas) | "{-# options_ghc" `T.isPrefixOf` line - = map buildCompletion + = map buildCompletion (Fuzzy.simpleFilter (VFS.prefixText pfix) flags) | "{-#" `T.isPrefixOf` line = [ mkPragmaCompl (a <> suffix) b c @@ -250,7 +251,8 @@ completion _ide _ complParams = do | "}" `T.isSuffixOf` line = " #-" | otherwise = " #-}" result Nothing = [] - _ -> return $ J.List [] + _ -> return $ [] + ----------------------------------------------------------------------- -- | Pragma where exist @@ -286,11 +288,11 @@ validPragmas = , ("INCOHERENT" , "INCOHERENT" , "{-# INCOHERENT #-}" , CanInline) ] -mkPragmaCompl :: T.Text -> T.Text -> T.Text -> J.CompletionItem +mkPragmaCompl :: T.Text -> T.Text -> T.Text -> LSP.CompletionItem mkPragmaCompl insertText label detail = - J.CompletionItem label (Just J.CiKeyword) Nothing (Just detail) - Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just J.Snippet) - Nothing Nothing Nothing Nothing Nothing Nothing + LSP.CompletionItem label Nothing (Just LSP.CompletionItemKind_Keyword) Nothing (Just detail) + Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just LSP.InsertTextFormat_Snippet) + Nothing Nothing Nothing Nothing Nothing Nothing Nothing stripLeading :: Char -> String -> String @@ -300,8 +302,11 @@ stripLeading c (s:ss) | otherwise = s:ss -buildCompletion :: T.Text -> J.CompletionItem +buildCompletion :: T.Text -> LSP.CompletionItem buildCompletion label = - J.CompletionItem label (Just J.CiKeyword) Nothing Nothing + LSP.CompletionItem label Nothing (Just LSP.CompletionItemKind_Keyword) Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing + + + diff --git a/plugins/hls-pragmas-plugin/test/Main.hs b/plugins/hls-pragmas-plugin/test/Main.hs index 517e86cfda..3a0260eb1a 100644 --- a/plugins/hls-pragmas-plugin/test/Main.hs +++ b/plugins/hls-pragmas-plugin/test/Main.hs @@ -4,15 +4,15 @@ module Main ( main ) where -import Control.Lens ((<&>), (^.)) +import Control.Lens ((<&>), (^.)) import Data.Aeson import Data.Foldable -import qualified Data.Text as T +import qualified Data.Text as T import Ide.Plugin.Pragmas -import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Protocol.Lens as L import System.FilePath import Test.Hls -import Test.Hls.Util (onlyWorkForGhcVersions) +import Test.Hls.Util (onlyWorkForGhcVersions) main :: IO () main = defaultTestRunner tests @@ -124,11 +124,11 @@ codeActionTests' = completionTests :: TestTree completionTests = testGroup "completions" - [ completionTest "completes pragmas" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #-}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 34, 0, 4] - , completionTest "completes pragmas with existing closing pragma bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 31, 0, 4] - , completionTest "completes pragmas with existing closing comment bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #") (Just "{-# LANGUAGE #-}") [0, 4, 0, 32, 0, 4] - , completionTest "completes pragmas with existing closing bracket" "Completion.hs" "" "LANGUAGE" (Just Snippet) (Just "LANGUAGE ${1:extension} #-") (Just "{-# LANGUAGE #-}") [0, 4, 0, 33, 0, 4] - , completionTest "completes options pragma" "Completion.hs" "OPTIONS" "OPTIONS_GHC" (Just Snippet) (Just "OPTIONS_GHC -${1:option} #-}") (Just "{-# OPTIONS_GHC #-}") [0, 4, 0, 34, 0, 4] + [ completionTest "completes pragmas" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #-}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 34, 0, 4] + , completionTest "completes pragmas with existing closing pragma bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension}") (Just "{-# LANGUAGE #-}") [0, 4, 0, 31, 0, 4] + , completionTest "completes pragmas with existing closing comment bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #") (Just "{-# LANGUAGE #-}") [0, 4, 0, 32, 0, 4] + , completionTest "completes pragmas with existing closing bracket" "Completion.hs" "" "LANGUAGE" (Just InsertTextFormat_Snippet) (Just "LANGUAGE ${1:extension} #-") (Just "{-# LANGUAGE #-}") [0, 4, 0, 33, 0, 4] + , completionTest "completes options pragma" "Completion.hs" "OPTIONS" "OPTIONS_GHC" (Just InsertTextFormat_Snippet) (Just "OPTIONS_GHC -${1:option} #-}") (Just "{-# OPTIONS_GHC #-}") [0, 4, 0, 34, 0, 4] , completionTest "completes ghc options pragma values" "Completion.hs" "{-# OPTIONS_GHC -Wno-red #-}\n" "Wno-redundant-constraints" Nothing Nothing Nothing [0, 0, 0, 0, 0, 24] , completionTest "completes language extensions" "Completion.hs" "" "OverloadedStrings" Nothing Nothing Nothing [0, 24, 0, 31, 0, 24] , completionTest "completes language extensions case insensitive" "Completion.hs" "lAnGuaGe Overloaded" "OverloadedStrings" Nothing Nothing Nothing [0, 4, 0, 34, 0, 24] @@ -149,7 +149,7 @@ completionSnippetTests = CanInline -> "something " input = inputPrefix <> (T.toLower $ T.init label) in completionTest (T.unpack label) - "Completion.hs" input label (Just Snippet) + "Completion.hs" input label (Just InsertTextFormat_Snippet) (Just $ "{-# " <> insertText <> " #-}") (Just detail) [0, 0, 0, 34, 0, fromIntegral $ T.length input]) @@ -187,7 +187,7 @@ completionTest testComment fileName replacementText expectedLabel expectedFormat item <- getCompletionByLabel expectedLabel compls liftIO $ do item ^. L.label @?= expectedLabel - item ^. L.kind @?= Just CiKeyword + item ^. L.kind @?= Just CompletionItemKind_Keyword item ^. L.insertTextFormat @?= expectedFormat item ^. L.insertText @?= expectedInsertText item ^. L.detail @?= detail diff --git a/plugins/hls-qualify-imported-names-plugin/hls-qualify-imported-names-plugin.cabal b/plugins/hls-qualify-imported-names-plugin/hls-qualify-imported-names-plugin.cabal index c829fdae2c..713e73d79f 100644 --- a/plugins/hls-qualify-imported-names-plugin/hls-qualify-imported-names-plugin.cabal +++ b/plugins/hls-qualify-imported-names-plugin/hls-qualify-imported-names-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hls-qualify-imported-names-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: A Haskell Language Server plugin that qualifies imported names description: Please see the README on GitHub at @@ -30,9 +30,9 @@ library , containers , deepseq , ghc - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , hls-graph - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , lsp , text , unordered-containers @@ -55,4 +55,4 @@ test-suite tests , text , filepath , hls-qualify-imported-names-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 diff --git a/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs index 62d39bfd6f..a33d95cfcf 100644 --- a/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs +++ b/plugins/hls-qualify-imported-names-plugin/src/Ide/Plugin/QualifyImportedNames.hs @@ -7,74 +7,73 @@ module Ide.Plugin.QualifyImportedNames (descriptor) where -import Control.Monad (foldM) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.State.Strict (State) -import qualified Control.Monad.Trans.State.Strict as State -import Data.DList (DList) -import qualified Data.DList as DList -import Data.Foldable (Foldable (foldl'), find) -import qualified Data.HashMap.Strict as HashMap -import Data.List (sortOn) -import qualified Data.List as List -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Text (Text) -import qualified Data.Text as Text -import Development.IDE (spanContainsRange) -import Development.IDE.Core.RuleTypes (GetFileContents (GetFileContents), - GetHieAst (GetHieAst), - HieAstResult (HAR, refMap), - TcModuleResult (TcModuleResult, tmrParsed, tmrTypechecked), - TypeCheck (TypeCheck)) -import Development.IDE.Core.Service (runAction) -import Development.IDE.Core.Shake (IdeState, use) -import Development.IDE.GHC.Compat (ContextInfo (Use), - GenLocated (..), GhcPs, - GlobalRdrElt, GlobalRdrEnv, - HsModule (hsmodImports), - Identifier, - IdentifierDetails (IdentifierDetails, identInfo), - ImpDeclSpec (ImpDeclSpec, is_as, is_dloc, is_qual), - ImportSpec (ImpSpec), - LImportDecl, ModuleName, - Name, NameEnv, OccName, - ParsedModule, RefMap, Span, - SrcSpan, - TcGblEnv (tcg_rdr_env), - emptyUFM, globalRdrEnvElts, - gre_imp, gre_name, locA, - lookupNameEnv, - moduleNameString, - nameOccName, occNameString, - pattern GRE, - pattern ParsedModule, - plusUFM_C, pm_parsed_source, - srcSpanEndCol, - srcSpanEndLine, - srcSpanStartCol, - srcSpanStartLine, unitUFM) -import Development.IDE.GHC.Error (isInsideSrcSpan) -import Development.IDE.Types.Diagnostics (List (List)) -import Development.IDE.Types.Location (NormalizedFilePath, - Position (Position), - Range (Range), Uri, - toNormalizedUri) -import Ide.Types (PluginDescriptor (pluginHandlers), - PluginId, - PluginMethodHandler, - defaultPluginDescriptor, - mkPluginHandler) -import Language.LSP.Types (CodeAction (CodeAction, _command, _diagnostics, _disabled, _edit, _isPreferred, _kind, _title, _xdata), - CodeActionKind (CodeActionQuickFix), - CodeActionParams (CodeActionParams), - Method (TextDocumentCodeAction), - SMethod (STextDocumentCodeAction), - TextDocumentIdentifier (TextDocumentIdentifier), - TextEdit (TextEdit), - WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), - type (|?) (InR), - uriToNormalizedFilePath) +import Control.Monad (foldM) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.State.Strict (State) +import qualified Control.Monad.Trans.State.Strict as State +import Data.DList (DList) +import qualified Data.DList as DList +import Data.Foldable (Foldable (foldl'), find) +import qualified Data.HashMap.Strict as HashMap +import Data.List (sortOn) +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import Development.IDE (spanContainsRange) +import Development.IDE.Core.RuleTypes (GetFileContents (GetFileContents), + GetHieAst (GetHieAst), + HieAstResult (HAR, refMap), + TcModuleResult (TcModuleResult, tmrParsed, tmrTypechecked), + TypeCheck (TypeCheck)) +import Development.IDE.Core.Service (runAction) +import Development.IDE.Core.Shake (IdeState, use) +import Development.IDE.GHC.Compat (ContextInfo (Use), + GenLocated (..), GhcPs, + GlobalRdrElt, GlobalRdrEnv, + HsModule (hsmodImports), + Identifier, + IdentifierDetails (IdentifierDetails, identInfo), + ImpDeclSpec (ImpDeclSpec, is_as, is_dloc, is_qual), + ImportSpec (ImpSpec), + LImportDecl, ModuleName, + Name, NameEnv, OccName, + ParsedModule, RefMap, Span, + SrcSpan, + TcGblEnv (tcg_rdr_env), + emptyUFM, globalRdrEnvElts, + gre_imp, gre_name, locA, + lookupNameEnv, + moduleNameString, + nameOccName, occNameString, + pattern GRE, + pattern ParsedModule, + plusUFM_C, pm_parsed_source, + srcSpanEndCol, + srcSpanEndLine, + srcSpanStartCol, + srcSpanStartLine, unitUFM) +import Development.IDE.GHC.Error (isInsideSrcSpan) +import Development.IDE.Types.Location (NormalizedFilePath, + Position (Position), + Range (Range), Uri, + toNormalizedUri) +import Ide.Types (PluginDescriptor (pluginHandlers), + PluginId, + PluginMethodHandler, + defaultPluginDescriptor, + mkPluginHandler) +import Language.LSP.Protocol.Message (Method (Method_TextDocumentCodeAction), + SMethod (SMethod_TextDocumentCodeAction)) +import Language.LSP.Protocol.Types (CodeAction (CodeAction, _command, _data_, _diagnostics, _disabled, _edit, _isPreferred, _kind, _title), + CodeActionKind (CodeActionKind_QuickFix), + CodeActionParams (CodeActionParams), + TextDocumentIdentifier (TextDocumentIdentifier), + TextEdit (TextEdit), + WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), + type (|?) (InL, InR), + uriToNormalizedFilePath) thenCmp :: Ordering -> Ordering -> Ordering {-# INLINE thenCmp #-} @@ -84,7 +83,7 @@ thenCmp ordering _ = ordering descriptor :: PluginId -> PluginDescriptor IdeState descriptor pluginId = (defaultPluginDescriptor pluginId) { pluginHandlers = mconcat - [ mkPluginHandler STextDocumentCodeAction codeActionProvider + [ mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider ] } @@ -98,15 +97,15 @@ findLImportDeclAt range parsedModule makeCodeActions :: Uri -> [TextEdit] -> [a |? CodeAction] makeCodeActions uri textEdits = [InR CodeAction {..} | not (null textEdits)] where _title = "Qualify imported names" - _kind = Just CodeActionQuickFix + _kind = Just CodeActionKind_QuickFix _command = Nothing _edit = Just WorkspaceEdit {..} - _changes = Just $ HashMap.singleton uri $ List textEdits + _changes = Just $ Map.singleton uri textEdits _documentChanges = Nothing _diagnostics = Nothing _isPreferred = Nothing _disabled = Nothing - _xdata = Nothing + _data_ = Nothing _changeAnnotations = Nothing getTypeCheckedModule :: IdeState -> NormalizedFilePath -> IO (Maybe TcModuleResult) @@ -236,7 +235,7 @@ usedIdentifiersToTextEdits range nameToImportedByMap sourceText usedIdentifiers -- 2. refMap from GetHieAst contains location of names and how they are used. -- 3. For each used name in refMap check whether the name comes from an import -- at the origin of the code action. -codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction +codeActionProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionProvider ideState pluginId (CodeActionParams _ _ documentId range context) | TextDocumentIdentifier uri <- documentId , Just normalizedFilePath <- uriToNormalizedFilePath (toNormalizedUri uri) = liftIO $ do @@ -251,8 +250,8 @@ codeActionProvider ideState pluginId (CodeActionParams _ _ documentId range cont , let nameToImportedByMap = globalRdrEnvToNameToImportedByMap globalRdrEnv , let usedIdentifiers = refMapToUsedIdentifiers refMap , let textEdits = usedIdentifiersToTextEdits range nameToImportedByMap sourceText usedIdentifiers -> - pure $ Right $ List (makeCodeActions uri textEdits) - | otherwise -> pure $ Right $ List [] - | otherwise -> pure $ Right $ List [] - | otherwise = pure $ Right $ List [] + pure $ Right $ InL (makeCodeActions uri textEdits) + | otherwise -> pure $ Right $ InL [] + | otherwise -> pure $ Right $ InL [] + | otherwise = pure $ Right $ InL [] diff --git a/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal b/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal index 41bb40f822..7cd78a21f8 100644 --- a/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal +++ b/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hls-refactor-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Exactprint refactorings for Haskell Language Server description: Please see the README on GitHub at @@ -68,8 +68,8 @@ library , ghc-boot , regex-tdfa , text-rope - , ghcide == 2.0.0.0 - , hls-plugin-api == 2.0.0.0 + , ghcide == 2.1.0.0 + , hls-plugin-api == 2.1.0.0 , lsp , text , transformers @@ -100,7 +100,7 @@ test-suite tests , base , filepath , hls-refactor-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , lens , lsp-types , text diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs index cd522278fa..661f7dbcce 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -90,8 +90,7 @@ import Generics.SYB.GHC import qualified GHC.Generics as GHC import Ide.PluginUtils import Language.Haskell.GHC.ExactPrint.Parsers -import Language.LSP.Types -import Language.LSP.Types.Capabilities (ClientCapabilities) +import Language.LSP.Protocol.Types import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs index 46c1a43d1a..97fdd80e70 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -22,7 +22,7 @@ import Control.Concurrent.STM.Stats (atomically) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Maybe -import Data.Aeson +import Data.Aeson as A import Data.Char import qualified Data.DList as DL import Data.Function @@ -75,25 +75,25 @@ import GHC.Parser.Annotation (TokenLocatio #endif import Ide.PluginUtils (subRange) import Ide.Types -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (ApplyWorkspaceEditParams (..), +import Language.LSP.Protocol.Message (ResponseError, + SMethod (..)) +import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (..), CodeAction (..), CodeActionContext (CodeActionContext, _diagnostics), - CodeActionKind (CodeActionQuickFix), + CodeActionKind (CodeActionKind_QuickFix), CodeActionParams (CodeActionParams), Command, Diagnostic (..), - List (..), MessageType (..), - ResponseError, - SMethod (..), + Null, ShowMessageParams (..), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit, _range), UInt, WorkspaceEdit (WorkspaceEdit, _changeAnnotations, _changes, _documentChanges), - type (|?) (InR), + type (|?) (InL, InR), uriToFilePath) +import qualified Language.LSP.Server as LSP import Language.LSP.VFS (VirtualFile, _file_text) import qualified Text.Fuzzy.Parallel as TFP @@ -123,8 +123,8 @@ codeAction :: IdeState -> PluginId -> CodeActionParams - -> LSP.LspM c (Either ResponseError (List (Command |? CodeAction))) -codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs}) = do + -> LSP.LspM c (Either ResponseError ([(Command |? CodeAction)] |? Null)) +codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics= xs}) = do contents <- LSP.getVirtualFile $ toNormalizedUri uri liftIO $ do let text = Rope.toText . (_file_text :: VirtualFile -> Rope.Rope) <$> contents @@ -134,7 +134,7 @@ codeAction state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) _range Cod let actions = caRemoveRedundantImports parsedModule text diag xs uri <> caRemoveInvalidExports parsedModule text diag xs uri - pure $ Right $ List actions + pure $ Right $ InL $ actions ------------------------------------------------------------------------------------------------- @@ -153,7 +153,7 @@ iePluginDescriptor recorder plId = , wrap suggestAddRecordFieldImport ] plId - in mkExactprintPluginDescriptor recorder $ old {pluginHandlers = pluginHandlers old <> mkPluginHandler STextDocumentCodeAction codeAction } + in mkExactprintPluginDescriptor recorder $ old {pluginHandlers = pluginHandlers old <> mkPluginHandler SMethod_TextDocumentCodeAction codeAction } typeSigsPluginDescriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState typeSigsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $ @@ -200,10 +200,10 @@ extendImportHandler :: CommandFunction IdeState ExtendImport 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 . Map.toList + let (_, (head -> TextEdit {_range})) = fromJust $ _changes >>= listToMaybe . M.toList srcSpan = rangeToSrcSpan nfp _range - LSP.sendNotification SWindowShowMessage $ - ShowMessageParams MtInfo $ + LSP.sendNotification SMethod_WindowShowMessage $ + ShowMessageParams MessageType_Info $ "Import " <> maybe ("‘" <> newThing) (\x -> "‘" <> x <> " (" <> newThing <> ")") thingParent <> "’ from " @@ -211,8 +211,8 @@ extendImportHandler ideState edit@ExtendImport {..} = do <> " (at " <> printOutputable srcSpan <> ")" - void $ LSP.sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return $ Right Null + void $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) + return $ Right A.Null extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit) extendImportHandler' ideState ExtendImport {..} @@ -249,7 +249,7 @@ extendImportHandler' ideState ExtendImport {..} Nothing -> newThing Just p -> p <> "(" <> newThing <> ")" t <- liftMaybe $ snd <$> newImportToEdit n ps (fromMaybe "" contents) - return (nfp, WorkspaceEdit {_changes=Just (GHC.Exts.fromList [(doc,List [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing}) + return (nfp, WorkspaceEdit {_changes=Just (GHC.Exts.fromList [(doc, [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing}) | otherwise = mzero @@ -493,14 +493,14 @@ caRemoveRedundantImports m contents digs ctxDigs uri = caRemoveCtx ++ [caRemoveAll] | otherwise = [] where - removeSingle title tedit diagnostic = mkCA title (Just CodeActionQuickFix) Nothing [diagnostic] WorkspaceEdit{..} where - _changes = Just $ Map.singleton uri $ List tedit + removeSingle title tedit diagnostic = mkCA title (Just CodeActionKind_QuickFix) Nothing [diagnostic] WorkspaceEdit{..} where + _changes = Just $ M.singleton uri tedit _documentChanges = Nothing _changeAnnotations = Nothing removeAll tedit = InR $ CodeAction{..} where - _changes = Just $ Map.singleton uri $ List tedit + _changes = Just $ M.singleton uri tedit _title = "Remove all redundant imports" - _kind = Just CodeActionQuickFix + _kind = Just CodeActionKind_QuickFix _diagnostics = Nothing _documentChanges = Nothing _edit = Just WorkspaceEdit{..} @@ -508,7 +508,7 @@ caRemoveRedundantImports m contents digs ctxDigs uri _isPreferred = Just True _command = Nothing _disabled = Nothing - _xdata = Nothing + _data_ = Nothing _changeAnnotations = Nothing caRemoveInvalidExports :: Maybe ParsedModule -> Maybe T.Text -> [Diagnostic] -> [Diagnostic] -> Uri -> [Command |? CodeAction] @@ -537,24 +537,24 @@ caRemoveInvalidExports m contents digs ctxDigs uri removeSingle (_, _, []) = Nothing removeSingle (title, diagnostic, ranges) = Just $ InR $ CodeAction{..} where tedit = concatMap (\r -> [TextEdit r ""]) $ nubOrd ranges - _changes = Just $ Map.singleton uri $ List tedit + _changes = Just $ M.singleton uri tedit _title = title - _kind = Just CodeActionQuickFix - _diagnostics = Just $ List [diagnostic] + _kind = Just CodeActionKind_QuickFix + _diagnostics = Just [diagnostic] _documentChanges = Nothing _edit = Just WorkspaceEdit{..} _command = Nothing -- See Note [Removing imports is preferred] _isPreferred = Just True _disabled = Nothing - _xdata = Nothing + _data_ = Nothing _changeAnnotations = Nothing removeAll [] = Nothing removeAll ranges = Just $ InR $ CodeAction{..} where tedit = concatMap (\r -> [TextEdit r ""]) ranges - _changes = Just $ Map.singleton uri $ List tedit + _changes = Just $ M.singleton uri tedit _title = "Remove all redundant exports" - _kind = Just CodeActionQuickFix + _kind = Just CodeActionKind_QuickFix _diagnostics = Nothing _documentChanges = Nothing _edit = Just WorkspaceEdit{..} @@ -562,7 +562,7 @@ caRemoveInvalidExports m contents digs ctxDigs uri -- See Note [Removing imports is preferred] _isPreferred = Just True _disabled = Nothing - _xdata = Nothing + _data_ = Nothing _changeAnnotations = Nothing suggestRemoveRedundantExport :: ParsedModule -> Diagnostic -> Maybe (T.Text, [Range]) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs index 4338e07a77..96cf3dfc04 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/Args.hs @@ -19,8 +19,8 @@ import Control.Monad.Reader import Control.Monad.Trans.Maybe import Data.Either (fromRight, partitionEithers) -import qualified Data.HashMap.Strict as Map import Data.IORef.Extra +import qualified Data.Map as Map import Data.Maybe (fromMaybe) import qualified Data.Text as T import Development.IDE hiding @@ -38,8 +38,9 @@ import Development.IDE.Types.Exports (ExportsMap) import Development.IDE.Types.Options (IdeOptions) import Ide.Plugin.Config (Config) import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP -import Language.LSP.Types type CodeActionTitle = T.Text @@ -52,8 +53,8 @@ type GhcideCodeAction = ExceptT ResponseError (ReaderT CodeActionArgs IO) Ghcide ------------------------------------------------------------------------------------------------- {-# ANN runGhcideCodeAction ("HLint: ignore Move guards forward" :: String) #-} -runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult -runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = List diags}) codeAction = do +runGhcideCodeAction :: LSP.MonadLsp Config m => IdeState -> MessageParams Method_TextDocumentCodeAction -> GhcideCodeAction -> m GhcideCodeActionResult +runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _range CodeActionContext {_diagnostics = diags}) codeAction = do let mbFile = toNormalizedFilePath' <$> uriToFilePath uri runRule key = runAction ("GhcideCodeActions." <> show key) state $ runMaybeT $ MaybeT (pure mbFile) >>= MaybeT . use key caaGhcSession <- onceIO $ runRule GhcSession @@ -90,20 +91,20 @@ runGhcideCodeAction state (CodeActionParams _ _ (TextDocumentIdentifier uri) _ra mkCA :: T.Text -> Maybe CodeActionKind -> Maybe Bool -> [Diagnostic] -> WorkspaceEdit -> (Command |? CodeAction) mkCA title kind isPreferred diags edit = - InR $ CodeAction title kind (Just $ List diags) isPreferred Nothing (Just edit) Nothing Nothing + InR $ CodeAction title kind (Just $ diags) isPreferred Nothing (Just edit) Nothing Nothing mkGhcideCAPlugin :: GhcideCodeAction -> PluginId -> PluginDescriptor IdeState mkGhcideCAPlugin codeAction plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeAction $ - \state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext {_diagnostics = List diags}) -> do + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction $ + \state _ params@(CodeActionParams _ _ (TextDocumentIdentifier uri) _ CodeActionContext {_diagnostics = diags}) -> do results <- runGhcideCodeAction state params codeAction pure $ Right $ - List + InL [ mkCA title kind isPreferred diags edit | (title, kind, isPreferred, tedit) <- results, - let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing + let edit = WorkspaceEdit (Just $ Map.singleton uri tedit) Nothing Nothing ] } @@ -193,13 +194,13 @@ instance ToCodeAction a => ToCodeAction (Either ResponseError a) where toCodeAction = either (\err -> ExceptT $ ReaderT $ \_ -> pure $ Left err) toCodeAction instance ToTextEdit a => ToCodeAction (CodeActionTitle, a) where - toCodeAction (title, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just CodeActionQuickFix,Nothing,) <$> toTextEdit caa te + toCodeAction (title, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just CodeActionKind_QuickFix,Nothing,) <$> toTextEdit caa te instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, a) where toCodeAction (title, kind, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just kind,Nothing,) <$> toTextEdit caa te instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionPreferred, a) where - toCodeAction (title, isPreferred, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just CodeActionQuickFix,Just isPreferred,) <$> toTextEdit caa te + toCodeAction (title, isPreferred, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just CodeActionKind_QuickFix,Just isPreferred,) <$> toTextEdit caa te instance ToTextEdit a => ToCodeAction (CodeActionTitle, CodeActionKind, CodeActionPreferred, a) where toCodeAction (title, kind, isPreferred, te) = ExceptT $ ReaderT $ \caa -> Right . pure . (title,Just kind,Just isPreferred,) <$> toTextEdit caa te diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index 275c26c389..74906cb47f 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -32,7 +32,7 @@ import Development.IDE.Spans.Common import GHC.Exts (IsList (fromList)) import GHC.Stack (HasCallStack) import Language.Haskell.GHC.ExactPrint -import Language.LSP.Types +import Language.LSP.Protocol.Types import Development.IDE.Plugin.CodeAction.Util @@ -149,7 +149,7 @@ rewriteToWEdit dflags uri r return $ WorkspaceEdit - { _changes = Just (fromList [(uri, List edits)]) + { _changes = Just (fromList [(uri, edits)]) , _documentChanges = Nothing , _changeAnnotations = Nothing } diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs index 305a08a535..f367b393a0 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/PositionIndexed.hs @@ -12,8 +12,8 @@ where import Data.Char import Data.List -import Language.LSP.Types (Position (Position), - Range (Range, _end, _start)) +import Language.LSP.Protocol.Types (Position (Position), + Range (Range, _end, _start)) type PositionIndexed a = [(Position, a)] diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs index 82bb01d9c8..cb71727c9a 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs @@ -7,7 +7,7 @@ import GHC.Parser.Annotation (TokenLocation (..)) #endif #if !MIN_VERSION_ghc(9,2,1) import qualified Data.Text as T -import Language.LSP.Types +import Language.LSP.Protocol.Types (TextEdit) #else import Control.Monad (join) import Control.Monad.Trans.Class (lift) @@ -34,11 +34,12 @@ import GHC.Hs (IsUnicodeSyntax (..) import GHC.Types.SrcLoc (generatedSrcSpan) import Ide.PluginUtils (makeDiffTextEdit, responseError) -import Language.Haskell.GHC.ExactPrint (TransformT(..), +import Language.Haskell.GHC.ExactPrint (TransformT (..), noAnnSrcSpanDP1, runTransformT) import Language.Haskell.GHC.ExactPrint.Transform (d1) -import Language.LSP.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types #endif #if !MIN_VERSION_ghc(9,2,1) @@ -117,7 +118,7 @@ addArgumentAction (ParsedModule _ moduleSrc _ _) range name _typ = do Just (matchedDeclName, numPats) -> modifySigWithM (unLoc matchedDeclName) (addTyHoleToTySigArg numPats) moduleSrc' Nothing -> pure moduleSrc' let diff = makeDiffTextEdit (T.pack $ exactPrint moduleSrc) (T.pack $ exactPrint newSource) - pure [("Add argument ‘" <> name <> "’ to function", fromLspList diff)] + pure [("Add argument ‘" <> name <> "’ to function", diff)] where addNameAsLastArgOfMatchingDecl = modifySmallestDeclWithM spanContainsRangeOrErr addNameAsLastArg addNameAsLastArg = fmap (first (:[])) . appendFinalPatToMatches name @@ -162,6 +163,4 @@ addTyHoleToTySigArg loc (L annHsSig (HsSig xHsSig tyVarBndrs lsigTy)) = lsigTy' = hsTypeFromFunTypeAsList (insertArg loc args, res) in L annHsSig (HsSig xHsSig tyVarBndrs lsigTy') -fromLspList :: List a -> [a] -fromLspList (List a) = a #endif diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs index 43b11202cf..35e04af6ba 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs @@ -6,7 +6,7 @@ import Control.Monad (guard) import Data.Char import qualified Data.Text as T import Development.IDE.Plugin.Plugins.Diagnostic -import Language.LSP.Types (Diagnostic (..), +import Language.LSP.Protocol.Types (Diagnostic (..), TextEdit (TextEdit)) import Text.Regex.TDFA (MatchResult (..), (=~)) diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs index 587ac1e133..17db1f0298 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillTypeWildcard.hs @@ -3,8 +3,9 @@ module Development.IDE.Plugin.Plugins.FillTypeWildcard ) where import Data.Char -import qualified Data.Text as T -import Language.LSP.Types (Diagnostic (..), TextEdit (TextEdit)) +import qualified Data.Text as T +import Language.LSP.Protocol.Types (Diagnostic (..), + TextEdit (TextEdit)) suggestFillTypeWildcard :: Diagnostic -> [(T.Text, TextEdit)] suggestFillTypeWildcard Diagnostic{_range=_range,..} diff --git a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/ImportUtils.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/ImportUtils.hs index 7afe7e5bb0..53fc61d918 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/ImportUtils.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/ImportUtils.hs @@ -14,7 +14,7 @@ import qualified Data.Text as T import Development.IDE.GHC.Compat import Development.IDE.Plugin.CodeAction.ExactPrint (wildCardSymbol) import Development.IDE.Types.Exports -import Language.LSP.Types (CodeActionKind (..)) +import Language.LSP.Protocol.Types (CodeActionKind (..)) -- | Possible import styles for an 'IdentInfo'. -- @@ -80,12 +80,12 @@ unImportStyle (ImportAllConstructors x) = (Just $ T.unpack x, wildCardSymbol) quickFixImportKind' :: T.Text -> ImportStyle -> CodeActionKind -quickFixImportKind' x (ImportTopLevel _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.topLevel" -quickFixImportKind' x (ImportViaParent _ _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.withParent" -quickFixImportKind' x (ImportAllConstructors _) = CodeActionUnknown $ "quickfix.import." <> x <> ".list.allConstructors" +quickFixImportKind' x (ImportTopLevel _) = CodeActionKind_Custom $ "quickfix.import." <> x <> ".list.topLevel" +quickFixImportKind' x (ImportViaParent _ _) = CodeActionKind_Custom $ "quickfix.import." <> x <> ".list.withParent" +quickFixImportKind' x (ImportAllConstructors _) = CodeActionKind_Custom $ "quickfix.import." <> x <> ".list.allConstructors" quickFixImportKind :: T.Text -> CodeActionKind -quickFixImportKind x = CodeActionUnknown $ "quickfix.import." <> x +quickFixImportKind x = CodeActionKind_Custom $ "quickfix.import." <> x -- | Possible import styles for qualified imports data QualifiedImportStyle = QualifiedImportPostfix | QualifiedImportPrefix diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 32720edf1e..d304c5c62f 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -33,14 +33,14 @@ import Development.IDE.Test import Development.IDE.Types.Location import Development.Shake (getDirectoryFilesIO) import Ide.Types -import Language.LSP.Test -import Language.LSP.Types hiding +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (length, line), SemanticTokenRelative (length), SemanticTokensEdit (_start), mkRange) -import Language.LSP.Types.Capabilities -import qualified Language.LSP.Types.Lens as L +import Language.LSP.Test import System.Directory import System.FilePath import System.Info.Extra (isMac, isWindows) @@ -87,9 +87,9 @@ tests = initializeTests = withResource acquire release tests where - tests :: IO (ResponseMessage Initialize) -> TestTree + tests :: IO (TResponseMessage Method_Initialize) -> TestTree tests getInitializeResponse = testGroup "initialize response capabilities" - [ chk " code action" _codeActionProvider (Just $ InL True) + [ chk " code action" _codeActionProvider (Just (InR (CodeActionOptions {_workDoneProgress = Nothing, _codeActionKinds = Nothing, _resolveProvider = Just False}))) , che " execute command" _executeCommandProvider [extendImportCommandId] ] where @@ -102,20 +102,20 @@ initializeTests = withResource acquire release tests where doTest = do ir <- getInitializeResponse - let Just ExecuteCommandOptions {_commands = List commands} = getActual $ innerCaps ir + let Just ExecuteCommandOptions {_commands = commands} = getActual $ innerCaps ir -- Check if expected exists in commands. Note that commands can arrive in different order. mapM_ (\e -> any (\o -> T.isSuffixOf e o) commands @? show (expected, show commands)) expected - acquire :: IO (ResponseMessage Initialize) + acquire :: IO (TResponseMessage Method_Initialize) acquire = run initializeResponse - release :: ResponseMessage Initialize -> IO () + release :: TResponseMessage Method_Initialize -> IO () release = const $ pure () - innerCaps :: ResponseMessage Initialize -> ServerCapabilities - innerCaps (ResponseMessage _ _ (Right (InitializeResult c _))) = c - innerCaps (ResponseMessage _ _ (Left _)) = error "Initialization error" + innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities + innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c + innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error" completionTests :: TestTree completionTests = @@ -277,7 +277,7 @@ completionCommandTest name src pos wanted expected = testSession name $ do modifiedCode <- skipManyTill anyMessage (getDocumentEdit docId) liftIO $ modifiedCode @?= T.unlines expected else do - expectMessages SWorkspaceApplyEdit 1 $ \edit -> + expectMessages SMethod_WorkspaceApplyEdit 1 $ \edit -> liftIO $ assertFailure $ "Expected no edit but got: " <> show edit completionNoCommandTest :: @@ -1882,7 +1882,7 @@ suggestImportDisambiguationTests = testGroup "suggest import disambiguation acti auxFiles = ["AVec.hs", "BVec.hs", "CVec.hs", "DVec.hs", "EVec.hs", "FVec.hs"] withTarget file locs k = runWithExtraFiles "hiding" $ \dir -> do doc <- openDoc file "haskell" - void $ expectDiagnostics [(file, [(DsError, loc, "Ambiguous occurrence") | loc <- locs])] + void $ expectDiagnostics [(file, [(DiagnosticSeverity_Error, loc, "Ambiguous occurrence") | loc <- locs])] actions <- getAllCodeActions doc k dir doc actions withHideFunction = withTarget ("HideFunction" <.> "hs") @@ -2336,7 +2336,7 @@ deleteUnusedDefinitionTests = testGroup "delete unused definition action" where testFor source pos expectedTitle expectedResult = do docId <- createDoc "A.hs" "haskell" source - expectDiagnostics [ ("A.hs", [(DsWarning, pos, "not used")]) ] + expectDiagnostics [ ("A.hs", [(DiagnosticSeverity_Warning, pos, "not used")]) ] (action, title) <- extractCodeAction docId "Delete" pos @@ -2360,9 +2360,9 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t , "f = 1" ]) #if MIN_VERSION_ghc(9,4,0) - [ (DsWarning, (3, 4), "Defaulting the type variable") ] + [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the type variable") ] #else - [ (DsWarning, (3, 4), "Defaulting the following constraint") ] + [ (DiagnosticSeverity_Warning, (3, 4), "Defaulting the following constraint") ] #endif "Add type annotation ‘Integer’ to ‘1’" (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" @@ -2381,9 +2381,9 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t , " in x" ]) #if MIN_VERSION_ghc(9,4,0) - [ (DsWarning, (4, 12), "Defaulting the type variable") ] + [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the type variable") ] #else - [ (DsWarning, (4, 12), "Defaulting the following constraint") ] + [ (DiagnosticSeverity_Warning, (4, 12), "Defaulting the following constraint") ] #endif "Add type annotation ‘Integer’ to ‘3’" (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" @@ -2403,9 +2403,9 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t , " in x" ]) #if MIN_VERSION_ghc(9,4,0) - [ (DsWarning, (4, 20), "Defaulting the type variable") ] + [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the type variable") ] #else - [ (DsWarning, (4, 20), "Defaulting the following constraint") ] + [ (DiagnosticSeverity_Warning, (4, 20), "Defaulting the following constraint") ] #endif "Add type annotation ‘Integer’ to ‘5’" (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" @@ -2426,12 +2426,12 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t , "f = seq \"debug\" traceShow \"debug\"" ]) #if MIN_VERSION_ghc(9,4,0) - [ (DsWarning, (6, 8), "Defaulting the type variable") - , (DsWarning, (6, 16), "Defaulting the type variable") + [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the type variable") + , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the type variable") ] #else - [ (DsWarning, (6, 8), "Defaulting the following constraint") - , (DsWarning, (6, 16), "Defaulting the following constraint") + [ (DiagnosticSeverity_Warning, (6, 8), "Defaulting the following constraint") + , (DiagnosticSeverity_Warning, (6, 16), "Defaulting the following constraint") ] #endif ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") @@ -2454,9 +2454,9 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t , "f a = traceShow \"debug\" a" ]) #if MIN_VERSION_ghc(9,4,0) - [ (DsWarning, (6, 6), "Defaulting the type variable") ] + [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the type variable") ] #else - [ (DsWarning, (6, 6), "Defaulting the following constraint") ] + [ (DiagnosticSeverity_Warning, (6, 6), "Defaulting the following constraint") ] #endif ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" @@ -2478,9 +2478,9 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))" ]) #if MIN_VERSION_ghc(9,4,0) - [ (DsWarning, (6, 54), "Defaulting the type variable") ] + [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the type variable") ] #else - [ (DsWarning, (6, 54), "Defaulting the following constraint") ] + [ (DiagnosticSeverity_Warning, (6, 54), "Defaulting the following constraint") ] #endif ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" diff --git a/plugins/hls-refactor-plugin/test/Test/AddArgument.hs b/plugins/hls-refactor-plugin/test/Test/AddArgument.hs index 7bd26224af..8f34798bf6 100644 --- a/plugins/hls-refactor-plugin/test/Test/AddArgument.hs +++ b/plugins/hls-refactor-plugin/test/Test/AddArgument.hs @@ -11,12 +11,12 @@ module Test.AddArgument (tests) where import Data.List.Extra import qualified Data.Text as T import Development.IDE.Types.Location -import Language.LSP.Test -import Language.LSP.Types hiding +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (length, line), SemanticTokenRelative (length), SemanticTokensEdit (_start), mkRange) +import Language.LSP.Test import Test.Tasty import Test.Tasty.HUnit diff --git a/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal b/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal index 01ff4cb84a..2145fe6a2a 100644 --- a/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal +++ b/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-refine-imports-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Refine imports plugin for Haskell Language Server description: Please see the README on GitHub at @@ -29,10 +29,10 @@ library , containers , deepseq , ghc - , ghcide == 2.0.0.0 - , hls-explicit-imports-plugin == 2.0.0.0 + , ghcide == 2.1.0.0 + , hls-explicit-imports-plugin == 2.1.0.0 , hls-graph - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , lsp , text , unordered-containers diff --git a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs index b448839898..42a401e2ad 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -16,7 +16,6 @@ import Control.DeepSeq (rwhnf) import Control.Monad (join) import Control.Monad.IO.Class (liftIO) import Data.Aeson.Types -import qualified Data.HashMap.Strict as HashMap import Data.IORef (readIORef) import Data.List (intercalate) import qualified Data.Map.Strict as Map @@ -48,20 +47,19 @@ import Ide.Plugin.ExplicitImports (extractMinimalImports, import Ide.PluginUtils (mkLspCommand) import Ide.Types import Language.LSP.Server -import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), - CodeAction (CodeAction, _command, _diagnostics, _disabled, _edit, _isPreferred, _kind, _title, _xdata), - CodeActionKind (CodeActionUnknown), +import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), + CodeAction (CodeAction, _command, _diagnostics, _disabled, _edit, _isPreferred, _kind, _title, _data_), + CodeActionKind (CodeActionKind_Custom), CodeActionParams (CodeActionParams), CodeLens (..), CodeLensParams (CodeLensParams, _textDocument), - Method (TextDocumentCodeAction, TextDocumentCodeLens), - SMethod (STextDocumentCodeAction, STextDocumentCodeLens, SWorkspaceApplyEdit), TextDocumentIdentifier (TextDocumentIdentifier, _uri), TextEdit (..), WorkspaceEdit (..), - type (|?) (InR), + type (|?) (InL, InR), uriToNormalizedFilePath) - +import Language.LSP.Protocol.Message (Method (Method_TextDocumentCodeAction, Method_TextDocumentCodeLens), + SMethod (SMethod_TextDocumentCodeAction, SMethod_TextDocumentCodeLens, SMethod_WorkspaceApplyEdit),) newtype Log = LogShake Shake.Log deriving Show instance Pretty Log where @@ -75,9 +73,9 @@ descriptor recorder plId = (defaultPluginDescriptor plId) , pluginRules = refineImportsRule recorder , pluginHandlers = mconcat [ -- This plugin provides code lenses - mkPluginHandler STextDocumentCodeLens lensProvider + mkPluginHandler SMethod_TextDocumentCodeLens lensProvider -- This plugin provides code actions - , mkPluginHandler STextDocumentCodeAction codeActionProvider + , mkPluginHandler SMethod_TextDocumentCodeAction codeActionProvider ] } @@ -101,10 +99,10 @@ refineImportCommand = runRefineImportCommand :: CommandFunction IdeState RefineImportCommandParams runRefineImportCommand _state (RefineImportCommandParams edit) = do -- This command simply triggers a workspace edit! - _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) return (Right Null) -lensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens +lensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens lensProvider state -- ghcide state pId @@ -125,13 +123,13 @@ lensProvider | (imp, Just refinedImports) <- result , Just edit <- [mkExplicitEdit posMapping imp refinedImports] ] - return $ Right (List $ catMaybes commands) - _ -> return $ Right (List []) + return $ Right (InL $ catMaybes commands) + _ -> return $ Right (InL []) | otherwise = - return $ Right (List []) + return $ Right (InL []) -- | Provide one code action to refine all imports -codeActionProvider :: PluginMethodHandler IdeState TextDocumentCodeAction +codeActionProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionProvider ideState _pId (CodeActionParams _ _ docId range _context) | TextDocumentIdentifier {_uri} <- docId, Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = liftIO $ @@ -144,7 +142,7 @@ codeActionProvider ideState _pId (CodeActionParams _ _ docId range _context) any (within range) rangesImports _ -> False if not insideImport - then return (Right (List [])) + then return (Right (InL [])) else do mbRefinedImports <- runIde ideState $ use RefineImports nfp let edits = @@ -155,20 +153,20 @@ codeActionProvider ideState _pId (CodeActionParams _ _ docId range _context) ] caExplicitImports = InR CodeAction {..} _title = "Refine all imports" - _kind = Just $ CodeActionUnknown "quickfix.import.refine" + _kind = Just $ CodeActionKind_Custom "quickfix.import.refine" _command = Nothing _edit = Just WorkspaceEdit {_changes, _documentChanges, _changeAnnotations} - _changes = Just $ HashMap.singleton _uri $ List edits + _changes = Just $ Map.singleton _uri edits _documentChanges = Nothing _diagnostics = Nothing _isPreferred = Nothing _disabled = Nothing - _xdata = Nothing + _data_ = Nothing _changeAnnotations = Nothing - return $ Right $ List [caExplicitImports | not (null edits)] + return $ Right $ InL [caExplicitImports | not (null edits)] | otherwise = - return $ Right $ List [] + return $ Right $ InL [] -------------------------------------------------------------------------------- @@ -299,10 +297,10 @@ generateLens pId uri edits@TextEdit {_range, _newText} = do -- The title of the command is just the minimal explicit import decl let title = "Refine imports to " <> T.intercalate ", " (T.lines _newText) -- the code lens has no extra data - _xdata = Nothing + _data_ = Nothing -- an edit that replaces the whole declaration with the explicit one edit = WorkspaceEdit (Just editsMap) Nothing Nothing - editsMap = HashMap.fromList [(uri, List [edits])] + editsMap = Map.fromList [(uri, [edits])] -- the command argument is simply the edit _arguments = Just [toJSON $ RefineImportCommandParams edit] -- create the command diff --git a/plugins/hls-refine-imports-plugin/test/Main.hs b/plugins/hls-refine-imports-plugin/test/Main.hs index 20df99f96a..284aedffa2 100644 --- a/plugins/hls-refine-imports-plugin/test/Main.hs +++ b/plugins/hls-refine-imports-plugin/test/Main.hs @@ -60,7 +60,7 @@ isRefineImports _ = False executeCmd :: Command -> Session () executeCmd cmd = do executeCommand cmd - _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) + _resp <- skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) -- liftIO $ print _resp return () diff --git a/plugins/hls-rename-plugin/hls-rename-plugin.cabal b/plugins/hls-rename-plugin/hls-rename-plugin.cabal index 160eda6e92..680d317a95 100644 --- a/plugins/hls-rename-plugin/hls-rename-plugin.cabal +++ b/plugins/hls-rename-plugin/hls-rename-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-rename-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Rename plugin for Haskell Language Server description: Please see the README on GitHub at @@ -29,11 +29,11 @@ library , extra , ghc , ghc-exactprint - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , hashable , hiedb , hie-compat - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , hls-refactor-plugin , lens , lsp @@ -59,4 +59,4 @@ test-suite tests , filepath , hls-plugin-api , hls-rename-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index 8506bb4b2c..20b3f47ec4 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -54,21 +54,22 @@ import HieDb.Query import Ide.Plugin.Properties import Ide.PluginUtils import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import Language.LSP.Server -import Language.LSP.Types -import qualified Language.LSP.Types.Lens as LSP instance Hashable (Mod a) where hash n = hash (unMod n) descriptor :: Recorder (WithPriority E.Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder pluginId = mkExactprintPluginDescriptor recorder $ (defaultPluginDescriptor pluginId) - { pluginHandlers = mkPluginHandler STextDocumentRename renameProvider + { pluginHandlers = mkPluginHandler SMethod_TextDocumentRename renameProvider , pluginConfigDescriptor = defaultConfigDescriptor { configCustomConfig = mkCustomConfig properties } } -renameProvider :: PluginMethodHandler IdeState TextDocumentRename -renameProvider state pluginId (RenameParams docId@(TextDocumentIdentifier uri) pos _prog newNameText) = +renameProvider :: PluginMethodHandler IdeState Method_TextDocumentRename +renameProvider state pluginId (RenameParams _prog docId@(TextDocumentIdentifier uri) pos newNameText) = pluginResponse $ do nfp <- handleUriToNfp uri directOldNames <- getNamesAtPos state nfp pos @@ -98,7 +99,7 @@ renameProvider state pluginId (RenameParams docId@(TextDocumentIdentifier uri) p verTxtDocId <- lift $ getVersionedTextDoc (TextDocumentIdentifier uri) getSrcEdit state verTxtDocId (replaceRefs newName locations) fileEdits <- mapM getFileEdit filesRefs - pure $ foldl' (<>) mempty fileEdits + pure $ InL $ foldl' (<>) mempty fileEdits -- | Limit renaming across modules. failWhenImportOrExport :: @@ -134,7 +135,7 @@ getSrcEdit :: ExceptT String m WorkspaceEdit getSrcEdit state verTxtDocId updatePs = do ccs <- lift getClientCapabilities - nfp <- handleUriToNfp (verTxtDocId ^. LSP.uri) + nfp <- handleUriToNfp (verTxtDocId ^. L.uri) annAst <- handleMaybeM ("No parsed source for: " ++ show nfp) $ liftIO $ runAction "Rename.GetAnnotatedParsedSource" state diff --git a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal index 1eff5b6afa..94c965047c 100644 --- a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal +++ b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hls-retrie-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Retrie integration plugin for Haskell Language Server description: Please see the README on GitHub at @@ -28,10 +28,11 @@ library , directory , extra , ghc - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , hashable - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , hls-refactor-plugin + , lens , lsp , lsp-types , retrie >=0.1.1.0 @@ -63,5 +64,5 @@ test-suite tests , hls-plugin-api , hls-refactor-plugin , hls-retrie-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , text diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index e5127c9567..990e261762 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -24,6 +24,7 @@ import Control.Concurrent.STM (readTVarIO) import Control.Exception.Safe (Exception (..), SomeException, assert, catch, throwIO, try) +import Control.Lens.Operators import Control.Monad (forM, unless, when) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (MonadTrans (lift)) @@ -46,6 +47,7 @@ import qualified Data.HashSet as Set import Data.IORef.Extra (atomicModifyIORef'_, newIORef, readIORef) import Data.List.Extra (find, nubOrdOn) +import qualified Data.Map as Map import Data.Maybe (catMaybes, fromJust, listToMaybe) import Data.String (IsString) @@ -114,15 +116,14 @@ import GHC.Generics (Generic) import GHC.Hs.Dump import Ide.PluginUtils import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message as LSP +import Language.LSP.Protocol.Types as LSP hiding (Null) import Language.LSP.Server (LspM, ProgressCancellable (Cancellable), sendNotification, sendRequest, withIndefiniteProgress) -import Language.LSP.Types as J hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) import Retrie (Annotated (astA), AnnotatedModule, Fixity (Fixity), @@ -178,7 +179,7 @@ import Development.IDE.Types.Shake (WithHieDb) descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeAction provider, + { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction provider, pluginCommands = [retrieCommand, retrieInlineThisCommand] } @@ -228,12 +229,12 @@ runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = nfp restrictToOriginatingFile unless (null errors) $ - lift $ sendNotification SWindowShowMessage $ - ShowMessageParams MtWarning $ + lift $ sendNotification SMethod_WindowShowMessage $ + ShowMessageParams MessageType_Warning $ T.unlines $ "## Found errors during rewrite:" : ["-" <> T.pack (show e) | e <- errors] - lift $ sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (\_ -> pure ()) + lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (\_ -> pure ()) return () return $ Right Null @@ -284,7 +285,7 @@ runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = pluginResponse $ do ourReplacement = [ r | r@Replacement{..} <- replacements , RealSrcSpan intoRange Nothing `GHC.isSubspanOf` replLocation] - lift $ sendRequest SWorkspaceApplyEdit + lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) return Null @@ -337,9 +338,9 @@ extractImports _ _ _ = [] ------------------------------------------------------------------------------- -provider :: PluginMethodHandler IdeState TextDocumentCodeAction +provider :: PluginMethodHandler IdeState Method_TextDocumentCodeAction provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) = pluginResponse $ do - let (J.CodeActionContext _diags _monly) = ca + let (LSP.CodeActionContext _diags _monly _) = ca nuri = toNormalizedUri uri nfp <- handleMaybe "uri" $ uriToNormalizedFilePath nuri @@ -350,7 +351,7 @@ provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) extras@ShakeExtras{ withHieDb, hiedbWriter } <- liftIO $ runAction "" state getShakeExtras range <- handleMaybe "range" $ fromCurrentRange posMapping range - let pos = _start range + let pos = range ^. L.start let rewrites = concatMap (suggestBindRewrites uri pos ms_mod) topLevelBinds ++ concatMap (suggestRuleRewrites uri pos ms_mod) hs_ruleds @@ -370,10 +371,10 @@ provider state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range ca) suggestBindInlines plId uri topLevelBinds range withHieDb (lookupMod hiedbWriter) let inlineCommands = [ Just $ - CodeAction _title (Just CodeActionRefactorInline) Nothing Nothing Nothing Nothing (Just c) Nothing + CodeAction _title (Just CodeActionKind_RefactorInline) Nothing Nothing Nothing Nothing (Just c) Nothing | c@Command{..} <- inlineSuggestions ] - return $ J.List [InR c | c <- retrieCommands ++ catMaybes inlineCommands] + return $ InL [InR c | c <- retrieCommands ++ catMaybes inlineCommands] getLocationUri :: Location -> Uri getLocationUri Location{_uri} = _uri @@ -419,11 +420,11 @@ suggestBindRewrites originatingFile pos ms_mod FunBind {fun_id = L (locA -> l') unfoldRewrite restrictToOriginatingFile = let rewrites = [Unfold (qualify ms_mod pprName)] description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile - in (description, CodeActionRefactorInline, RunRetrieParams {..}) + in (description, CodeActionKind_RefactorInline, RunRetrieParams {..}) foldRewrite restrictToOriginatingFile = let rewrites = [Fold (qualify ms_mod pprName)] description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile - in (description, CodeActionRefactorExtract, RunRetrieParams {..}) + in (description, CodeActionKind_RefactorExtract, RunRetrieParams {..}) in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True] suggestBindRewrites _ _ _ _ = [] @@ -480,11 +481,11 @@ suggestTypeRewrites originatingFile ms_mod SynDecl {tcdLName} = unfoldRewrite restrictToOriginatingFile = let rewrites = [TypeForward (qualify ms_mod pprName)] description = "Unfold " <> pprNameText <> describeRestriction restrictToOriginatingFile - in (description, CodeActionRefactorInline, RunRetrieParams {..}) + in (description, CodeActionKind_RefactorInline, RunRetrieParams {..}) foldRewrite restrictToOriginatingFile = let rewrites = [TypeBackward (qualify ms_mod pprName)] description = "Fold " <> pprNameText <> describeRestriction restrictToOriginatingFile - in (description, CodeActionRefactorExtract, RunRetrieParams {..}) + in (description, CodeActionKind_RefactorExtract, RunRetrieParams {..}) in [unfoldRewrite False, unfoldRewrite True, foldRewrite False, foldRewrite True] suggestTypeRewrites _ _ _ = [] @@ -517,7 +518,7 @@ suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) = describeRestriction restrictToOriginatingFile in ( description, - CodeActionRefactor, + CodeActionKind_Refactor, RunRetrieParams {..} ) backwardsRewrite ruleName restrictToOriginatingFile = @@ -525,7 +526,7 @@ suggestRuleRewrites originatingFile pos ms_mod (L _ HsRules {rds_rules}) = description = "Apply rule " <> T.pack ruleName <> " backwards" <> describeRestriction restrictToOriginatingFile in ( description, - CodeActionRefactor, + CodeActionKind_Refactor, RunRetrieParams {..} ) @@ -703,8 +704,8 @@ constructInlineFromIdentifer originParsedModule originSpan = do constructfromFunMatches imports fun_id fun_matches _ -> return $ error "cound not find source code to inline" -asEditMap :: [(Uri, TextEdit)] -> WorkspaceEditMap -asEditMap = coerce . HM.fromListWith (++) . map (second pure) +asEditMap :: [(Uri, TextEdit)] -> Map.Map Uri [TextEdit] +asEditMap = Map.fromListWith (++) . map (second pure) asTextEdits :: Change -> [(Uri, TextEdit)] asTextEdits NoChange = [] diff --git a/plugins/hls-splice-plugin/hls-splice-plugin.cabal b/plugins/hls-splice-plugin/hls-splice-plugin.cabal index d5448fd000..e4bf4a1573 100644 --- a/plugins/hls-splice-plugin/hls-splice-plugin.cabal +++ b/plugins/hls-splice-plugin/hls-splice-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-splice-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: HLS Plugin to expand TemplateHaskell Splices and QuasiQuotes @@ -42,8 +42,8 @@ library , foldl , ghc , ghc-exactprint - , ghcide == 2.0.0.0 - , hls-plugin-api == 2.0.0.0 + , ghcide == 2.1.0.0 + , hls-plugin-api == 2.1.0.0 , hls-refactor-plugin , lens , lsp @@ -69,5 +69,6 @@ test-suite tests , base , filepath , hls-splice-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , text + , row-types diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 651e31308c..0cf5da4541 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -64,15 +64,15 @@ import Ide.Plugin.Splice.Types import Ide.Types import Language.Haskell.GHC.ExactPrint (uniqueSrcSpanT) import Language.LSP.Server -import Language.LSP.Types -import Language.LSP.Types.Capabilities -import qualified Language.LSP.Types.Lens as J +import Language.LSP.Protocol.Types hiding (Null) +import Language.LSP.Protocol.Message +import qualified Language.LSP.Protocol.Lens as J descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginCommands = commands - , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction + , pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction codeAction } commands :: [PluginCommand IdeState] @@ -97,7 +97,7 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do clientCapabilities <- getClientCapabilities rio <- askRunInIO let reportEditor :: ReportEditor - reportEditor msgTy msgs = liftIO $ rio $ sendNotification SWindowShowMessage (ShowMessageParams msgTy (T.unlines msgs)) + reportEditor msgTy msgs = liftIO $ rio $ sendNotification SMethod_WindowShowMessage (ShowMessageParams msgTy (T.unlines msgs)) expandManually fp = do mresl <- liftIO $ runAction "expandTHSplice.fallback.TypeCheck (stale)" ideState $ useWithStale TypeCheck fp @@ -107,7 +107,7 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do ) pure mresl reportEditor - MtWarning + MessageType_Warning [ "Expansion in type-checking phase failed;" , "trying to expand manually, but note that it is less rigorous." ] @@ -186,7 +186,7 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do case eedits of Left err -> do reportEditor - MtError + MessageType_Error ["Error during expanding splice: " <> T.pack err] pure (Left $ responseError $ T.pack err) Right edits -> @@ -195,7 +195,7 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do Nothing -> pure $ Right Null Just (Left err) -> pure $ Left err Just (Right edit) -> do - _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) + _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) pure $ Right Null where @@ -415,7 +415,7 @@ manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _e unless (null warns) $ reportEditor - MtWarning + MessageType_Warning [ "Warning during expanding: " , "" , T.pack (showErrors warns) @@ -483,10 +483,10 @@ fromSearchResult _ = Nothing -- TODO: workaround when HieAst unavailable (e.g. when the module itself errors) -- TODO: Declaration Splices won't appear in HieAst; perhaps we must just use Parsed/Renamed ASTs? -codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction +codeAction :: PluginMethodHandler IdeState Method_TextDocumentCodeAction codeAction state plId (CodeActionParams _ _ docId ran _) = do verTxtDocId <- getVersionedTextDoc docId - liftIO $ fmap (maybe (Right $ List []) Right) $ + liftIO $ fmap (maybe (Right $ InL []) Right) $ runMaybeT $ do fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri ParsedModule {..} <- @@ -501,9 +501,9 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = do act = mkLspCommand plId cmdId title (Just [toJSON params]) pure $ InR $ - CodeAction title (Just CodeActionRefactorRewrite) Nothing Nothing Nothing Nothing (Just act) Nothing + CodeAction title (Just CodeActionKind_RefactorRewrite) Nothing Nothing Nothing Nothing (Just act) Nothing - pure $ maybe mempty List mcmds + pure $ InL $ fromMaybe mempty mcmds where theUri = docId ^. J.uri detectSplice :: diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs index f74816519a..cc17bf9c86 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice/Types.hs @@ -5,14 +5,14 @@ module Ide.Plugin.Splice.Types where -import Data.Aeson (FromJSON, ToJSON) -import qualified Data.Text as T +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Text as T -- This import is needed for the ToJSON/FromJSON instances of RealSrcSpan -import Development.IDE () -import Development.IDE.GHC.Compat (RealSrcSpan) -import GHC.Generics (Generic) -import Ide.Types (CommandId) -import Language.LSP.Types (VersionedTextDocumentIdentifier) +import Development.IDE () +import Development.IDE.GHC.Compat (RealSrcSpan) +import GHC.Generics (Generic) +import Ide.Types (CommandId) +import Language.LSP.Protocol.Types (VersionedTextDocumentIdentifier) -- | Parameter for the addMethods PluginCommand. data ExpandSpliceParams = ExpandSpliceParams diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index d72fc8e45f..8a2800305e 100644 --- a/plugins/hls-splice-plugin/test/Main.hs +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -1,15 +1,16 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} - module Main ( main ) where import Control.Monad (void) import Data.List (find) +import Data.Row import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -76,7 +77,7 @@ goldenTest fp tc line col = case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of Just (InR CodeAction {_command = Just c}) -> do executeCommand c - void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) _ -> liftIO $ assertFailure "No CodeAction detected" goldenTestWithEdit :: FilePath -> FilePath -> ExpandStyle -> Int -> Int -> TestTree @@ -94,7 +95,9 @@ goldenTestWithEdit fp expect tc line col = waitForAllProgressDone alt <- liftIO $ T.readFile (fp <.> "error.hs") void $ applyEdit doc $ TextEdit theRange alt - changeDoc doc [TextDocumentContentChangeEvent (Just theRange) Nothing alt] + changeDoc doc [TextDocumentContentChangeEvent $ InL $ #range .== theRange + .+ #rangeLength .== Nothing + .+ #text .== alt] void waitForDiagnostics -- wait for the entire build to finish void waitForBuildQueue @@ -102,7 +105,7 @@ goldenTestWithEdit fp expect tc line col = case find ((== Just (toExpandCmdTitle tc)) . codeActionTitle) actions of Just (InR CodeAction {_command = Just c}) -> do executeCommand c - void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) _ -> liftIO $ assertFailure "No CodeAction detected" testDataDir :: FilePath diff --git a/plugins/hls-stan-plugin/hls-stan-plugin.cabal b/plugins/hls-stan-plugin/hls-stan-plugin.cabal index e03689497c..1c88ae4a5c 100644 --- a/plugins/hls-stan-plugin/hls-stan-plugin.cabal +++ b/plugins/hls-stan-plugin/hls-stan-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-stan-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Stan integration plugin with Haskell Language Server description: Please see the README on GitHub at @@ -74,7 +74,7 @@ test-suite test , filepath , hls-stan-plugin , hls-plugin-api - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , lens , lsp-types , text diff --git a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs index 2388bf2613..732d94066e 100644 --- a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs +++ b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs @@ -13,6 +13,7 @@ import qualified Data.Map as Map import Data.Maybe (fromJust, mapMaybe) import qualified Data.Text as T import Development.IDE +import Development.IDE (Diagnostic (_codeDescription)) import Development.IDE.Core.Rules (getHieFile, getSourceFileSource) import Development.IDE.Core.RuleTypes (HieAstResult (..)) @@ -33,7 +34,7 @@ import Ide.Types (PluginDescriptor (..), defaultConfigDescriptor, defaultPluginDescriptor, pluginEnabledConfig) -import qualified Language.LSP.Types as LSP +import qualified Language.LSP.Protocol.Types as LSP import Stan.Analysis (Analysis (..), runAnalysis) import Stan.Category (Category (..)) import Stan.Core.Id (Id (..)) @@ -110,11 +111,13 @@ rules recorder plId = do ShowDiag, LSP.Diagnostic { _range = realSrcSpanToRange observationSrcSpan, - _severity = Just LSP.DsHint, + _severity = Just LSP.DiagnosticSeverity_Hint, _code = Just (LSP.InR $ unId (inspectionId inspection)), _source = Just "stan", _message = message, _relatedInformation = Nothing, - _tags = Nothing + _tags = Nothing, + _codeDescription = Nothing, + _data_ = Nothing } ) diff --git a/plugins/hls-stan-plugin/test/Main.hs b/plugins/hls-stan-plugin/test/Main.hs index 48e9128329..5c407a1296 100644 --- a/plugins/hls-stan-plugin/test/Main.hs +++ b/plugins/hls-stan-plugin/test/Main.hs @@ -10,7 +10,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Ide.Plugin.Stan as Stan -import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Protocol.Lens as L import System.FilePath import Test.Hls @@ -28,7 +28,7 @@ tests = liftIO $ do length diags @?= 1 reduceDiag ^. L.range @?= Range (Position 0 0) (Position 3 19) - reduceDiag ^. L.severity @?= Just DsHint + reduceDiag ^. L.severity @?= Just DiagnosticSeverity_Hint let expectedPrefix = " ✲ Name: " assertBool "" $ T.isPrefixOf expectedPrefix (reduceDiag ^. L.message) reduceDiag ^. L.source @?= Just "stan" diff --git a/plugins/hls-stylish-haskell-plugin/hls-stylish-haskell-plugin.cabal b/plugins/hls-stylish-haskell-plugin/hls-stylish-haskell-plugin.cabal index 74e1f5feb8..af0ebeb768 100644 --- a/plugins/hls-stylish-haskell-plugin/hls-stylish-haskell-plugin.cabal +++ b/plugins/hls-stylish-haskell-plugin/hls-stylish-haskell-plugin.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-stylish-haskell-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Integration with the Stylish Haskell code formatter description: Please see the README on GitHub at @@ -30,8 +30,8 @@ library , filepath , ghc , ghc-boot-th - , ghcide == 2.0.0.0 - , hls-plugin-api == 2.0.0.0 + , ghcide == 2.1.0.0 + , hls-plugin-api == 2.1.0.0 , lsp-types , stylish-haskell ^>=0.12 || ^>=0.13 || ^>=0.14.2 , text @@ -50,4 +50,4 @@ test-suite tests , base , filepath , hls-stylish-haskell-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 diff --git a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs index 7c98427181..c68e623401 100644 --- a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs +++ b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs @@ -16,7 +16,7 @@ import GHC.LanguageExtensions.Type import Ide.PluginUtils import Ide.Types hiding (Config) import Language.Haskell.Stylish -import Language.LSP.Types as J +import Language.LSP.Protocol.Types as LSP import System.Directory import System.FilePath @@ -40,7 +40,7 @@ provider ide typ contents fp _opts = do result = runStylishHaskell file mergedConfig selectedContents case result of Left err -> return $ Left $ responseError $ T.pack $ "stylishHaskellCmd: " ++ err - Right new -> return $ Right $ J.List [TextEdit range new] + Right new -> return $ Right $ LSP.InL [TextEdit range new] where getMergedConfig dyn config | null (configLanguageExtensions config) diff --git a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal index e3e1a52919..536defbe6e 100644 --- a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal +++ b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 category: Development name: hls-tactics-plugin -version: 2.0.0.0 +version: 2.1.0.0 synopsis: Wingman plugin for Haskell Language Server description: Please see the README on GitHub at @@ -99,9 +99,9 @@ library , ghc-boot-th , ghc-exactprint , ghc-source-gen ^>=0.4.1 - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , hls-graph - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , hls-refactor-plugin , hyphenation , lens @@ -185,7 +185,7 @@ test-suite tests , ghcide , hls-plugin-api , hls-tactics-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , hspec , hspec-expectations , lens diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs index b55ee31ae3..bbde652ae9 100644 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs @@ -18,7 +18,7 @@ import Wingman.StaticPlugin import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) data Log - = LogWingmanLanguageServer WingmanLanguageServer.Log + = LogWingmanLanguageServer WingmanLanguageServer.Log | LogExactPrint E.Log deriving Show diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs index 65e8b2e508..c9c8e50fe3 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs @@ -24,9 +24,10 @@ import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource(GetAnn import qualified Ide.Plugin.Config as Plugin import Ide.Types import Language.LSP.Server (LspM, sendRequest, getClientCapabilities, getVersionedTextDoc) -import qualified Language.LSP.Types as LSP -import qualified Language.LSP.Types.Lens as J -import Language.LSP.Types hiding (CodeLens, CodeAction) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import qualified Language.LSP.Protocol.Types as LSP +import Language.LSP.Protocol.Types hiding (CodeLens, CodeAction) import Wingman.AbstractLSP.Types import Wingman.EmptyCase (fromMaybeT) import Wingman.LanguageServer (runIde, getTacticConfigAction, getIdeDynflags, mkWorkspaceEdits, runStaleIde, showLspMessage, mkShowMessageParams) @@ -61,9 +62,9 @@ buildHandlers cs = flip foldMap cs $ \(Interaction (c :: Continuation sort target b)) -> case c_makeCommand c of SynthesizeCodeAction k -> - mkPluginHandler STextDocumentCodeAction $ codeActionProvider @target (c_sort c) k + mkPluginHandler SMethod_TextDocumentCodeAction $ codeActionProvider @target (c_sort c) k SynthesizeCodeLens k -> - mkPluginHandler STextDocumentCodeLens $ codeLensProvider @target (c_sort c) k + mkPluginHandler SMethod_TextDocumentCodeLens $ codeLensProvider @target (c_sort c) k ------------------------------------------------------------------------------ @@ -91,12 +92,12 @@ runContinuation runContinuation plId cont state (fc, b) = do fromMaybeT (Left $ ResponseError - { _code = InternalError + { _code = InR $ ErrorCodes_InternalError , _message = T.pack "TODO(sandy)" , _xdata = Nothing } ) $ do env@LspEnv{..} <- buildEnv state plId fc - nfp <- getNfp $ fc_verTxtDocId le_fileContext ^. J.uri + nfp <- getNfp $ fc_verTxtDocId le_fileContext ^. L.uri let stale a = runStaleIde "runContinuation" state nfp a args <- fetchTargetArgs @a env res <- c_runCommand cont env args fc b @@ -116,7 +117,7 @@ runContinuation plId cont state (fc, b) = do case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_verTxtDocId le_fileContext) (unTrack pm) gr of Left errs -> pure $ Just $ ResponseError - { _code = InternalError + { _code = InR ErrorCodes_InternalError , _message = T.pack $ show errs , _xdata = Nothing } @@ -131,7 +132,7 @@ sendEdits :: WorkspaceEdit -> MaybeT (LspM Plugin.Config) () sendEdits edits = void $ lift $ sendRequest - SWorkspaceApplyEdit + SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (const $ pure ()) @@ -155,7 +156,7 @@ buildEnv -> MaybeT (LspM Plugin.Config) LspEnv buildEnv state plId fc = do cfg <- liftIO $ runIde "plugin" "config" state $ getTacticConfigAction plId - nfp <- getNfp $ fc_verTxtDocId fc ^. J.uri + nfp <- getNfp $ fc_verTxtDocId fc ^. L.uri dflags <- mapMaybeT liftIO $ getIdeDynflags state nfp pure $ LspEnv { le_ideState = state @@ -176,11 +177,11 @@ codeActionProvider -> TargetArgs target -> MaybeT (LspM Plugin.Config) [(Metadata, b)] ) - -> PluginMethodHandler IdeState TextDocumentCodeAction + -> PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionProvider sort k state plId (CodeActionParams _ _ docId range _) = do verTxtDocId <- getVersionedTextDoc docId - fromMaybeT (Right $ List []) $ do + fromMaybeT (Right $ InL []) $ do let fc = FileContext { fc_verTxtDocId = verTxtDocId , fc_range = Just $ unsafeMkCurrent range @@ -190,7 +191,7 @@ codeActionProvider sort k state plId actions <- k env args pure $ Right - $ List + $ InL $ fmap (InR . uncurry (makeCodeAction plId fc sort)) actions @@ -204,11 +205,11 @@ codeLensProvider -> TargetArgs target -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)] ) - -> PluginMethodHandler IdeState TextDocumentCodeLens + -> PluginMethodHandler IdeState Method_TextDocumentCodeLens codeLensProvider sort k state plId (CodeLensParams _ _ docId) = do verTxtDocId <- getVersionedTextDoc docId - fromMaybeT (Right $ List []) $ do + fromMaybeT (Right $ InL []) $ do let fc = FileContext { fc_verTxtDocId = verTxtDocId , fc_range = Nothing @@ -218,7 +219,7 @@ codeLensProvider sort k state plId actions <- k env args pure $ Right - $ List + $ InL $ fmap (uncurry3 $ makeCodeLens plId sort fc) actions @@ -243,7 +244,7 @@ makeCodeAction plId fc sort (Metadata title kind preferred) b = , _disabled = Nothing , _edit = Nothing , _command = Just cmd - , _xdata = Nothing + , _data_ = Nothing } @@ -265,6 +266,6 @@ makeCodeLens plId sort fc range (Metadata title _ _) b = in LSP.CodeLens { _range = range , _command = Just cmd - , _xdata = Nothing + , _data_ = Nothing } diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/TacticActions.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/TacticActions.hs index fde29db9f7..7c74eac8dc 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/TacticActions.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/TacticActions.hs @@ -17,7 +17,7 @@ import Development.IDE.Core.UseStale import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint import Generics.SYB.GHC (mkBindListT, everywhereM') -import qualified Language.LSP.Types.Lens as LSP +import qualified Language.LSP.Protocol.Lens as L import Wingman.AbstractLSP.Types import Wingman.CaseSplit import Wingman.GHC (liftMaybe, isHole, pattern AMatch) @@ -47,7 +47,7 @@ makeTacticInteraction cmd = } ) $ \LspEnv{..} HoleJudgment{..} FileContext{..} var_name -> do - nfp <- getNfp (fc_verTxtDocId ^. LSP.uri) + nfp <- getNfp (fc_verTxtDocId ^. L.uri) let stale a = runStaleIde "tacticCmd" le_ideState nfp a let span = fmap (rangeToRealSrcSpan (fromNormalizedFilePath nfp)) hj_range diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/Types.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/Types.hs index eea5c70b15..0b4e4cde11 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/Types.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/Types.hs @@ -20,8 +20,8 @@ import GHC.Generics (Generic) import qualified Ide.Plugin.Config as Plugin import Ide.Types hiding (Config) import Language.LSP.Server (LspM) -import Language.LSP.Types hiding (CodeLens, CodeAction) -import qualified Language.LSP.Types.Lens as LSP +import Language.LSP.Protocol.Types hiding (CodeLens, CodeAction) +import qualified Language.LSP.Protocol.Lens as L import Wingman.LanguageServer (judgementForHole) import Wingman.Types @@ -166,6 +166,6 @@ instance IsTarget HoleTarget where fetchTargetArgs LspEnv{..} = do let FileContext{..} = le_fileContext range <- MaybeT $ pure fc_range - nfp <- getNfp (fc_verTxtDocId ^. LSP.uri) + nfp <- getNfp (fc_verTxtDocId ^. L.uri) mapMaybeT liftIO $ judgementForHole le_ideState nfp range le_config diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/EmptyCase.hs b/plugins/hls-tactics-plugin/old/src/Wingman/EmptyCase.hs index 48a490f9d5..6c49e8d702 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/EmptyCase.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/EmptyCase.hs @@ -27,8 +27,8 @@ import Development.IDE.GHC.ExactPrint import Development.IDE.Spans.LocalBindings (getLocalScope) import Ide.Types import Language.LSP.Server -import Language.LSP.Types -import qualified Language.LSP.Types.Lens as LSP +import Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types import Prelude hiding (span) import Wingman.AbstractLSP.Types import Wingman.CodeGen (destructionFor) @@ -52,7 +52,7 @@ emptyCaseInteraction = Interaction $ Continuation @EmptyCaseT @EmptyCaseT @WorkspaceEdit EmptyCaseT (SynthesizeCodeLens $ \LspEnv{..} _ -> do let FileContext{..} = le_fileContext - nfp <- getNfp (fc_verTxtDocId ^. LSP.uri) + nfp <- getNfp (fc_verTxtDocId ^. L.uri) let stale a = runStaleIde "codeLensProvider" le_ideState nfp a @@ -78,7 +78,7 @@ emptyCaseInteraction = Interaction $ ( range , Metadata (mkEmptyCaseLensDesc ty) - (CodeActionUnknown "refactor.wingman.completeEmptyCase") + (CodeActionKind_Custom "refactor.wingman.completeEmptyCase") False , edits ) diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs index 3c3ba22ce3..478bf8ecf6 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs @@ -47,11 +47,9 @@ import Ide.Plugin.Properties import Ide.Types (PluginId) import Language.Haskell.GHC.ExactPrint (Transform, modifyAnnsT, addAnnotationsForPretty) import Language.LSP.Server (MonadLsp, sendNotification) -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import Language.LSP.Types.Capabilities +import Language.LSP.Protocol.Types hiding + (SemanticTokensEdit (_start)) +import Language.LSP.Protocol.Message import Prelude hiding (span) import Retrie (transformA) import Wingman.Context @@ -172,10 +170,10 @@ properties = emptyProperties "Maximum number of `Use constructor ` code actions that can appear" 5 & defineEnumProperty #hole_severity "The severity to use when showing hole diagnostics. These are noisy, but some editors don't allow jumping to all severities." - [ (Just DsError, "error") - , (Just DsWarning, "warning") - , (Just DsInfo, "info") - , (Just DsHint, "hint") + [ (Just DiagnosticSeverity_Error, "error") + , (Just DiagnosticSeverity_Warning, "warning") + , (Just DiagnosticSeverity_Information, "info") + , (Just DiagnosticSeverity_Hint, "hint") , (Nothing, "none") ] Nothing @@ -521,11 +519,11 @@ isRhsHoleWithoutWhere (unTrack -> rss) (unTrack -> tcs) = ufmSeverity :: UserFacingMessage -> MessageType -ufmSeverity NotEnoughGas = MtInfo -ufmSeverity TacticErrors = MtError -ufmSeverity TimedOut = MtInfo -ufmSeverity NothingToDo = MtInfo -ufmSeverity (InfrastructureError _) = MtError +ufmSeverity NotEnoughGas = MessageType_Info +ufmSeverity TacticErrors = MessageType_Error +ufmSeverity TimedOut = MessageType_Info +ufmSeverity NothingToDo = MessageType_Info +ufmSeverity (InfrastructureError _) = MessageType_Error mkShowMessageParams :: UserFacingMessage -> ShowMessageParams @@ -533,7 +531,7 @@ mkShowMessageParams ufm = ShowMessageParams (ufmSeverity ufm) $ T.pack $ show uf showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m () -showLspMessage = sendNotification SWindowShowMessage +showLspMessage = sendNotification SMethod_WindowShowMessage -- This rule only exists for generating file diagnostics @@ -610,9 +608,11 @@ mkDiagnostic severity r = Diagnostic r (Just severity) (Just $ InR "hole") + Nothing (Just "wingman") "Hole" - (Just $ List [DtUnnecessary]) + (Just [DiagnosticTag_Unnecessary]) + Nothing Nothing diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/Metaprogram.hs b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/Metaprogram.hs index 272f60e1a2..6f6ca119f0 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/Metaprogram.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/Metaprogram.hs @@ -20,7 +20,8 @@ import Development.IDE.Core.Shake (IdeState (..)) import Development.IDE.Core.UseStale import Development.IDE.GHC.Compat hiding (empty) import Ide.Types -import Language.LSP.Types +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Message import Prelude hiding (span) import Wingman.LanguageServer import Wingman.Metaprogramming.Parser (attempt_it) @@ -29,14 +30,14 @@ import Wingman.Types ------------------------------------------------------------------------------ -- | Provide the "empty case completion" code lens -hoverProvider :: PluginMethodHandler IdeState TextDocumentHover +hoverProvider :: PluginMethodHandler IdeState Method_TextDocumentHover hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurrent -> pos) _) | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do let loc = fmap (realSrcLocSpan . positionToRealSrcLoc nfp) pos stale = unsafeRunStaleIdeFast "hoverProvider" state nfp cfg <- liftIO $ runIde "plugin" "config" state (getTacticConfigAction plId) - liftIO $ fromMaybeT (Right Nothing) $ do + (fmap . fmap) maybeToNull <$> liftIO $ fromMaybeT (Right Nothing) $ do holes <- stale GetMetaprograms fmap (Right . Just) $ @@ -47,13 +48,13 @@ hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurr HoleJudgment{hj_jdg=jdg, hj_ctx=ctx} <- judgementForHole state nfp tr_range cfg z <- liftIO $ attempt_it rsl ctx jdg $ T.unpack program pure $ Hover - { _contents = HoverContents - $ MarkupContent MkMarkdown + { _contents = InL + $ MarkupContent MarkupKind_Markdown $ either T.pack T.pack z , _range = Just $ unTrack tr_range } Nothing -> empty -hoverProvider _ _ _ = pure $ Right Nothing +hoverProvider _ _ _ = pure $ Right $ InR Null fromMaybeT :: Functor m => a -> MaybeT m a -> m a fromMaybeT def = fmap (fromMaybe def) . runMaybeT diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/TacticProviders.hs b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/TacticProviders.hs index 68da7fc5c0..4d28c92ad8 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/TacticProviders.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer/TacticProviders.hs @@ -17,7 +17,7 @@ import qualified Data.Set as S import qualified Data.Text as T import Development.IDE.GHC.Compat import Ide.Types hiding (Config) -import Language.LSP.Types hiding (SemanticTokenAbsolute (..), SemanticTokenRelative (..)) +import Language.LSP.Protocol.Types import Prelude hiding (span) import Wingman.AbstractLSP.Types import Wingman.Auto @@ -86,7 +86,7 @@ tacticPreferred RunMetaprogram = True mkTacticKind :: TacticCommand -> CodeActionKind mkTacticKind = - CodeActionUnknown . mappend "refactor.wingman." . tacticKind + CodeActionKind_Custom . mappend "refactor.wingman." . tacticKind ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/ProofState.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/ProofState.hs index 8c128a9153..529c5c29cd 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/ProofState.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/Metaprogramming/ProofState.hs @@ -10,7 +10,7 @@ import Data.Functor ((<&>)) import qualified Data.Text as T import Prettyprinter import Prettyprinter.Render.Util.Panic -import Language.LSP.Types (sectionSeparator) +import Language.LSP.Protocol.Types (sectionSeparator) import Wingman.Judgements (jHypothesis) import Wingman.Types diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Plugin.hs index b55ee31ae3..5b6cc89150 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/Plugin.hs @@ -6,7 +6,7 @@ import Development.IDE.Core.Shake (IdeState (..)) import Development.IDE.Plugin.CodeAction import qualified Development.IDE.GHC.ExactPrint as E import Ide.Types -import Language.LSP.Types +import Language.LSP.Protocol.Message import Prelude hiding (span) import Wingman.AbstractLSP import Wingman.AbstractLSP.TacticActions (makeTacticInteraction) @@ -18,7 +18,7 @@ import Wingman.StaticPlugin import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) data Log - = LogWingmanLanguageServer WingmanLanguageServer.Log + = LogWingmanLanguageServer WingmanLanguageServer.Log | LogExactPrint E.Log deriving Show @@ -35,7 +35,7 @@ descriptor recorder plId : fmap makeTacticInteraction [minBound .. maxBound] ) $ (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentHover hoverProvider + { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hoverProvider , pluginRules = wingmanRules (cmapWithPrio LogWingmanLanguageServer recorder) plId , pluginConfigDescriptor = defaultConfigDescriptor diff --git a/plugins/hls-tactics-plugin/old/test/Utils.hs b/plugins/hls-tactics-plugin/old/test/Utils.hs index 2bde87c191..b36c5b54e1 100644 --- a/plugins/hls-tactics-plugin/old/test/Utils.hs +++ b/plugins/hls-tactics-plugin/old/test/Utils.hs @@ -23,9 +23,9 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Ide.Plugin.Tactic as Tactic import Ide.Types (IdePlugins(..)) -import Language.LSP.Types -import Language.LSP.Types.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title) -import qualified Language.LSP.Types.Lens as J +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title, error) import System.Directory (doesFileExist) import System.FilePath import Test.Hls @@ -118,7 +118,7 @@ invokeTactic doc InvokeTactic{..} = do case find ((== Just (tacticTitle it_command it_argument)) . codeActionTitle) actions of Just (InR CodeAction {_command = Just c}) -> do executeCommand c - void $ skipManyTill anyMessage $ message SWorkspaceApplyEdit + void $ skipManyTill anyMessage $ message SMethod_WorkspaceApplyEdit _ -> error $ show actions @@ -154,7 +154,7 @@ mkCodeLensTest input = lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc for_ lenses $ \(CodeLens _ (Just cmd) _) -> executeCommand cmd - _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) + _resp <- skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) edited <- documentContents doc let expected_name = input <.> "expected" <.> "hs" -- Write golden tests if they don't already exist @@ -204,7 +204,7 @@ mkShowMessageTest tc occ line col input ufm = Just (InR CodeAction {_command = Just c}) <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions executeCommand c - NotificationMessage _ _ err <- skipManyTill anyMessage (message SWindowShowMessage) + TNotificationMessage _ _ err <- skipManyTill anyMessage (message SMethod_WindowShowMessage) liftIO $ err `shouldBe` mkShowMessageParams ufm @@ -258,9 +258,9 @@ tacticPath :: FilePath tacticPath = "old/test/golden" -executeCommandWithResp :: Command -> Session (ResponseMessage 'WorkspaceExecuteCommand) +executeCommandWithResp :: Command -> Session (TResponseMessage 'Method_WorkspaceExecuteCommand) executeCommandWithResp cmd = do let args = decode $ encode $ fromJust $ cmd ^. arguments execParams = ExecuteCommandParams Nothing (cmd ^. command) args - request SWorkspaceExecuteCommand execParams + request SMethod_WorkspaceExecuteCommand execParams diff --git a/stack-lts19.yaml b/stack-lts19.yaml index ec0b29b52a..0ece22d38a 100644 --- a/stack-lts19.yaml +++ b/stack-lts19.yaml @@ -59,10 +59,11 @@ extra-deps: - retrie-1.1.0.0 - stylish-haskell-0.14.2.0@sha256:fffe1c13ad4c2678cf28a7470cac5d3bf20c71c36f09969e3e5f186787cceb7c,4321 - co-log-core-0.3.1.0 -- lsp-1.6.0.0 -- lsp-types-1.6.0.0 -- lsp-test-0.14.1.0 +- lsp-2.0.0.0 +- lsp-types-2.0.0.1 +- lsp-test-0.15.0.0 - hie-bios-0.12.0 +- row-types-1.0.1.2 configure-options: ghcide: diff --git a/stack.yaml b/stack.yaml index 8ec367da08..c28042b4c0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -48,10 +48,11 @@ extra-deps: - monad-dijkstra-0.1.1.3@sha256:d2fc098d7c122555e726830a12ae0423ac187f89de9228f32e56e2f6fc2238e1,1900 - retrie-1.2.0.1 - co-log-core-0.3.1.0 -- lsp-1.6.0.0 -- lsp-types-1.6.0.0 -- lsp-test-0.14.1.0 +- lsp-2.0.0.0 +- lsp-types-2.0.0.1 +- lsp-test-0.15.0.0 - hie-bios-0.12.0 +- row-types-1.0.1.2 # currently needed for ghcide>extra, etc. allow-newer: true diff --git a/test/functional/Command.hs b/test/functional/Command.hs index d937879e8e..b24390d59f 100644 --- a/test/functional/Command.hs +++ b/test/functional/Command.hs @@ -1,30 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} module Command (tests) where -import Control.Lens hiding (List) +import Control.Lens hiding (List) import Data.Char -import qualified Data.Text as T -import Language.LSP.Types as LSP -import Language.LSP.Types.Lens as LSP +import qualified Data.Text as T +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types as LSP import Test.Hls import Test.Hls.Command -import Test.Hls.Flags (requiresEvalPlugin) +import Test.Hls.Flags (requiresEvalPlugin) tests :: TestTree tests = testGroup "commands" [ testCase "are prefixed" $ runSession hlsCommand fullCaps "test/testdata/" $ do - ResponseMessage _ _ (Right res) <- initializeResponse - let List cmds = res ^. LSP.capabilities . executeCommandProvider . _Just . commands + TResponseMessage _ _ (Right res) <- initializeResponse + let cmds = res ^. L.capabilities . L.executeCommandProvider . _Just . L.commands f x = (T.length (T.takeWhile isNumber x) >= 1) && (T.count ":" x >= 2) liftIO $ do all f cmds @? "All prefixed" not (null cmds) @? "Commands aren't empty" , requiresEvalPlugin $ testCase "get de-prefixed" $ runSession hlsCommand fullCaps "test/testdata/" $ do - ResponseMessage _ _ (Left err) <- request - SWorkspaceExecuteCommand - (ExecuteCommandParams Nothing "34133:eval:evalCommand" (Just (List []))) + TResponseMessage _ _ (Left err) <- request + SMethod_WorkspaceExecuteCommand + (ExecuteCommandParams Nothing "34133:eval:evalCommand" (Just [])) let ResponseError _ msg _ = err -- We expect an error message about the dud arguments, but we can -- check that we found the right plugin. diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index 969a736161..08280d4c4f 100644 --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -1,14 +1,16 @@ +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Completion(tests) where +import Control.Lens hiding ((.=)) import Control.Monad -import Control.Lens hiding ((.=)) -import Data.Aeson (object, (.=)) -import Data.Foldable (find) -import qualified Data.Text as T -import Ide.Plugin.Config (maxCompletions) -import Language.LSP.Types.Lens hiding (applyEdit) +import Data.Aeson (object, (.=)) +import Data.Foldable (find) +import Data.Row.Records (focus) +import qualified Data.Text as T +import Ide.Plugin.Config (maxCompletions) +import Language.LSP.Protocol.Lens hiding (applyEdit, length) import Test.Hls import Test.Hls.Command @@ -16,7 +18,7 @@ getResolvedCompletions :: TextDocumentIdentifier -> Position -> Session [Complet getResolvedCompletions doc pos = do xs <- getCompletions doc pos forM xs $ \item -> do - rsp <- request SCompletionItemResolve item + rsp <- request SMethod_CompletionItemResolve item case rsp ^. result of Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) Right x -> pure x @@ -33,9 +35,9 @@ tests = testGroup "completions" [ item <- getCompletionByLabel "putStrLn" compls liftIO $ do item ^. label @?= "putStrLn" - item ^. kind @?= Just CiFunction + item ^. kind @?= Just CompletionItemKind_Function item ^. detail @?= Just ":: String -> IO ()\nfrom Prelude" - item ^. insertTextFormat @?= Just Snippet + item ^. insertTextFormat @?= Just InsertTextFormat_Snippet item ^. insertText @?= Just "putStrLn" , testCase "itemCompletion/resolve works" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do @@ -48,9 +50,9 @@ tests = testGroup "completions" [ item <- getCompletionByLabel "putStrLn" compls liftIO $ do item ^. label @?= "putStrLn" - item ^. kind @?= Just CiFunction + item ^. kind @?= Just CompletionItemKind_Function item ^. detail @?= Just ":: String -> IO ()\nfrom Prelude" - item ^. insertTextFormat @?= Just Snippet + item ^. insertTextFormat @?= Just InsertTextFormat_Snippet item ^. insertText @?= Just "putStrLn" , testCase "completes imports" $ runSession (hlsCommand <> " --test") fullCaps "test/testdata/completion" $ do @@ -66,7 +68,7 @@ tests = testGroup "completions" [ liftIO $ do item ^. label @?= "Maybe" item ^. detail @?= Just "Data.Maybe" - item ^. kind @?= Just CiModule + item ^. kind @?= Just CompletionItemKind_Module , testCase "completes qualified imports" $ runSession (hlsCommand <> " --test") fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" @@ -81,7 +83,7 @@ tests = testGroup "completions" [ liftIO $ do item ^. label @?= "List" item ^. detail @?= Just "Data.List" - item ^. kind @?= Just CiModule + item ^. kind @?= Just CompletionItemKind_Module , testCase "completes with no prefix" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" @@ -126,7 +128,7 @@ tests = testGroup "completions" [ item <- getCompletionByLabel "accessor" compls liftIO $ do item ^. label @?= "accessor" - item ^. kind @?= Just CiFunction + item ^. kind @?= Just CompletionItemKind_Function , testCase "have implicit foralls on basic polymorphic types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "Completion.hs" "haskell" @@ -163,7 +165,7 @@ tests = testGroup "completions" [ item <- getCompletionByLabel "Alternative" compls liftIO $ do item ^. label @?= "Alternative" - item ^. kind @?= Just CiFunction + item ^. kind @?= Just CompletionItemKind_Function item ^. detail @?= Just "Control.Applicative" , testCase "import second function completion" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do @@ -176,7 +178,7 @@ tests = testGroup "completions" [ item <- getCompletionByLabel "liftA" compls liftIO $ do item ^. label @?= "liftA" - item ^. kind @?= Just CiFunction + item ^. kind @?= Just CompletionItemKind_Function item ^. detail @?= Just "Control.Applicative" , testCase "completes locally defined associated type family" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do @@ -186,7 +188,7 @@ tests = testGroup "completions" [ item <- getCompletionByLabel "Fam" compls liftIO $ do item ^. label @?= "Fam" - item ^. kind @?= Just CiStruct + item ^. kind @?= Just CompletionItemKind_Struct , contextTests , snippetTests @@ -203,7 +205,7 @@ snippetTests = testGroup "snippets" [ compls <- getResolvedCompletions doc (Position 5 14) item <- getCompletionByLabel "Nothing" compls liftIO $ do - item ^. insertTextFormat @?= Just Snippet + item ^. insertTextFormat @?= Just InsertTextFormat_Snippet item ^. insertText @?= Just "Nothing" , testCase "work for polymorphic types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do @@ -216,8 +218,8 @@ snippetTests = testGroup "snippets" [ item <- getCompletionByLabel "foldl" compls liftIO $ do item ^. label @?= "foldl" - item ^. kind @?= Just CiFunction - item ^. insertTextFormat @?= Just Snippet + item ^. kind @?= Just CompletionItemKind_Function + item ^. insertTextFormat @?= Just InsertTextFormat_Snippet item ^. insertText @?= Just "foldl" , testCase "work for complex types" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do @@ -230,8 +232,8 @@ snippetTests = testGroup "snippets" [ item <- getCompletionByLabel "mapM" compls liftIO $ do item ^. label @?= "mapM" - item ^. kind @?= Just CiFunction - item ^. insertTextFormat @?= Just Snippet + item ^. kind @?= Just CompletionItemKind_Function + item ^. insertTextFormat @?= Just InsertTextFormat_Snippet item ^. insertText @?= Just "mapM" , testCase "work for infix functions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do @@ -244,8 +246,8 @@ snippetTests = testGroup "snippets" [ item <- getCompletionByLabel "filter" compls liftIO $ do item ^. label @?= "filter" - item ^. kind @?= Just CiFunction - item ^. insertTextFormat @?= Just PlainText + item ^. kind @?= Just CompletionItemKind_Function + item ^. insertTextFormat @?= Just InsertTextFormat_PlainText item ^. insertText @?= Nothing , testCase "work for infix functions in backticks" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do @@ -258,8 +260,8 @@ snippetTests = testGroup "snippets" [ item <- getCompletionByLabel "filter" compls liftIO $ do item ^. label @?= "filter" - item ^. kind @?= Just CiFunction - item ^. insertTextFormat @?= Just PlainText + item ^. kind @?= Just CompletionItemKind_Function + item ^. insertTextFormat @?= Just InsertTextFormat_PlainText item ^. insertText @?= Nothing , testCase "work for qualified infix functions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do @@ -272,8 +274,8 @@ snippetTests = testGroup "snippets" [ item <- getCompletionByLabel "intersperse" compls liftIO $ do item ^. label @?= "intersperse" - item ^. kind @?= Just CiFunction - item ^. insertTextFormat @?= Just PlainText + item ^. kind @?= Just CompletionItemKind_Function + item ^. insertTextFormat @?= Just InsertTextFormat_PlainText item ^. insertText @?= Nothing , testCase "work for qualified infix functions in backticks" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do @@ -286,8 +288,8 @@ snippetTests = testGroup "snippets" [ item <- getCompletionByLabel "intersperse" compls liftIO $ do item ^. label @?= "intersperse" - item ^. kind @?= Just CiFunction - item ^. insertTextFormat @?= Just PlainText + item ^. kind @?= Just CompletionItemKind_Function + item ^. insertTextFormat @?= Just InsertTextFormat_PlainText item ^. insertText @?= Nothing , testCase "respects lsp configuration" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do @@ -314,7 +316,7 @@ snippetTests = testGroup "snippets" [ Just c -> pure c Nothing -> liftIO . assertFailure $ "Completion with label 'MkFoo' and insertText starting with 'MkFoo {' not found among " <> show compls liftIO $ do - item ^. insertTextFormat @?= Just Snippet + item ^. insertTextFormat @?= Just InsertTextFormat_Snippet item ^. insertText @?= Just "MkFoo {arg1=${1:_arg1}, arg2=${2:_arg2}, arg3=${3:_arg3}, arg4=${4:_arg4}, arg5=${5:_arg5}}" ] where @@ -326,8 +328,8 @@ snippetTests = testGroup "snippets" [ item <- getCompletionByLabel "foldl" compls liftIO $ do item ^. label @?= "foldl" - item ^. kind @?= Just CiFunction - item ^. insertTextFormat @?= Just PlainText + item ^. kind @?= Just CompletionItemKind_Function + item ^. insertTextFormat @?= Just InsertTextFormat_PlainText item ^. insertText @?= Nothing noSnippetsCaps = @@ -337,7 +339,7 @@ snippetTests = testGroup "snippets" [ . _Just . completionItem . _Just - . snippetSupport + . focus #snippetSupport ?~ False ) fullCaps diff --git a/test/functional/Config.hs b/test/functional/Config.hs index 5f13e7449b..24af9869b4 100644 --- a/test/functional/Config.hs +++ b/test/functional/Config.hs @@ -1,30 +1,31 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} - module Config (tests) where import Control.DeepSeq -import Control.Lens hiding (List, (.=)) +import Control.Lens hiding (List, (.=)) import Control.Monad import Data.Aeson import Data.Hashable -import qualified Data.HashMap.Strict as HM -import qualified Data.Map as Map -import qualified Data.Text as T -import Data.Typeable (Typeable) -import Development.IDE (RuleResult, action, define, - getFilesOfInterestUntracked, - getPluginConfigAction, ideErrorText, - uses_) -import Development.IDE.Test (expectDiagnostics) +import qualified Data.HashMap.Strict as HM +import qualified Data.Map as Map +import Data.Proxy +import qualified Data.Text as T +import Data.Typeable (Typeable) +import Development.IDE (RuleResult, action, define, + getFilesOfInterestUntracked, + getPluginConfigAction, + ideErrorText, uses_) +import Development.IDE.Test (expectDiagnostics) import GHC.Generics import Ide.Plugin.Config import Ide.Types -import Language.LSP.Test as Test -import qualified Language.LSP.Types.Lens as L -import System.FilePath (()) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Test as Test +import System.FilePath (()) import Test.Hls import Test.Hls.Command @@ -44,11 +45,11 @@ configParsingTests = testGroup "config parsing" sendConfigurationChanged (toJSON config) -- Send custom request so server returns a response to prevent blocking - void $ sendNotification (SCustomMethod "non-existent-method") Null + void $ sendNotification (SMethod_CustomMethod (Proxy @"non-existent-method")) Null - logNot <- skipManyTill Test.anyMessage (message SWindowLogMessage) + logNot <- skipManyTill Test.anyMessage (message SMethod_WindowLogMessage) - liftIO $ (logNot ^. L.params . L.xtype) > MtError + liftIO $ (logNot ^. L.params . L.type_) > MessageType_Error || "non-existent-method" `T.isInfixOf` (logNot ^. L.params . L.message) @? "Server sends logMessage with MessageType = Error" ] @@ -92,8 +93,8 @@ genericConfigTests = testGroup "generic plugin config" expectDiagnostics standardDiagnostics ] where - standardDiagnostics = [("Foo.hs", [(DsWarning, (1,0), "Top-level binding")])] - testPluginDiagnostics = [("Foo.hs", [(DsError, (0,0), "testplugin")])] + standardDiagnostics = [("Foo.hs", [(DiagnosticSeverity_Warning, (1,0), "Top-level binding")])] + testPluginDiagnostics = [("Foo.hs", [(DiagnosticSeverity_Error, (0,0), "testplugin")])] runConfigSession subdir = failIfSessionTimeout . runSessionWithServer @() plugin ("test/testdata" subdir) diff --git a/test/functional/Deferred.hs b/test/functional/Deferred.hs index 02239701e9..d4eeb70e00 100644 --- a/test/functional/Deferred.hs +++ b/test/functional/Deferred.hs @@ -3,10 +3,11 @@ {-# LANGUAGE OverloadedStrings #-} module Deferred(tests) where -import Control.Lens hiding (List) +import Control.Lens hiding (List) -- import Control.Monad -- import Data.Maybe -import Language.LSP.Types.Lens hiding (id, message) +import Language.LSP.Protocol.Lens hiding (id, length, message) +import Language.LSP.Protocol.Types (Null (Null)) -- import qualified Language.LSP.Types.Lens as LSP import Test.Hls import Test.Hls.Command @@ -88,7 +89,7 @@ tests = testGroup "deferred responses" [ testCase "instantly respond to failed modules with no cache" $ runSession hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "FuncTestFail.hs" "haskell" defs <- getDefinitions doc (Position 1 11) - liftIO $ defs @?= InR [] + liftIO $ defs @?= InR (InR Null) -- TODO: the benefits of caching parsed modules is doubted. -- TODO: add issue link @@ -154,17 +155,17 @@ multiMainTests = testGroup "multiple main modules" [ testCase "Can load one file at a time, when more than one Main module exists" $ runSession hlsCommand fullCaps "test/testdata" $ do _doc <- openDoc "ApplyRefact2.hs" "haskell" - _diagsRspHlint <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics) - diagsRspGhc <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics) - let (List diags) = diagsRspGhc ^. params . diagnostics + _diagsRspHlint <- skipManyTill anyNotification (message SMethod_TextDocumentPublishDiagnostics) + diagsRspGhc <- skipManyTill anyNotification (message SMethod_TextDocumentPublishDiagnostics) + let diags = diagsRspGhc ^. params . diagnostics liftIO $ length diags @?= 2 _doc2 <- openDoc "HaReRename.hs" "haskell" - _diagsRspHlint2 <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics) + _diagsRspHlint2 <- skipManyTill anyNotification (message SMethod_TextDocumentPublishDiagnostics) -- errMsg <- skipManyTill anyNotification notification :: Session ShowMessageNotification - diagsRsp2 <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics) - let (List diags2) = diagsRsp2 ^. params . diagnostics + diagsRsp2 <- skipManyTill anyNotification (message SMethod_TextDocumentPublishDiagnostics) + let diags2 = diagsRsp2 ^. params . diagnostics liftIO $ show diags2 @?= "[]" ] diff --git a/test/functional/Definition.hs b/test/functional/Definition.hs index 85ed8b876d..24ce49297d 100644 --- a/test/functional/Definition.hs +++ b/test/functional/Definition.hs @@ -1,7 +1,7 @@ module Definition (tests) where import Control.Lens -import Language.LSP.Types.Lens +import Language.LSP.Protocol.Lens import System.Directory import Test.Hls import Test.Hls.Command @@ -14,7 +14,7 @@ tests = testGroup "definitions" [ doc <- openDoc "References.hs" "haskell" defs <- getDefinitions doc (Position 7 8) let expRange = Range (Position 4 0) (Position 4 3) - liftIO $ defs @?= InL [Location (doc ^. uri) expRange] + liftIO $ defs @?= InL (Definition (InR [Location (doc ^. uri) expRange])) -- ----------------------------------- @@ -24,7 +24,7 @@ tests = testGroup "definitions" [ defs <- getDefinitions doc (Position 2 8) liftIO $ do fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= InL [Location (filePathToUri fp) zeroRange] + defs @?= InL (Definition (InR [Location (filePathToUri fp) zeroRange])) , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ testCase "goto's exported modules" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do @@ -32,7 +32,7 @@ tests = testGroup "definitions" [ defs <- getDefinitions doc (Position 0 15) liftIO $ do fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= InL [Location (filePathToUri fp) zeroRange] + defs @?= InL (Definition (InR [Location (filePathToUri fp) zeroRange])) , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ testCase "goto's imported modules that are loaded" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do @@ -41,7 +41,7 @@ tests = testGroup "definitions" [ defs <- getDefinitions doc (Position 2 8) liftIO $ do fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= InL [Location (filePathToUri fp) zeroRange] + defs @?= InL (Definition (InR [Location (filePathToUri fp) zeroRange])) , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ testCase "goto's imported modules that are loaded, and then closed" $ @@ -54,7 +54,7 @@ tests = testGroup "definitions" [ liftIO $ putStrLn "D" liftIO $ do fp <- canonicalizePath "test/testdata/definition/Bar.hs" - defs @?= InL [Location (filePathToUri fp) zeroRange] + defs @?= InL (Definition (InR [Location (filePathToUri fp) zeroRange])) liftIO $ putStrLn "E" -- AZ noDiagnostics diff --git a/test/functional/Diagnostic.hs b/test/functional/Diagnostic.hs index 089a3ecbe2..6d4502d145 100644 --- a/test/functional/Diagnostic.hs +++ b/test/functional/Diagnostic.hs @@ -2,8 +2,8 @@ module Diagnostic (tests) where -import Control.Lens hiding (List) -import qualified Language.LSP.Types.Lens as LSP +import Control.Lens hiding (List) +import qualified Language.LSP.Protocol.Lens as L import Test.Hls import Test.Hls.Command @@ -19,6 +19,6 @@ warningTests = testGroup "Warnings are warnings" [ runSession hlsCommand fullCaps "test/testdata/wErrorTest" $ do doc <- openDoc "src/WError.hs" "haskell" [diag] <- waitForDiagnosticsFrom doc - liftIO $ diag ^. LSP.severity @?= Just DsWarning + liftIO $ diag ^. L.severity @?= Just DiagnosticSeverity_Warning ] diff --git a/test/functional/Format.hs b/test/functional/Format.hs index cb434b28f1..42410d2068 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -2,20 +2,20 @@ {-# LANGUAGE OverloadedStrings #-} module Format (tests) where -import Control.Lens ((^.)) +import Control.Lens ((^.)) import Control.Monad.IO.Class import Data.Aeson -import qualified Data.ByteString.Lazy as BS -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as T +import qualified Data.ByteString.Lazy as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types import Language.LSP.Test -import Language.LSP.Types -import qualified Language.LSP.Types.Lens as LSP import Test.Hls import Test.Hls.Command -import Test.Hls.Flags (requiresFloskellPlugin, - requiresOrmoluPlugin) +import Test.Hls.Flags (requiresFloskellPlugin, + requiresOrmoluPlugin) tests :: TestTree tests = testGroup "format document" [ @@ -47,11 +47,11 @@ providerTests :: TestTree providerTests = testGroup "formatting provider" [ testCase "respects none" $ runSessionWithConfig (formatConfig "none") hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" - resp <- request STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) - liftIO $ case resp ^. LSP.result of + resp <- request SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) + liftIO $ case resp ^. L.result of result@(Left (ResponseError reason message Nothing)) -> case reason of - MethodNotFound -> pure () -- No formatter - InvalidRequest | "No plugin enabled for STextDocumentFormatting" `T.isPrefixOf` message -> pure () + (InR ErrorCodes_MethodNotFound) -> pure () -- No formatter + (InR ErrorCodes_InvalidRequest) | "No plugin enabled for SMethod_TextDocumentFormatting" `T.isPrefixOf` message -> pure () _ -> assertFailure $ "strange response from formatting provider:" ++ show result result -> assertFailure $ "strange response from formatting provider:" ++ show result diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index b3fe0fc2a3..7afde93f97 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -4,21 +4,21 @@ module FunctionalCodeAction (tests) where -import Control.Lens hiding (List) +import Control.Lens hiding (List) import Control.Monad import Data.Aeson -import Data.Aeson.Lens (_Object) +import Data.Aeson.Lens (_Object) import Data.List -import qualified Data.Map as M +import qualified Data.Map as M import Data.Maybe -import qualified Data.Text as T +import qualified Data.Text as T import Ide.Plugin.Config -import Language.LSP.Test as Test -import qualified Language.LSP.Types.Lens as L +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Test as Test import Test.Hls import Test.Hspec.Expectations -import Development.IDE.Test (configureCheckProject) +import Development.IDE.Test (configureCheckProject) import Test.Hls.Command {-# ANN module ("HLint: ignore Reduce duplication"::String) #-} @@ -64,7 +64,7 @@ renameTests = testGroup "rename suggestions" [ cmd <- liftIO $ inspectCommand cars ["Replace with", "putStrLn"] let mbArgs = cmd ^. L.arguments case mbArgs of - Just (List [args]) -> liftIO $ do + Just [args] -> liftIO $ do let editParams = args ^. ix "fallbackWorkspaceEdit" . _Object (editParams & has (ix "changes")) @? "Contains changes" not (editParams & has (ix "documentChanges")) @? "Doesn't contain documentChanges" @@ -184,7 +184,7 @@ packageTests = testGroup "add package suggestions" [ (InR action:_) -> do liftIO $ do action ^. L.title @?= "Add text as a dependency" - action ^. L.kind @?= Just CodeActionQuickFix + action ^. L.kind @?= Just CodeActionKind_QuickFix "package:add" `T.isSuffixOf` (action ^. L.command . _Just . L.command) @? "Command contains package:add" executeCodeAction action @@ -218,7 +218,7 @@ packageTests = testGroup "add package suggestions" [ liftIO $ do action ^. L.title @?= "Add zlib as a dependency" - forM_ allActions $ \a -> a ^. L.kind @?= Just CodeActionQuickFix + forM_ allActions $ \a -> a ^. L.kind @?= Just CodeActionKind_QuickFix forM_ allActions $ \a -> "package:add" `T.isSuffixOf` (a ^. L.command . _Just . L.command) @? "Command contains package:add" executeCodeAction action @@ -255,7 +255,7 @@ redundantImportTests = testGroup "redundant import code actions" [ case mbRemoveAction of Just removeAction -> do liftIO $ do - forM_ allActions $ \a -> a ^. L.kind @?= Just CodeActionQuickFix + forM_ allActions $ \a -> a ^. L.kind @?= Just CodeActionKind_QuickFix forM_ allActions $ \a -> a ^. L.command @?= Nothing forM_ allActions $ \a -> isJust (a ^. L.edit) @? "Has edit" @@ -425,23 +425,23 @@ unusedTermTests = testGroup "unused term code actions" [ _ <- waitForDiagnosticsFrom doc diags <- getCurrentDiagnostics doc let params = CodeActionParams Nothing Nothing doc (Range (Position 1 0) (Position 4 0)) caContext - caContext = CodeActionContext (List diags) (Just (List [CodeActionRefactor])) - caContextAllActions = CodeActionContext (List diags) Nothing + caContext = CodeActionContext diags (Just [CodeActionKind_Refactor]) Nothing + caContextAllActions = CodeActionContext diags Nothing Nothing -- Verify that we get code actions of at least two different kinds. - ResponseMessage _ _ (Right (List res)) - <- request STextDocumentCodeAction (params & L.context .~ caContextAllActions) + TResponseMessage _ _ (Right res) + <- request SMethod_TextDocumentCodeAction (params & L.context .~ caContextAllActions) liftIO $ do - let cas = map fromAction res + let cas = map fromAction $ absorbNull res kinds = map (^. L.kind) cas - assertBool "Test precondition failed" $ Just CodeActionQuickFix `elem` kinds + assertBool "Test precondition failed" $ Just CodeActionKind_QuickFix `elem` kinds -- Verify that that when we set the only parameter, we only get actions -- of the right kind. - ResponseMessage _ _ (Right (List res)) <- request STextDocumentCodeAction params + TResponseMessage _ _ (Right res) <- request SMethod_TextDocumentCodeAction params liftIO $ do - let cas = map fromAction res + let cas = map fromAction $ absorbNull res kinds = map (^. L.kind) cas assertBool "Quick fixes should have been filtered out" - $ Just CodeActionQuickFix `notElem` kinds + $ Just CodeActionKind_QuickFix `notElem` kinds ] disableWingman :: Session () diff --git a/test/functional/HieBios.hs b/test/functional/HieBios.hs index ea4d2515bf..28e76aa4ff 100644 --- a/test/functional/HieBios.hs +++ b/test/functional/HieBios.hs @@ -1,11 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module HieBios (tests) where -import Control.Lens ((^.)) +import Control.Lens ((^.)) import Control.Monad.IO.Class -import qualified Data.Text as T -import qualified Language.LSP.Types.Lens as L -import System.FilePath (()) +import qualified Data.Text as T +import qualified Language.LSP.Protocol.Lens as L +import System.FilePath (()) import Test.Hls import Test.Hls.Command @@ -19,7 +19,7 @@ tests = testGroup "hie-bios" [ Just mainHoverText <- getHover doc (Position 3 1) let hoverContents = mainHoverText ^. L.contents case hoverContents of - (HoverContents (MarkupContent _ x)) -> do + (InL (MarkupContent _ x)) -> do liftIO $ "main :: IO ()" `T.isInfixOf` x @? "found hover text for main" _ -> error $ "Unexpected hover contents: " ++ show hoverContents diff --git a/test/functional/Highlight.hs b/test/functional/Highlight.hs index fcc8e8ea04..28b2a2d393 100644 --- a/test/functional/Highlight.hs +++ b/test/functional/Highlight.hs @@ -12,10 +12,10 @@ tests = testGroup "highlight" [ highlights <- getHighlights doc (Position 2 2) liftIO $ do let hls = - [ DocumentHighlight (mkRange 2 0 2 3) (Just HkWrite) - , DocumentHighlight (mkRange 4 22 4 25) (Just HkRead) - , DocumentHighlight (mkRange 3 6 3 9) (Just HkRead) - , DocumentHighlight (mkRange 1 0 1 3) (Just HkRead)] + [ DocumentHighlight (mkRange 2 0 2 3) (Just DocumentHighlightKind_Write) + , DocumentHighlight (mkRange 4 22 4 25) (Just DocumentHighlightKind_Read) + , DocumentHighlight (mkRange 3 6 3 9) (Just DocumentHighlightKind_Read) + , DocumentHighlight (mkRange 1 0 1 3) (Just DocumentHighlightKind_Read)] mapM_ (\x -> x `elem` highlights @? "Contains highlight") hls ] where diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index e4f84f82ce..62d90e3314 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -5,20 +5,19 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} - +{-# LANGUAGE ViewPatterns #-} module Progress (tests) where -import Control.Exception (throw) -import Control.Lens hiding ((.=)) -import Data.Aeson (Value, decode, encode, object, - (.=)) -import Data.List (delete) -import Data.Maybe (fromJust) -import Data.Text (Text, pack) -import qualified Language.LSP.Types as LSP -import Language.LSP.Types.Capabilities -import qualified Language.LSP.Types.Lens as L -import System.FilePath (()) +import Control.Exception (throw) +import Control.Lens hiding ((.=)) +import Data.Aeson (Value, decode, encode, + object, (.=)) +import Data.List (delete) +import Data.Maybe (fromJust) +import Data.Text (Text, pack) +import Language.LSP.Protocol.Capabilities +import qualified Language.LSP.Protocol.Lens as L +import System.FilePath (()) import Test.Hls import Test.Hls.Command import Test.Hls.Flags @@ -36,20 +35,20 @@ tests = , requiresEvalPlugin $ testCase "eval plugin sends progress reports" $ runSession hlsCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do doc <- openDoc "T1.hs" "haskell" - lspId <- sendRequest STextDocumentCodeLens (CodeLensParams Nothing Nothing doc) + lspId <- sendRequest SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc) (codeLensResponse, activeProgressTokens) <- expectProgressMessagesTill - (responseForId STextDocumentCodeLens lspId) + (responseForId SMethod_TextDocumentCodeLens lspId) ["Setting up testdata (for T1.hs)", "Processing", "Indexing"] [] -- this is a test so exceptions result in fails - let response = getResponseResult codeLensResponse + let response = getMessageResult codeLensResponse case response of - LSP.List [evalLens] -> do + InL [evalLens] -> do let command = evalLens ^?! L.command . _Just - _ <- sendRequest SWorkspaceExecuteCommand $ + _ <- sendRequest SMethod_WorkspaceExecuteCommand $ ExecuteCommandParams Nothing (command ^. L.command) @@ -62,14 +61,14 @@ tests = sendConfigurationChanged (formatLspConfig "ormolu") doc <- openDoc "Format.hs" "haskell" expectProgressMessages ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] [] - _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) + _ <- sendRequest SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) expectProgressMessages ["Formatting Format.hs"] [] , requiresFourmoluPlugin $ testCase "fourmolu plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata/format" $ do sendConfigurationChanged (formatLspConfig "fourmolu") doc <- openDoc "Format.hs" "haskell" expectProgressMessages ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] [] - _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) + _ <- sendRequest SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) expectProgressMessages ["Formatting Format.hs"] [] ] @@ -81,9 +80,9 @@ progressCaps = fullCaps{_window = Just (WindowClientCapabilities (Just True) Not data ProgressMessage = ProgressCreate WorkDoneProgressCreateParams - | ProgressBegin (ProgressParams WorkDoneProgressBeginParams) - | ProgressReport (ProgressParams WorkDoneProgressReportParams) - | ProgressEnd (ProgressParams WorkDoneProgressEndParams) + | ProgressBegin ProgressToken WorkDoneProgressBegin + | ProgressReport ProgressToken WorkDoneProgressReport + | ProgressEnd ProgressToken WorkDoneProgressEnd data InterestingMessage a = InterestingMessage a @@ -93,15 +92,21 @@ progressMessage :: Session ProgressMessage progressMessage = progressCreate <|> progressBegin <|> progressReport <|> progressEnd where - progressCreate = ProgressCreate . view L.params <$> message SWindowWorkDoneProgressCreate - progressBegin = ProgressBegin <$> satisfyMaybe (\case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Begin x))) -> Just (ProgressParams t x) + progressCreate = ProgressCreate . view L.params <$> message SMethod_WindowWorkDoneProgressCreate + progressBegin :: Session ProgressMessage + progressBegin = satisfyMaybe (\case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams t (preview _workDoneProgressBegin -> Just params))) -> + Just (ProgressBegin t params) _ -> Nothing) - progressReport = ProgressReport <$> satisfyMaybe (\case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Report x))) -> Just (ProgressParams t x) + progressReport :: Session ProgressMessage + progressReport = satisfyMaybe (\case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams t (preview _workDoneProgressReport -> Just params))) -> + Just (ProgressReport t params) _ -> Nothing) - progressEnd = ProgressEnd <$> satisfyMaybe (\case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (End x))) -> Just (ProgressParams t x) + progressEnd :: Session ProgressMessage + progressEnd = satisfyMaybe (\case + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams t (preview _workDoneProgressEnd -> Just params))) + -> Just (ProgressEnd t params) _ -> Nothing) interestingMessage :: Session a -> Session (InterestingMessage a) @@ -142,28 +147,23 @@ updateExpectProgressStateAndRecurseWith :: ([Text] -> [ProgressToken] -> Session updateExpectProgressStateAndRecurseWith f progressMessage expectedTitles activeProgressTokens = do case progressMessage of ProgressCreate params -> do - f expectedTitles (getToken params : activeProgressTokens) - ProgressBegin params -> do - liftIO $ getToken params `expectedIn` activeProgressTokens - f (delete (getTitle params) expectedTitles) activeProgressTokens - ProgressReport params -> do - liftIO $ getToken params `expectedIn` activeProgressTokens + f expectedTitles ((params ^. L.token): activeProgressTokens) + ProgressBegin token params -> do + liftIO $ token `expectedIn` activeProgressTokens + f (delete (params ^. L.title) expectedTitles) activeProgressTokens + ProgressReport token _ -> do + liftIO $ token `expectedIn` activeProgressTokens f expectedTitles activeProgressTokens - ProgressEnd params -> do - liftIO $ getToken params `expectedIn` activeProgressTokens - f expectedTitles (delete (getToken params) activeProgressTokens) - -getTitle :: (L.HasValue s a1, L.HasTitle a1 a2) => s -> a2 -getTitle msg = msg ^. L.value . L.title + ProgressEnd token _ -> do + liftIO $ token `expectedIn` activeProgressTokens + f expectedTitles (delete token activeProgressTokens) -getToken :: L.HasToken s a => s -> a -getToken msg = msg ^. L.token expectedIn :: (Foldable t, Eq a, Show a) => a -> t a -> Assertion expectedIn a as = a `elem` as @? "Unexpected " ++ show a -getResponseResult :: ResponseMessage m -> ResponseResult m -getResponseResult rsp = +getMessageResult :: TResponseMessage m -> MessageResult m +getMessageResult rsp = case rsp ^. L.result of Right x -> x Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) err diff --git a/test/functional/Reference.hs b/test/functional/Reference.hs index e3304fbec1..7c9a11e4d1 100644 --- a/test/functional/Reference.hs +++ b/test/functional/Reference.hs @@ -3,7 +3,7 @@ module Reference (tests) where import Control.Lens import Data.Coerce import Data.List -import Language.LSP.Types.Lens +import Language.LSP.Protocol.Lens import Test.Hls import Test.Hls.Command diff --git a/test/functional/Symbol.hs b/test/functional/Symbol.hs index 56a7142701..776296e3ff 100644 --- a/test/functional/Symbol.hs +++ b/test/functional/Symbol.hs @@ -1,11 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module Symbol (tests) where -import Control.Lens (_Just, ix, to, (^?)) +import Control.Lens (_Just, ix, (^?)) import Data.List -import Language.LSP.Test as Test -import Language.LSP.Types.Capabilities -import qualified Language.LSP.Types.Lens as L +import Language.LSP.Protocol.Capabilities +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Test as Test import Test.Hls import Test.Hls.Command @@ -19,44 +19,44 @@ v310Tests :: TestTree v310Tests = testGroup "3.10 hierarchical document symbols" [ testCase "provides nested data types and constructors" $ runSession hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "Symbols.hs" "haskell" - Left symbs <- getDocumentSymbols doc + Right symbs <- getDocumentSymbols doc - let myData = DocumentSymbol "MyData" Nothing SkStruct Nothing Nothing myDataR myDataSR (Just (List [a, b])) - a = DocumentSymbol "A" Nothing SkConstructor Nothing Nothing aR aSR Nothing - b = DocumentSymbol "B" Nothing SkConstructor Nothing Nothing bR bSR Nothing - let myData' = symbs ^? ix 0 . L.children . _Just .to fromList . ix 2 + let myData = DocumentSymbol "MyData" Nothing SymbolKind_Struct Nothing Nothing myDataR myDataSR (Just [a, b]) + a = DocumentSymbol "A" Nothing SymbolKind_Constructor Nothing Nothing aR aSR Nothing + b = DocumentSymbol "B" Nothing SymbolKind_Constructor Nothing Nothing bR bSR Nothing + let myData' = symbs ^? ix 0 . L.children . _Just . ix 2 liftIO $ Just myData == myData' @? "Contains symbol" , ignoreTestBecause "extracting symbols from nested wheres not supported" $ testCase "provides nested where functions" $ runSession hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "Symbols.hs" "haskell" - Left symbs <- getDocumentSymbols doc + Right symbs <- getDocumentSymbols doc - let foo = DocumentSymbol "foo" Nothing SkFunction Nothing Nothing fooR fooSR (Just (List [bar])) - bar = DocumentSymbol "bar" Nothing SkFunction Nothing Nothing barR barSR (Just (List [dog, cat])) - dog = DocumentSymbol "dog" Nothing SkVariable Nothing Nothing dogR dogSR (Just mempty) - cat = DocumentSymbol "cat" Nothing SkVariable Nothing Nothing catR catSR (Just mempty) - let foo' = symbs ^? ix 0 . L.children . _Just .to fromList . ix 1 + let foo = DocumentSymbol "foo" Nothing SymbolKind_Function Nothing Nothing fooR fooSR (Just [bar]) + bar = DocumentSymbol "bar" Nothing SymbolKind_Function Nothing Nothing barR barSR (Just [dog, cat]) + dog = DocumentSymbol "dog" Nothing SymbolKind_Variable Nothing Nothing dogR dogSR (Just mempty) + cat = DocumentSymbol "cat" Nothing SymbolKind_Variable Nothing Nothing catR catSR (Just mempty) + let foo' = symbs ^? ix 0 . L.children . _Just . ix 1 liftIO $ Just foo == foo' @? "Contains symbol" , ignoreTestBecause "extracting pattern synonym symbols not supported" $ testCase "provides pattern synonyms" $ runSession hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "Symbols.hs" "haskell" - Left symbs <- getDocumentSymbols doc + Right symbs <- getDocumentSymbols doc let testPattern = DocumentSymbol "TestPattern" - Nothing SkFunction Nothing Nothing testPatternR testPatternSR (Just mempty) - let testPattern' = symbs ^? ix 0 . L.children . _Just .to fromList . ix 3 + Nothing SymbolKind_Function Nothing Nothing testPatternR testPatternSR (Just mempty) + let testPattern' = symbs ^? ix 0 . L.children . _Just . ix 3 liftIO $ Just testPattern == testPattern' @? "Contains symbol" , testCase "provides imports" $ runSession hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "Symbols.hs" "haskell" - Left symbs <- getDocumentSymbols doc + Right symbs <- getDocumentSymbols doc - let imports = DocumentSymbol "imports" Nothing SkModule Nothing Nothing importsR importsSR (Just (List [importDataMaybe])) - importDataMaybe = DocumentSymbol "import Data.Maybe" Nothing SkModule Nothing Nothing importDataMaybeR importDataMaybeSR Nothing - let imports' = symbs ^? ix 0 . L.children . _Just .to fromList . ix 0 + let imports = DocumentSymbol "imports" Nothing SymbolKind_Module Nothing Nothing importsR importsSR (Just [importDataMaybe]) + importDataMaybe = DocumentSymbol "import Data.Maybe" Nothing SymbolKind_Module Nothing Nothing importDataMaybeR importDataMaybeSR Nothing + let imports' = symbs ^? ix 0 . L.children . _Just . ix 0 liftIO $ Just imports == imports' @? "Contains symbol" ] @@ -65,41 +65,41 @@ pre310Tests :: TestTree pre310Tests = testGroup "pre 3.10 symbol information" [ testCase "provides nested data types and constructors" $ runSession hlsCommand oldCaps "test/testdata" $ do doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell" - Right symbs <- getDocumentSymbols doc + Left symbs <- getDocumentSymbols doc - let myData = SymbolInformation "MyData" SkStruct Nothing Nothing (Location testUri myDataR) (Just "Symbols") - a = SymbolInformation "A" SkConstructor Nothing Nothing (Location testUri aR) (Just "MyData") - b = SymbolInformation "B" SkConstructor Nothing Nothing (Location testUri bR) (Just "MyData") + let myData = SymbolInformation "MyData" SymbolKind_Struct Nothing (Just "Symbols") Nothing (Location testUri myDataR) + a = SymbolInformation "A" SymbolKind_Constructor Nothing (Just "MyData") Nothing (Location testUri aR) + b = SymbolInformation "B" SymbolKind_Constructor Nothing (Just "MyData") Nothing (Location testUri bR) liftIO $ [myData, a, b] `isInfixOf` symbs @? "Contains symbols" , ignoreTestBecause "extracting symbols from nested wheres not supported" $ testCase "provides nested where functions" $ runSession hlsCommand oldCaps "test/testdata" $ do doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell" - Right symbs <- getDocumentSymbols doc + Left symbs <- getDocumentSymbols doc - let foo = SymbolInformation "foo" SkFunction Nothing Nothing (Location testUri fooR) (Just "Symbols") - bar = SymbolInformation "bar" SkFunction Nothing Nothing (Location testUri barR) (Just "foo") - dog = SymbolInformation "dog" SkVariable Nothing Nothing (Location testUri dogR) (Just "bar") - cat = SymbolInformation "cat" SkVariable Nothing Nothing (Location testUri catR) (Just "bar") + let foo = SymbolInformation "foo" SymbolKind_Function Nothing (Just "Symbols") Nothing (Location testUri fooR) + bar = SymbolInformation "bar" SymbolKind_Function Nothing (Just "foo") Nothing (Location testUri barR) + dog = SymbolInformation "dog" SymbolKind_Variable Nothing (Just "bar") Nothing (Location testUri dogR) + cat = SymbolInformation "cat" SymbolKind_Variable Nothing (Just "bar") Nothing (Location testUri catR) -- Order is important! liftIO $ [foo, bar, dog, cat] `isInfixOf` symbs @? "Contains symbols" , ignoreTestBecause "extracting pattern synonym symbols not supported" $ testCase "provides pattern synonyms" $ runSession hlsCommand oldCaps "test/testdata" $ do doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell" - Right symbs <- getDocumentSymbols doc + Left symbs <- getDocumentSymbols doc let testPattern = SymbolInformation "TestPattern" - SkFunction Nothing Nothing (Location testUri testPatternR) (Just "Symbols") + SymbolKind_Function Nothing (Just "Symbols") Nothing (Location testUri testPatternR) liftIO $ testPattern `elem` symbs @? "Contains symbols" , testCase "provides imports" $ runSession hlsCommand oldCaps "test/testdata" $ do doc@(TextDocumentIdentifier testUri) <- openDoc "Symbols.hs" "haskell" - Right symbs <- getDocumentSymbols doc + Left symbs <- getDocumentSymbols doc - let imports = SymbolInformation "imports" SkModule Nothing Nothing (Location testUri importsR) (Just "Symbols") - importDataMaybe = SymbolInformation "import Data.Maybe" SkModule Nothing Nothing (Location testUri importDataMaybeR) (Just "imports") + let imports = SymbolInformation "imports" SymbolKind_Module Nothing (Just "Symbols") Nothing (Location testUri importsR) + importDataMaybe = SymbolInformation "import Data.Maybe" SymbolKind_Module Nothing (Just "imports") Nothing (Location testUri importDataMaybeR) liftIO $ [imports, importDataMaybe] `isInfixOf` symbs @? "Contains symbol" ] @@ -107,9 +107,6 @@ pre310Tests = testGroup "pre 3.10 symbol information" [ oldCaps :: ClientCapabilities oldCaps = capsForVersion (LSPVersion 3 9) -fromList :: List a -> [a] -fromList (List a) = a - -- Some common ranges and selection ranges in Symbols.hs importsR :: Range importsR = Range (Position 3 0) (Position 3 17) diff --git a/test/functional/TypeDefinition.hs b/test/functional/TypeDefinition.hs index f191fbfe7e..c114c4ead1 100644 --- a/test/functional/TypeDefinition.hs +++ b/test/functional/TypeDefinition.hs @@ -33,7 +33,7 @@ getTypeDefinitionTest :: SymbolLocation -> [SymbolLocation] -> Assertion getTypeDefinitionTest (symbolFile, symbolLine, symbolCol) definitionLocations = failIfSessionTimeout . runSession (hlsCommand ++ " --test") fullCaps definitionsPath $ do doc <- openDoc symbolFile "haskell" - InL defs <- getTypeDefinitions doc $ Position symbolLine symbolCol + InL (Definition (InR defs)) <- getTypeDefinitions doc $ Position symbolLine symbolCol liftIO $ defs `expectSameLocations` map (first3 (definitionsPath )) definitionLocations getTypeDefinitionTest' :: UInt -> UInt -> UInt -> UInt -> Assertion