From 646c9161b2e9b4780b8d349e6054eddfa602def4 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 30 May 2023 20:02:13 +0300 Subject: [PATCH 01/70] Add lsp packages from git till they are released And bump hls version to keep cabal sane --- cabal.project | 18 +++++ ghcide-bench/ghcide-bench.cabal | 4 +- ghcide/ghcide.cabal | 12 ++-- ghcide/test/ghcide-test-utils.cabal | 2 +- haskell-language-server.cabal | 66 +++++++++---------- hls-graph/hls-graph.cabal | 2 +- hls-plugin-api/hls-plugin-api.cabal | 6 +- hls-test-utils/hls-test-utils.cabal | 12 ++-- .../hls-alternate-number-format-plugin.cabal | 10 +-- .../hls-cabal-fmt-plugin.cabal | 8 +-- .../hls-cabal-plugin/hls-cabal-plugin.cabal | 14 ++-- .../hls-call-hierarchy-plugin.cabal | 8 +-- .../hls-change-type-signature-plugin.cabal | 8 +-- .../hls-class-plugin/hls-class-plugin.cabal | 8 +-- .../hls-code-range-plugin.cabal | 10 +-- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 8 +-- .../hls-explicit-fixity-plugin.cabal | 8 +-- .../hls-explicit-imports-plugin.cabal | 6 +- .../hls-explicit-record-fields-plugin.cabal | 6 +- .../hls-floskell-plugin.cabal | 10 +-- .../hls-fourmolu-plugin.cabal | 8 +-- plugins/hls-gadt-plugin/hls-gadt-plugin.cabal | 8 +-- .../hls-haddock-comments-plugin.cabal | 8 +-- .../hls-hlint-plugin/hls-hlint-plugin.cabal | 8 +-- .../hls-module-name-plugin.cabal | 8 +-- .../hls-ormolu-plugin/hls-ormolu-plugin.cabal | 8 +-- .../hls-pragmas-plugin.cabal | 8 +-- .../hls-qualify-imported-names-plugin.cabal | 8 +-- .../hls-refactor-plugin.cabal | 8 +-- .../hls-refine-imports-plugin.cabal | 8 +-- .../hls-rename-plugin/hls-rename-plugin.cabal | 8 +-- .../hls-retrie-plugin/hls-retrie-plugin.cabal | 8 +-- .../hls-splice-plugin/hls-splice-plugin.cabal | 8 +-- plugins/hls-stan-plugin/hls-stan-plugin.cabal | 4 +- .../hls-stylish-haskell-plugin.cabal | 8 +-- .../hls-tactics-plugin.cabal | 8 +-- 36 files changed, 184 insertions(+), 166 deletions(-) diff --git a/cabal.project b/cabal.project index 74b62a5d73..a20c323b0e 100644 --- a/cabal.project +++ b/cabal.project @@ -91,6 +91,24 @@ source-repository-package tag: 7a0af7a8fd38045fd15fb13445bdcc7085325460 -- END DELETE +-- This is needed till lsp makes a release +source-repository-package + type:git + location: https://github.com/haskell/lsp + tag: ba7e5cbfaf4ab075a8fc290d61e8c9a96a41fd94 + subdir: lsp +source-repository-package + type:git + location: https://github.com/haskell/lsp + tag: ba7e5cbfaf4ab075a8fc290d61e8c9a96a41fd94 + subdir: lsp-types +source-repository-package + type:git + location: https://github.com/haskell/lsp + tag: ba7e5cbfaf4ab075a8fc290d61e8c9a96a41fd94 + subdir: lsp-test + + allow-newer: -- ghc-9.4 ekg-json:base, diff --git a/ghcide-bench/ghcide-bench.cabal b/ghcide-bench/ghcide-bench.cabal index ddc6d59e06..1d6944aa21 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 @@ -118,7 +118,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/ghcide.cabal b/ghcide/ghcide.cabal index 3999846837..3cc04199d5 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.0, + lsp ^>= 2.0.0.0 , mtl, optparse-applicative, parallel, @@ -80,7 +80,7 @@ library regex-tdfa >= 1.3.1.0, text-rope, safe-exceptions, - hls-graph == 2.0.0.0, + hls-graph == 2.1.0.0, sorted-list, sqlite-simple, stm, @@ -345,7 +345,7 @@ test-suite ghcide-tests hls-plugin-api, lens, list-t, - lsp-test ^>= 0.14, + lsp-test ^>= 0.15, monoid-subclasses, network-uri, QuickCheck, diff --git a/ghcide/test/ghcide-test-utils.cabal b/ghcide/test/ghcide-test-utils.cabal index 5e1791c3b8..8d7bbf73d9 100644 --- a/ghcide/test/ghcide-test-utils.cabal +++ b/ghcide/test/ghcide-test-utils.cabal @@ -35,7 +35,7 @@ library lsp-types, hls-plugin-api, lens, - lsp-test ^>= 0.14, + lsp-test ^>= 0.15, tasty-hunit >= 0.10, text, hs-source-dirs: src diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 3b5b7522ec..5cb44ce2b6 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 @@ -213,144 +213,144 @@ 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 -- formatters common floskell - if flag(floskell) && impl(ghc < 9.5) - build-depends: hls-floskell-plugin == 2.0.0.0 + if flag(floskell) && impl(ghc < 9.5) + 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 @@ -405,12 +405,12 @@ library , cryptohash-sha1 , data-default , ghc - , ghcide == 2.0.0.0 + , ghcide == 2.1.0.0 , githash >=0.1.6.1 , lsp , hie-bios , hiedb - , hls-plugin-api == 2.0.0.0 + , hls-plugin-api == 2.1.0.0 , optparse-applicative , optparse-simple , process @@ -549,7 +549,7 @@ 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 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-test-utils/hls-test-utils.cabal b/hls-test-utils/hls-test-utils.cabal index e1b94070e3..35bfcaeeb6 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.0 , tasty , tasty-expected-failure , tasty-golden 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-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-plugin/hls-cabal-plugin.cabal b/plugins/hls-cabal-plugin/hls-cabal-plugin.cabal index e86c9f3108..284b6973ef 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,12 +48,12 @@ 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.0 , regex-tdfa ^>=1.3.1 , stm , text @@ -74,7 +74,7 @@ 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 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-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..6b43a31507 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,8 +28,8 @@ 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 @@ -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-class-plugin/hls-class-plugin.cabal b/plugins/hls-class-plugin/hls-class-plugin.cabal index 93941d7c3a..7a07046087 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,7 @@ 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 , text 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-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index 401c43c785..c901471dc0 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,7 @@ 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 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-imports-plugin/hls-explicit-imports-plugin.cabal b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal index 62e3b85b90..44a7eb3ac4 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 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-floskell-plugin/hls-floskell-plugin.cabal b/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal index e98f55a1db..0f75b5ac11 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.0 , 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-fourmolu-plugin/hls-fourmolu-plugin.cabal b/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal index e60d6702f2..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 @@ -35,8 +35,8 @@ library , 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-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-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-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index 035d951f04..13478ead07 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,7 @@ 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 , text 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..0472627f0a 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 @@ -32,8 +32,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 , lsp , text , transformers @@ -52,4 +52,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-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-pragmas-plugin/hls-pragmas-plugin.cabal b/plugins/hls-pragmas-plugin/hls-pragmas-plugin.cabal index b5ed8e0b70..24f770cdeb 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 @@ -52,7 +52,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-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-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-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-rename-plugin/hls-rename-plugin.cabal b/plugins/hls-rename-plugin/hls-rename-plugin.cabal index 12476e2252..6351271fdd 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 , lsp , lsp-types @@ -58,4 +58,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-retrie-plugin/hls-retrie-plugin.cabal b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal index 1eff5b6afa..e157db1004 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,9 +28,9 @@ 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 , lsp , lsp-types @@ -63,5 +63,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-splice-plugin/hls-splice-plugin.cabal b/plugins/hls-splice-plugin/hls-splice-plugin.cabal index d5448fd000..b731619473 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,5 @@ test-suite tests , base , filepath , hls-splice-plugin - , hls-test-utils == 2.0.0.0 + , hls-test-utils == 2.1.0.0 , text 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-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-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 From 009c4a0b3e6b1ed4e5c64f71a25ba63d16f54594 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 31 May 2023 17:46:54 +0300 Subject: [PATCH 02/70] hls-plugin-api changes for lsp* 2 packages --- hls-plugin-api/src/Ide/Plugin/ConfigUtils.hs | 51 +-- hls-plugin-api/src/Ide/Plugin/RangeMap.hs | 5 +- hls-plugin-api/src/Ide/PluginUtils.hs | 58 ++-- hls-plugin-api/src/Ide/Types.hs | 347 +++++++++++-------- hls-plugin-api/test/Ide/PluginUtilsTest.hs | 14 +- 5 files changed, 265 insertions(+), 210 deletions(-) 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 f98b38ff80..0fdfe1c0fd 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -40,32 +40,32 @@ module Ide.PluginUtils where -import Control.Arrow ((&&&)) -import Control.Monad.Extra (maybeM) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) +import Control.Arrow ((&&&)) +import Control.Monad.Extra (maybeM) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Data.Algorithm.Diff import Data.Algorithm.DiffOutput -import Data.Bifunctor (Bifunctor (first)) -import Data.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 Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start)) +import qualified Language.LSP.Protocol.Types as J 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 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 -- --------------------------------------------------------------------- @@ -104,14 +104,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) @@ -168,15 +168,15 @@ diffText' supports (f,fText) f2Text withDeletions = else WorkspaceEdit (Just h) Nothing Nothing where diff = diffTextEdit fText f2Text withDeletions - h = H.singleton f diff - docChanges = J.List [InL docEdit] - docEdit = J.TextDocumentEdit (J.VersionedTextDocumentIdentifier f (Just 0)) $ fmap InL diff + h = M.singleton f diff + docChanges = [InL docEdit] + docEdit = J.TextDocumentEdit (J.OptionalVersionedTextDocumentIdentifier f (InL 0)) $ fmap InL diff -- --------------------------------------------------------------------- clientSupportsDocumentChanges :: ClientCapabilities -> Bool clientSupportsDocumentChanges caps = - let ClientCapabilities mwCaps _ _ _ _ = caps + let ClientCapabilities mwCaps _ _ _ _ _ = caps supports = do wCaps <- mwCaps WorkspaceEditClientCapabilities mDc _ _ _ _ <- _workspaceEdit wCaps @@ -280,7 +280,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 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 031158c35b..ffe25452d4 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 InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -51,65 +52,51 @@ 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 (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 Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start), id) +import qualified Language.LSP.Protocol.Types as J +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_ @@ -341,7 +328,13 @@ 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 +-- I removed the HasTracing constraint as with it, I get • +-- No instance for (HasTextDocument InitializedParams doc0) +-- arising from the superclasses of an instance declaration +-- In the instance declaration for +-- ‘PluginMethod 'Notification 'Method_Initialized' +-- class HasTracing (MessageParams m) => PluginMethod (k :: MessageKind) (m :: Method ClientToServer k) where +class 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 plugin is enabled @@ -391,7 +384,7 @@ class HasTracing (MessageParams m) => PluginMethod (k :: MethodType) (m :: Metho -- 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 @@ -400,28 +393,30 @@ class PluginMethod Request m => PluginRequestMethod (m :: Method FromClient Requ -- glorious hover box. -- -- However, sometimes only one handler of a request can realistically exist, - -- such as TextDocumentFormatting, it is safe to just unconditionally report + -- such as Method_TextDocumentFormatting, it is safe to just unconditionally report -- back one arbitrary result (arbitrary since it should only be one anyway). combineResponses :: SMethod m -> 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 -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 = + case fmap compat $ filter wasRequested $ concat $ dumpNulls resps of + [] -> InR J.Null + x -> InL x where compat :: (Command |? CodeAction) -> (Command |? CodeAction) compat x@(InL _) = x @@ -437,7 +432,7 @@ instance PluginRequestMethod TextDocumentCodeAction where 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. @@ -446,145 +441,164 @@ instance PluginRequestMethod TextDocumentCodeAction where , Just caKind <- ca ^. kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed | otherwise = False -instance PluginMethod Request TextDocumentDefinition where + -- Copied form lsp-types 1.6 to get compilation working. May make more + -- sense to add it back to lsp-types 2.0 + -- | Does the first 'CodeActionKind' subsume the other one, hierarchically. Reflexive. + codeActionKindSubsumes :: CodeActionKind -> CodeActionKind -> Bool + -- Simple but ugly implementation: prefix on the string representation + codeActionKindSubsumes parent child = toEnumBaseType parent `T.isPrefixOf` toEnumBaseType child + +instance PluginMethod Request Method_TextDocumentDefinition where pluginEnabled _ msgParams pluginDesc _ = pluginResponsible uri pluginDesc where uri = msgParams ^. J.textDocument . J.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 -instance PluginMethod Request TextDocumentDocumentHighlight where +instance PluginMethod Request Method_TextDocumentDocumentHighlight where pluginEnabled _ msgParams pluginDesc _ = pluginResponsible uri pluginDesc where uri = msgParams ^. J.textDocument . J.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 -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 -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 +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 -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 -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 -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 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 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 -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 -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 -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 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 _ _ _ _ (dumpNulls -> hs) = + if mcontent ^. value == "" + then InR J.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 + -- 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 (^. contents) hs -instance PluginRequestMethod TextDocumentDocumentSymbol where - combineResponses _ _ (ClientCapabilities _ tdc _ _ _) params xs = res +instance PluginRequestMethod Method_TextDocumentDocumentSymbol where + combineResponses _ _ (ClientCapabilities _ tdc _ _ _ _) params xs = res where uri' = params ^. textDocument . uri supportsHierarchy = Just True == (tdc >>= _documentSymbol >>= _hierarchicalDocumentSymbolSupport) - dsOrSi = fmap toEither xs + dsOrSi :: [Either [SymbolInformation] [DocumentSymbol]] + dsOrSi = (fmap toEither) <$> mapMaybe nullToMaybe' $ toList xs + res :: [SymbolInformation] |? ([DocumentSymbol] |? J.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] @@ -593,10 +607,10 @@ instance PluginRequestMethod TextDocumentDocumentSymbol where 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 + si = SymbolInformation name' (ds ^. kind) Nothing parent (ds ^. 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 @@ -608,53 +622,55 @@ instance PluginRequestMethod CompletionItemResolve where & J.additionalTextEdits .~ comp1 ^. J.additionalTextEdits <> comp2 ^. J.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 J.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 J.Null)) = (n, InR (InR J.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 -- --------------------------------------------------------------------- @@ -663,71 +679,71 @@ instance PluginRequestMethod CustomMethod where -- | 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)) @@ -750,7 +766,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 () @@ -767,7 +783,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 @@ -871,7 +887,7 @@ data FormattingType = FormatText type FormattingMethod m = ( J.HasOptions (MessageParams m) FormattingOptions , J.HasTextDocument (MessageParams m) TextDocumentIdentifier - , ResponseResult m ~ List TextEdit + , MessageResult m ~ ([TextEdit] |? Null) ) type FormattingHandler a @@ -880,11 +896,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 @@ -893,9 +909,9 @@ 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 ^. J.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 @@ -907,7 +923,7 @@ mkFormattingHandlers f = mkPluginHandler STextDocumentFormatting (provider SText -- --------------------------------------------------------------------- responseError :: T.Text -> ResponseError -responseError txt = ResponseError InvalidParams txt Nothing +responseError txt = ResponseError ErrorCodes_InvalidParams txt Nothing -- --------------------------------------------------------------------- @@ -955,7 +971,7 @@ mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [Value] -> Command mkLspCommand plid cn title args' = Command title cmdId args where cmdId = mkLspCmdId pROCESS_ID plid cn - args = List <$> args' + args = args' mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text mkLspCmdId pid (PluginId plid) (CommandId cid) @@ -979,3 +995,42 @@ getProcessID = fromIntegral <$> P.getProcessID installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing #endif + +-- The functions below should probably be added to the lsp-types package +-- but temporarily including them here +-- We get null responses, which can be problematic for concat, because of +-- this we need to filter them out +dumpNulls :: Foldable f => f (a |? J.Null) -> [a] +dumpNulls = takeLefts + +takeLefts :: Foldable f => f (a |? b) -> [a] +takeLefts = foldr (\x acc -> case x of + InL x' -> x' : acc + InR _ -> acc) [] + +instance Semigroup s => Semigroup (s |? J.Null) where + InL x <> InL y = InL (x <> y) + InL x <> InR _ = InL x + InR _ <> InL x = InL x + InR _ <> InR y = InR y + +instance Semigroup WorkspaceEdit where + (WorkspaceEdit a b c) <> (WorkspaceEdit a' b' c') = WorkspaceEdit (a <> a') (b <> b') (c <> c') + +class NullToMaybe a b where + nullToMaybe' :: a -> Maybe b + +instance NullToMaybe (a |? J.Null) a where + nullToMaybe' (InL x) = Just x + nullToMaybe' (InR _) = Nothing + +instance NullToMaybe (a |? (b |? J.Null)) (a |? b) where + nullToMaybe' (InL x) = Just $ InL x + nullToMaybe' (InR (InL x)) = Just $ InR x + nullToMaybe' (InR (InR _)) = Nothing + +instance NullToMaybe (a |? (b |? (c |? J.Null))) (a |? (b |? c)) where + nullToMaybe' (InL x) = Just $ InL x + nullToMaybe' (InR (InL x)) = Just $ InR $ InL x + nullToMaybe' (InR (InR (InL x))) = Just $ InR $ InR x + nullToMaybe' (InR (InR (InR _))) = Nothing 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 From 3a17def14030d65aa17b917c9104175ca4f2447f Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 31 May 2023 21:18:30 +0300 Subject: [PATCH 03/70] refactor helper functions --- hls-plugin-api/src/Ide/Types.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index ffe25452d4..26d6fbe6da 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -573,7 +573,7 @@ instance PluginRequestMethod Method_TextDocumentCodeLens where instance PluginRequestMethod Method_TextDocumentRename where instance PluginRequestMethod Method_TextDocumentHover where - combineResponses _ _ _ _ (dumpNulls -> hs) = + combineResponses _ _ _ _ (dumpNulls -> hs :: [Hover]) = if mcontent ^. value == "" then InR J.Null else InL $ Hover (InL mcontent) r @@ -590,7 +590,7 @@ instance PluginRequestMethod Method_TextDocumentDocumentSymbol where uri' = params ^. textDocument . uri supportsHierarchy = Just True == (tdc >>= _documentSymbol >>= _hierarchicalDocumentSymbolSupport) dsOrSi :: [Either [SymbolInformation] [DocumentSymbol]] - dsOrSi = (fmap toEither) <$> mapMaybe nullToMaybe' $ toList xs + dsOrSi = toEither <$> dumpNulls xs res :: [SymbolInformation] |? ([DocumentSymbol] |? J.Null) res | supportsHierarchy = InR $ InL $ concatMap (either (fmap siToDs) id) dsOrSi @@ -1000,14 +1000,17 @@ installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing -- but temporarily including them here -- We get null responses, which can be problematic for concat, because of -- this we need to filter them out -dumpNulls :: Foldable f => f (a |? J.Null) -> [a] -dumpNulls = takeLefts takeLefts :: Foldable f => f (a |? b) -> [a] takeLefts = foldr (\x acc -> case x of InL x' -> x' : acc InR _ -> acc) [] +dumpNulls :: (Foldable f, NullToMaybe a b) => f a -> [b] +dumpNulls = foldr (\x acc -> case nullToMaybe' x of + Just x' -> x' : acc + Nothing -> acc) [] + instance Semigroup s => Semigroup (s |? J.Null) where InL x <> InL y = InL (x <> y) InL x <> InR _ = InL x From b6b6b6824835641567c2bb179d9fa50f75226254 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 1 Jun 2023 13:59:39 +0300 Subject: [PATCH 04/70] Fix a hlint issue I was responsible for creating --- hls-plugin-api/src/Ide/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 26d6fbe6da..d600736c74 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -432,7 +432,7 @@ instance PluginRequestMethod Method_TextDocumentCodeAction where wasRequested (InL _) = True wasRequested (InR ca) | Nothing <- _only context = True - | Just (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. From 9245aba4cf34a11e7043585cef504b5a23769eb5 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 1 Jun 2023 23:07:27 +0300 Subject: [PATCH 05/70] Separate the helper functions and... Readd the HasTracing constraint --- .../src/Ide/TempLSPTypeFunctions.hs | 69 +++++++++++++++++++ hls-plugin-api/src/Ide/Types.hs | 53 +------------- 2 files changed, 72 insertions(+), 50 deletions(-) create mode 100644 hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs diff --git a/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs b/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs new file mode 100644 index 0000000000..b50a33a61c --- /dev/null +++ b/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +module Ide.TempLSPTypeFunctions (takeLefts, dumpNulls, nullToMaybe', NullToMaybe, + toLspId, toTypedResponseError) where +import Data.Aeson (FromJSON (parseJSON), ToJSON, + decode, encode, fromJSON) +import Data.Aeson.Types (parseMaybe) +import Data.Semigroup () +import Data.Text (Text) +import Language.LSP.Protocol.Message (ErrorData, + LspId (IdInt, IdString), + ResponseError (ResponseError), + TResponseError (TResponseError)) +import Language.LSP.Protocol.Types (Int32, Null, + WorkspaceEdit (WorkspaceEdit), + type (|?) (..)) + + +-- The functions below may be added to the lsp-types package if they end up being +-- useful. temporarily including them here now. + + +takeLefts :: Foldable f => f (a |? b) -> [a] +takeLefts = foldr (\x acc -> case x of + InL x' -> x' : acc + InR _ -> acc) [] + +-- Especially when we want to use concat, we are not interested in nulls, +-- because of this we need to filter them out +dumpNulls :: (Foldable f, NullToMaybe a b) => f a -> [b] +dumpNulls = foldr (\x acc -> case nullToMaybe' x of + Just x' -> x' : acc + Nothing -> acc) [] + +instance Semigroup s => Semigroup (s |? Null) where + InL x <> InL y = InL (x <> y) + InL x <> InR _ = InL x + InR _ <> InL x = InL x + InR _ <> InR y = InR y + +instance Semigroup WorkspaceEdit where + (WorkspaceEdit a b c) <> (WorkspaceEdit a' b' c') = WorkspaceEdit (a <> a') (b <> b') (c <> c') + +class NullToMaybe a b where + nullToMaybe' :: a -> Maybe b + +instance NullToMaybe (a |? Null) a where + nullToMaybe' (InL x) = Just x + nullToMaybe' (InR _) = Nothing + +instance NullToMaybe (a |? (b |? Null)) (a |? b) where + nullToMaybe' (InL x) = Just $ InL x + nullToMaybe' (InR (InL x)) = Just $ InR x + nullToMaybe' (InR (InR _)) = Nothing + +instance NullToMaybe (a |? (b |? (c |? Null))) (a |? (b |? c)) where + nullToMaybe' (InL x) = Just $ InL x + nullToMaybe' (InR (InL x)) = Just $ InR $ InL x + nullToMaybe' (InR (InR (InL x))) = Just $ InR $ InR x + nullToMaybe' (InR (InR (InR _))) = Nothing + +toLspId :: (Int32 |? Text) -> LspId a +toLspId (InL x) = IdInt x +toLspId (InR y) = IdString y + +toTypedResponseError :: FromJSON (ErrorData m) => ResponseError -> TResponseError m +toTypedResponseError (ResponseError c m d) = TResponseError c m (decode . encode=<< d) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index d600736c74..3d3ed7f795 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -9,7 +9,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -83,6 +82,7 @@ import Development.IDE.Graph import GHC (DynFlags) import GHC.Generics import Ide.Plugin.Properties +import Ide.TempLSPTypeFunctions import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (length, line), @@ -328,13 +328,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' --- I removed the HasTracing constraint as with it, I get • --- No instance for (HasTextDocument InitializedParams doc0) --- arising from the superclasses of an instance declaration --- In the instance declaration for --- ‘PluginMethod 'Notification 'Method_Initialized' --- class HasTracing (MessageParams m) => PluginMethod (k :: MessageKind) (m :: Method ClientToServer k) where -class PluginMethod (k :: MessageKind) (m :: Method ClientToServer 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 plugin is enabled @@ -954,7 +948,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 @@ -996,44 +990,3 @@ getProcessID = fromIntegral <$> P.getProcessID installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing #endif --- The functions below should probably be added to the lsp-types package --- but temporarily including them here --- We get null responses, which can be problematic for concat, because of --- this we need to filter them out - -takeLefts :: Foldable f => f (a |? b) -> [a] -takeLefts = foldr (\x acc -> case x of - InL x' -> x' : acc - InR _ -> acc) [] - -dumpNulls :: (Foldable f, NullToMaybe a b) => f a -> [b] -dumpNulls = foldr (\x acc -> case nullToMaybe' x of - Just x' -> x' : acc - Nothing -> acc) [] - -instance Semigroup s => Semigroup (s |? J.Null) where - InL x <> InL y = InL (x <> y) - InL x <> InR _ = InL x - InR _ <> InL x = InL x - InR _ <> InR y = InR y - -instance Semigroup WorkspaceEdit where - (WorkspaceEdit a b c) <> (WorkspaceEdit a' b' c') = WorkspaceEdit (a <> a') (b <> b') (c <> c') - -class NullToMaybe a b where - nullToMaybe' :: a -> Maybe b - -instance NullToMaybe (a |? J.Null) a where - nullToMaybe' (InL x) = Just x - nullToMaybe' (InR _) = Nothing - -instance NullToMaybe (a |? (b |? J.Null)) (a |? b) where - nullToMaybe' (InL x) = Just $ InL x - nullToMaybe' (InR (InL x)) = Just $ InR x - nullToMaybe' (InR (InR _)) = Nothing - -instance NullToMaybe (a |? (b |? (c |? J.Null))) (a |? (b |? c)) where - nullToMaybe' (InL x) = Just $ InL x - nullToMaybe' (InR (InL x)) = Just $ InR $ InL x - nullToMaybe' (InR (InR (InL x))) = Just $ InR $ InR x - nullToMaybe' (InR (InR (InR _))) = Nothing From 658757f9f51670e373f9a8ea428bc5d035562f98 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 2 Jun 2023 00:04:02 +0300 Subject: [PATCH 06/70] ghcide checkpoint (doesn't compile) --- ghcide/exe/Main.hs | 2 +- ghcide/ghcide.cabal | 1 + .../session-loader/Development/IDE/Session.hs | 10 +- ghcide/src/Development/IDE/Core/Actions.hs | 8 +- ghcide/src/Development/IDE/Core/Compile.hs | 68 ++++++----- ghcide/src/Development/IDE/Core/FileExists.hs | 10 +- ghcide/src/Development/IDE/Core/FileStore.hs | 36 +++--- .../Development/IDE/Core/IdeConfiguration.hs | 9 +- ghcide/src/Development/IDE/Core/OfInterest.hs | 14 ++- .../Development/IDE/Core/PositionMapping.hs | 23 ++-- .../src/Development/IDE/Core/Preprocessor.hs | 6 +- .../Development/IDE/Core/ProgressReporting.hs | 38 ++++--- ghcide/src/Development/IDE/Core/RuleTypes.hs | 2 +- ghcide/src/Development/IDE/Core/Rules.hs | 18 +-- ghcide/src/Development/IDE/Core/Service.hs | 2 +- ghcide/src/Development/IDE/Core/Shake.hs | 53 +++++---- ghcide/src/Development/IDE/Core/Tracing.hs | 2 +- ghcide/src/Development/IDE/GHC/Error.hs | 14 ++- ghcide/src/Development/IDE/GHC/Warnings.hs | 2 +- .../src/Development/IDE/Import/FindImports.hs | 2 +- .../Development/IDE/LSP/HoverDefinition.hs | 40 ++++--- .../src/Development/IDE/LSP/LanguageServer.hs | 35 +++--- .../src/Development/IDE/LSP/Notifications.hs | 27 ++--- ghcide/src/Development/IDE/LSP/Outline.hs | 66 +++++------ ghcide/src/Development/IDE/LSP/Server.hs | 34 +++--- ghcide/src/Development/IDE/Main.hs | 4 +- .../src/Development/IDE/Plugin/Completions.hs | 42 +++---- .../IDE/Plugin/Completions/Logic.hs | 103 +++++++++-------- .../IDE/Plugin/Completions/Types.hs | 18 +-- ghcide/src/Development/IDE/Plugin/HLS.hs | 106 +++++++++--------- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 22 ++-- ghcide/src/Development/IDE/Plugin/Test.hs | 14 ++- .../src/Development/IDE/Plugin/TypeLenses.hs | 24 ++-- ghcide/src/Development/IDE/Spans/AtPoint.hs | 22 ++-- .../Development/IDE/Spans/Documentation.hs | 2 +- ghcide/src/Development/IDE/Spans/Pragmas.hs | 2 +- .../src/Development/IDE/Types/Diagnostics.hs | 25 ++--- ghcide/src/Development/IDE/Types/Location.hs | 4 +- ghcide/src/Development/IDE/Types/Logger.hs | 24 ++-- ghcide/src/Development/IDE/Types/Options.hs | 17 +-- .../src/Ide/TempLSPTypeFunctions.hs | 3 +- 41 files changed, 522 insertions(+), 432 deletions(-) diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 4191f6d9f2..2c55140973 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -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 3cc04199d5..401c2b4635 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -78,6 +78,7 @@ library prettyprinter >= 1.7, random, regex-tdfa >= 1.3.1.0, + row-types, text-rope, safe-exceptions, hls-graph == 2.1.0.0, diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 89855b5293..17b04ec63a 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,9 @@ 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 hiding (error) +import Language.LSP.Protocol.Types hiding (id) import Language.LSP.Server -import Language.LSP.Types import System.Directory import qualified System.Directory.Extra as IO import System.FilePath @@ -632,7 +634,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 +908,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 +1122,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..b49229065f 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -30,8 +30,10 @@ 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 (..), - SymbolInformation (..)) +import Language.LSP.Protocol.Types (DocumentHighlight (..), + Null, + SymbolInformation (..), + type (|?) (..)) -- | Eventually this will lookup/generate URIs for files in dependencies, but not in the @@ -108,7 +110,7 @@ highlightAtPoint file pos = runMaybeT $ do mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos' -- Refs are not an IDE action, so it is OK to be slow and (more) accurate -refsAtPoint :: NormalizedFilePath -> Position -> Action [Location] +refsAtPoint :: NormalizedFilePath -> Position -> Action ([Location] |? Null) refsAtPoint file pos = do ShakeExtras{withHieDb} <- getShakeExtras fs <- HM.keys <$> getFilesOfInterestUntracked diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 1f70e9653b..872dd04712 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -98,8 +98,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) @@ -132,6 +133,7 @@ import GHC (Anchor (anchor), import qualified GHC as G import GHC.Hs (LEpaComment) import qualified GHC.Types.Error as Error +import Data.Data (Proxy(Proxy)) #endif #if MIN_VERSION_ghc(9,5,0) @@ -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:" @@ -784,14 +786,14 @@ tagDiag (w@(Reason warning), (nfp, sh, 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)) + addTag :: DiagnosticTag -> Maybe ([DiagnosticTag]) -> Maybe ([DiagnosticTag]) + addTag t Nothing = Just ( [t]) + addTag t (Just ( ts)) = Just ( (t : ts)) -- other diagnostics are left unaffected tagDiag t = t @@ -918,12 +920,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 @@ -941,22 +944,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 } @@ -973,15 +979,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 @@ -1013,7 +1021,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 ] @@ -1021,7 +1029,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 ] @@ -1291,9 +1299,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..82deb02dc0 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,14 @@ 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 +163,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 +269,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 +313,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..5a1bb632ab 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 (getUri _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..e6d31819e7 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,10 @@ 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.Protocol.Types 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 +133,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 +159,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..3bf1589ede 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,12 +29,14 @@ 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) +import qualified Language.LSP.Protocol.Types as J -- | Either an exact position, or the range of text that was substituted data PositionResult a = PositionRange -- ^ Fields need to be non-strict otherwise bind is exponential @@ -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 (J.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..ff54d7fa4e 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 hiding (error) +import Language.LSP.Protocol.Types hiding (id) +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..4701a405d2 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -136,6 +136,7 @@ import Development.IDE.GHC.Compat (NameCache, import Development.IDE.GHC.Compat (upNameCache) #endif import qualified Data.Aeson.Types as A +import Data.Maybe (Maybe (Nothing)) import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake @@ -167,10 +168,14 @@ import Ide.Types (IdePlugins (IdePlugins) PluginDescriptor (pluginId), PluginId) import Language.LSP.Diagnostics +import Language.LSP.Protocol.Capabilities +import Language.LSP.Protocol.Message hiding (error) +import Language.LSP.Protocol.Types (NotebookDocumentClientCapabilities (NotebookDocumentClientCapabilities), + NotebookDocumentSyncClientCapabilities (NotebookDocumentSyncClientCapabilities), + WindowClientCapabilities (WindowClientCapabilities)) +import Language.LSP.Protocol.Types hiding (id, start) +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 +308,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 +349,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) @@ -638,8 +643,16 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer else noProgressReporting actionQueue <- newQueue - let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv - + let -- TODO: Find some saner default ClientCapabilities so we don't need to + -- use Nothing 54 times. + clientCapabilities = maybe defClientCapabilities LSP.resClientCapabilities lspEnv + defClientCapabilities = ClientCapabilities defWorkspaceCaps defTextDocumentCaps defNotebookDocumentClientCaps defWindowClientCaps defGeneralClientCaps Nothing + defWorkspaceCaps = Just $ WorkspaceClientCapabilities Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + defTextDocumentCaps = Just $ TextDocumentClientCapabilities Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + defNotebookDocumentClientCaps = Just $ NotebookDocumentClientCapabilities defNotebookDocumentSyncClientCaps + defNotebookDocumentSyncClientCaps = NotebookDocumentSyncClientCapabilities Nothing Nothing + defWindowClientCaps = Just $ WindowClientCapabilities Nothing Nothing Nothing + defGeneralClientCaps = Just $ GeneralClientCapabilities Nothing Nothing Nothing Nothing dirtyKeys <- newTVarIO mempty -- Take one VFS snapshot at the start vfsVar <- newTVarIO =<< vfsSnapshot lspEnv @@ -682,7 +695,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer getStateKeys :: ShakeExtras -> IO [Key] getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . state --- | Must be called in the 'Initialized' handler and only once +-- | Must be called in the 'Method_Initialized' handler and only once shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO () shakeSessionInit recorder ide@IdeState{..} = do -- Take a snapshot of the VFS - it should be empty as we've received no notifications @@ -900,7 +913,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 +1141,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 +1233,7 @@ traceA (A Succeeded{}) = "Success" updateFileDiagnostics :: MonadIO m => Recorder (WithPriority Log) -> NormalizedFilePath - -> TextDocumentVersion + -> Maybe Int32 -> Key -> ShakeExtras -> [(ShowDiagnostic,Diagnostic)] -- ^ current results @@ -1254,15 +1267,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 +1310,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 +1327,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 +1342,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 @@ -1343,6 +1356,4 @@ updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} Versi zeroMapping (EM.insert actual_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 + actual_version = _version 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..e9b8d9d1bc 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -16,26 +16,34 @@ 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 hiding (documentHighlight, + hover, id, references) 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 $ InL []) (InR . InL . fmap locationToDefinitionLink) +gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InL []) (InR . InL . fmap locationToDefinitionLink) +hover = request "Hover" getAtPoint (InR Null) foundHover +documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL -references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError (List Location)) +-- Again not sure this is correct, but lsp-types 2 needs DefinitionLink instead +-- of location so we convert like so +locationToDefinitionLink :: Location -> DefinitionLink +locationToDefinitionLink Location{..} = DefinitionLink $ LocationLink Nothing _uri _range _range + +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 +51,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 <$> (runAction "references" ide $ refsAtPoint filePath pos) + Nothing -> pure $ Left $ ResponseError 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..57366affa8 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 hiding (retry) import qualified Language.LSP.Server as LSP -import Language.LSP.Types import System.IO import UnliftIO.Async import UnliftIO.Concurrent @@ -43,11 +44,11 @@ import qualified Development.IDE.Session as Session import Development.IDE.Types.Logger import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Shake (WithHieDb) +import Ide.TempLSPTypeFunctions import Language.LSP.Server (LanguageContextEnv, LspServerLog, type (<~>)) import System.IO.Unsafe (unsafeInterleaveIO) - data Log = LogRegisteringIdeConfig !IdeConfiguration | LogReactorThreadException !SomeException @@ -92,7 +93,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 (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a)), LSP.Handlers (m config), (LanguageContextEnv config, a) -> m config <~> IO)) -> IO () @@ -133,7 +134,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 +196,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 +234,11 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa case cancelOrRes of Left () -> do log Debug $ LogCancelledRequest _id - k $ ResponseError RequestCancelled "" Nothing + k $ ResponseError (ErrorCodes_Custom (-32800)) "" Nothing Right res -> pure res ) $ \(e :: SomeException) -> do exceptionInHandler e - k $ ResponseError InternalError (T.pack $ show e) Nothing + k $ ResponseError 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 +264,27 @@ 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)) 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..e57b330fb1 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,15 +119,15 @@ 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 - --------- Initialize Shake session -------------------------------------------------------------------- + , mkPluginNotificationHandler LSP.SMethod_Initialized $ \ide _ _ _ -> do + --------- Method_Initialize Shake session -------------------------------------------------------------------- liftIO $ shakeSessionInit (cmapWithPrio LogShake recorder) ide --------- Set up file watchers ------------------------------------------------------------------------ diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index 7afcb5bfdd..7c44a73e80 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 (SymbolKind_Variable, SymbolKind_Field, SymbolKind_File, SymbolKind_Function, SymbolKind_Interface, SymbolKind_Method, SymbolKind_Module, SymbolKind_Object, SymbolKind_Struct, SymbolKind_TypeParameter), 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_Variable , _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 @@ -148,7 +148,7 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLNam conArgRecordFields (RecCon (L _ lcdfs)) = Just $ List [ (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..61b35102f9 100644 --- a/ghcide/src/Development/IDE/LSP/Server.hs +++ b/ghcide/src/Development/IDE/LSP/Server.hs @@ -7,6 +7,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} +--{-# LANGUAGE ExistentialQuantification #-} module Development.IDE.LSP.Server ( ReactorMessage(..) , ReactorChan @@ -14,46 +15,53 @@ module Development.IDE.LSP.Server , requestHandler , notificationHandler ) where - -import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Arrow (left) +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.Protocol.Types hiding (id) +import Language.LSP.Server (Handlers, LspM) +import qualified Language.LSP.Server as LSP import Language.LSP.VFS import UnliftIO.Chan - +--import Ide.TempLSPTypeFunctions +--import Data.Aeson (FromJSON) data ReactorMessage = ReactorNotification (IO ()) | ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ()) +-- | forall {f :: MessageDirection} (m :: Method f 'Request). ReactorRequest SomeLspId (IO ()) (TResponseError m -> IO ()) type ReactorChan = Chan ReactorMessage newtype ServerM c a = ServerM { unServerM :: ReaderT (ReactorChan, IdeState) (LspM c) a } 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), FromJSON( ErrorData 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 (TResponseError m) (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) +-- writeChan chan $ ReactorRequest (SomeLspId _id) (trace $ LSP.runLspT env $ (resp' . convertToTyped) =<< k ide _params) (LSP.runLspT env . (resp' . convertToTyped) . Left) +-- where convertToTyped = left toTypedResponseError 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..1b79d87b9c 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 Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Types as J 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,9 +151,9 @@ 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 + 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 & J.detail .~ (det1 <> _detail) & J.documentation .~ Just doc1 ) @@ -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..56cf7fce5a 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} - +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedLabels #-} -- Mostly taken from "haskell-ide-engine" module Development.IDE.Plugin.Completions.Logic ( @@ -14,15 +14,18 @@ module Development.IDE.Plugin.Completions.Logic ( ) where import Control.Applicative +import Control.Lens hiding (Context) import Data.Char (isAlphaNum, isUpper) 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 +44,6 @@ 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.Error import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types @@ -64,8 +66,10 @@ import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), IdePlugins (..), PluginId) -import Language.LSP.Types -import Language.LSP.Types.Capabilities +import Language.LSP.Protocol.Capabilities +import Language.LSP.Protocol.Types hiding (id, + insertText, label, + name) import qualified Language.LSP.VFS as VFS import Text.Fuzzy.Parallel (Scored (score), original) @@ -76,7 +80,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 @@ -140,11 +144,13 @@ getCContext pos pm goInline _ = Nothing importGo :: GHC.LImportDecl GhcPs -> Maybe Context +#if MIN_VERSION_ghc(9,5,0) importGo (L (locA -> r) impDecl) | pos `isInsideSrcSpan` r -#if MIN_VERSION_ghc(9,5,0) = importInline importModuleName (fmap (fmap reLoc) $ ideclImportList impDecl) #else + importGo (L (locA -> r) impDecl) + | pos `isInsideSrcSpan` r = importInline importModuleName (fmap (fmap reLoc) $ ideclHiding impDecl) #endif <|> Just (ImportContext importModuleName) @@ -155,28 +161,33 @@ getCContext pos pm -- importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context #if MIN_VERSION_ghc(9,5,0) importInline modName (Just (EverythingBut, L r _)) + | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName + | otherwise = Nothing #else importInline modName (Just (True, L r _)) -#endif | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName | otherwise = Nothing +#endif + #if MIN_VERSION_ghc(9,5,0) importInline modName (Just (Exactly, L r _)) + | pos `isInsideSrcSpan` r = Just $ ImportListContext modName + | otherwise = Nothing #else importInline modName (Just (False, L r _)) -#endif | pos `isInsideSrcSpan` r = Just $ ImportListContext modName | otherwise = Nothing +#endif importInline _ _ = Nothing 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 +226,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 +243,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 +266,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,29 +291,29 @@ showForSnippet x = printOutputable x mkModCompl :: T.Text -> CompletionItem mkModCompl label = - CompletionItem label (Just CiModule) Nothing Nothing + CompletionItem label Nothing (Just CompletionItemKind_Module) Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing mkModuleFunctionImport :: T.Text -> T.Text -> CompletionItem mkModuleFunctionImport moduleName label = - CompletionItem label (Just CiFunction) Nothing (Just moduleName) + CompletionItem label Nothing (Just CompletionItemKind_Function) Nothing (Just moduleName) + Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing mkImportCompl :: T.Text -> T.Text -> CompletionItem mkImportCompl enteredQual label = - CompletionItem m (Just CiModule) Nothing (Just label) + CompletionItem m Nothing (Just CompletionItemKind_Module) Nothing (Just label) + Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing where m = fromMaybe "" (T.stripPrefix enteredQual label) mkExtCompl :: T.Text -> CompletionItem mkExtCompl label = - CompletionItem label (Just CiKeyword) Nothing Nothing + CompletionItem label Nothing (Just CompletionItemKind_Keyword) Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem @@ -439,20 +452,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 +477,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 +533,7 @@ toggleSnippets ClientCapabilities {_textDocument} CompletionsConfig{..} = removeSnippetsWhen (not $ enableSnippets && supported) where supported = - Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport) + Just True == (_textDocument >>= _completion >>= view completionItem >>= (\x -> x .! #snippetSupport)) toggleAutoExtend :: CompletionsConfig -> CompItem -> CompItem toggleAutoExtend CompletionsConfig{enableAutoExtend=False} x = x {additionalTextEdits = Nothing} @@ -531,7 +544,7 @@ removeSnippetsWhen condition x = if condition then x - { _insertTextFormat = Just PlainText, + { _insertTextFormat = Just InsertTextFormat_PlainText, _insertText = Nothing } else x @@ -613,7 +626,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 +803,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..a37b309e0a 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 @@ -88,7 +88,7 @@ data Provenance data CompItem = CI { compKind :: CompletionItemKind - , insertText :: T.Text -- ^ Snippet for the completion + , insertText :: T.Text -- ^ InsertTextFormat_Snippet for the completion , provenance :: Provenance -- ^ From where this item is imported from. , label :: T.Text -- ^ Label to display to the user. , typeText :: Maybe T.Text @@ -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..f7f9250450 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -9,43 +9,44 @@ 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 Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (id) +import qualified Language.LSP.Protocol.Types as J +import qualified Language.LSP.Protocol.Types as LSP +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) -- --------------------------------------------------------------------- -- @@ -86,14 +87,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 -> 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 +147,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 +158,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 |? LSP.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) -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs) - Nothing -> return $ Right J.Null + Nothing -> return $ Right $ InR Null - J.Error _str -> return $ Right J.Null + A.Error _str -> return $ Right $ InR Null -- Just an ordinary HIE command Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams @@ -187,16 +188,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 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 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 ErrorCodes_InvalidRequest (commandDoesntExist com p xs) + Just (PluginCommand _ _ f) -> case A.fromJSON arg of + A.Error err -> logAndReturnError recorder p ErrorCodes_InvalidParams (failedToParseArgs com p err arg) + A.Success a -> fmap InL <$> f ide a -- --------------------------------------------------------------------- @@ -220,7 +222,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 ErrorCodes_InvalidRequest msg Nothing msg = pluginNotEnabled m fs' return $ Left err Just fs -> do @@ -275,20 +277,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 ErrorCodes_InternalError (msg e pid) Nothing) combineErrors :: [ResponseError] -> ResponseError combineErrors [x] = x -combineErrors xs = ResponseError InternalError (T.pack (show xs)) Nothing +combineErrors xs = ResponseError 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..ae85621b81 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -15,8 +15,10 @@ 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 hiding (documentHighlight, + hover, references) import Language.LSP.Server (LspM) -import Language.LSP.Types import Text.Regex.TDFA.Text () data Log @@ -43,29 +45,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..7407d8d440 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, retry) 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 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 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..cddc98befc 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -27,7 +27,7 @@ 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 (documentHighlight) -- compiler and infrastructure import Development.IDE.Core.PositionMapping @@ -115,7 +115,7 @@ referencesAtPoint -> NormalizedFilePath -- ^ The file the cursor is in -> Position -- ^ position in the file -> FOIReferences -- ^ references data for FOIs - -> m [Location] + -> m ([Location] |? Null) referencesAtPoint withHieDb nfp pos refs = do -- The database doesn't have up2date references data for the FOIs so we must collect those -- from the Shake graph. @@ -134,7 +134,7 @@ referencesAtPoint withHieDb nfp pos refs = do refs <- liftIO $ withHieDb (\hieDb -> findTypeRefs hieDb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude) pure $ mapMaybe typeRowToLoc refs _ -> pure [] - pure $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs + pure $ InL $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs rowToLoc :: Res RefRow -> Maybe Location rowToLoc (row:.info) = flip Location range <$> mfile @@ -178,8 +178,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 +391,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_Variable + | 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 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 1420995be7..229cefd47b 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, @@ -24,10 +23,8 @@ import Data.Text.Prettyprint.Doc.Render.Terminal (Color (..), color) import qualified Data.Text.Prettyprint.Doc.Render.Terminal as Terminal import Data.Text.Prettyprint.Doc.Render.Text import Language.LSP.Diagnostics -import Language.LSP.Types as LSP (Diagnostic (..), - DiagnosticSeverity (..), - DiagnosticSource, - List (..)) +import Language.LSP.Protocol.Types as LSP (Diagnostic (..), + DiagnosticSeverity (..)) import Data.ByteString (ByteString) import Development.IDE.Types.Location @@ -49,10 +46,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 +61,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 +116,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 416049a5ab..2ce5f765c1 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -55,12 +55,11 @@ import GHC.Stack (CallStack, HasCallStack, SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine), callStack, getCallStack, withFrozenCallStack) -import Language.LSP.Server -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (LogMessageParams (..), +import Language.LSP.Protocol.Types (LogMessageParams (..), MessageType (..), - SMethod (SWindowLogMessage, SWindowShowMessage), ShowMessageParams (..)) +import Language.LSP.Server +import qualified Language.LSP.Server as LSP #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter as PrettyPrinterModule import Prettyprinter.Render.Text (renderStrict) @@ -72,6 +71,7 @@ import Colog.Core (LogAction (..), Severity, WithSeverity (..)) import qualified Colog.Core as Colog +import Language.LSP.Protocol.Message (SMethod (SMethod_WindowLogMessage, SMethod_WindowShowMessage)) import System.IO (Handle, IOMode (AppendMode), hClose, hFlush, @@ -300,28 +300,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..0b56e03abb 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,17 +19,17 @@ module Development.IDE.Types.Options , OptHaddockParse(..) , ProgressReportingStyle(..) ) where - -import qualified Data.Text as T +import Control.Lens +import qualified Data.Text as T import Data.Typeable import Development.IDE.Core.RuleTypes -import Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Compat as GHC 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 Ide.Types (DynFlagsModifications) +import qualified Language.LSP.Protocol.Capabilities as LSP +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 ^. LSP.workDoneProgress) =<< LSP._window (caps :: LSP.ClientCapabilities)) defaultIdeOptions :: Action IdeGhcSession -> IdeOptions defaultIdeOptions session = IdeOptions diff --git a/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs b/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs index b50a33a61c..c7b16c824f 100644 --- a/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs +++ b/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs @@ -4,8 +4,7 @@ {-# LANGUAGE PolyKinds #-} module Ide.TempLSPTypeFunctions (takeLefts, dumpNulls, nullToMaybe', NullToMaybe, toLspId, toTypedResponseError) where -import Data.Aeson (FromJSON (parseJSON), ToJSON, - decode, encode, fromJSON) +import Data.Aeson (FromJSON, decode, encode) import Data.Aeson.Types (parseMaybe) import Data.Semigroup () import Data.Text (Text) From 082f1e6a17dde716ea343a4fc4fb4cdb0c00915b Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 3 Jun 2023 14:39:10 +0300 Subject: [PATCH 07/70] ghcide compiles, but 40/351 tests fail Now tracking my fork of the new lsp release which dumps TResponseError --- cabal.project | 12 +- ghcide/exe/Main.hs | 2 +- ghcide/ghcide.cabal | 1 + .../src/Development/IDE/LSP/LanguageServer.hs | 2 +- ghcide/src/Development/IDE/LSP/Server.hs | 23 +- .../IDE/Plugin/Completions/Logic.hs | 1 + ghcide/test/exe/Main.hs | 596 +++++++++--------- ghcide/test/ghcide-test-utils.cabal | 1 + ghcide/test/src/Development/IDE/Test.hs | 47 +- .../src/Development/IDE/Test/Diagnostic.hs | 17 +- hls-plugin-api/hls-plugin-api.cabal | 1 + 11 files changed, 339 insertions(+), 364 deletions(-) diff --git a/cabal.project b/cabal.project index a20c323b0e..69433e35cf 100644 --- a/cabal.project +++ b/cabal.project @@ -94,18 +94,18 @@ source-repository-package -- This is needed till lsp makes a release source-repository-package type:git - location: https://github.com/haskell/lsp - tag: ba7e5cbfaf4ab075a8fc290d61e8c9a96a41fd94 + location: https://github.com/joyfulmantis/lsp + tag: 98d34d93d8bd93ec603b77f5e5085ba09c74b9c1 subdir: lsp source-repository-package type:git - location: https://github.com/haskell/lsp - tag: ba7e5cbfaf4ab075a8fc290d61e8c9a96a41fd94 + location: https://github.com/joyfulmantis/lsp + tag: 98d34d93d8bd93ec603b77f5e5085ba09c74b9c1 subdir: lsp-types source-repository-package type:git - location: https://github.com/haskell/lsp - tag: ba7e5cbfaf4ab075a8fc290d61e8c9a96a41fd94 + location: https://github.com/joyfulmantis/lsp + tag: 98d34d93d8bd93ec603b77f5e5085ba09c74b9c1 subdir: lsp-test diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index 2c55140973..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) diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 401c2b4635..c35433d3c9 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -364,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/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 57366affa8..d6aebc27a1 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -93,7 +93,7 @@ runLanguageServer -> config -> (config -> Value -> Either T.Text config) -> (MVar () - -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (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 () diff --git a/ghcide/src/Development/IDE/LSP/Server.hs b/ghcide/src/Development/IDE/LSP/Server.hs index 61b35102f9..6875fac4b8 100644 --- a/ghcide/src/Development/IDE/LSP/Server.hs +++ b/ghcide/src/Development/IDE/LSP/Server.hs @@ -1,13 +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 #-} ---{-# LANGUAGE ExistentialQuantification #-} module Development.IDE.LSP.Server ( ReactorMessage(..) , ReactorChan @@ -15,46 +10,40 @@ module Development.IDE.LSP.Server , requestHandler , notificationHandler ) where -import Control.Arrow (left) 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.Protocol.Message -import Language.LSP.Protocol.Types hiding (id) import Language.LSP.Server (Handlers, LspM) import qualified Language.LSP.Server as LSP import Language.LSP.VFS import UnliftIO.Chan ---import Ide.TempLSPTypeFunctions ---import Data.Aeson (FromJSON) + data ReactorMessage = ReactorNotification (IO ()) | ReactorRequest SomeLspId (IO ()) (ResponseError -> IO ()) --- | forall {f :: MessageDirection} (m :: Method f 'Request). ReactorRequest SomeLspId (IO ()) (TResponseError m -> IO ()) type ReactorChan = Chan ReactorMessage newtype ServerM c a = ServerM { unServerM :: ReaderT (ReactorChan, IdeState) (LspM c) a } deriving (Functor, Applicative, Monad, MonadReader (ReactorChan, IdeState), MonadIO, MonadUnliftIO, LSP.MonadLsp c) requestHandler - :: forall (m :: Method ClientToServer Request) c. (HasTracing (MessageParams m), FromJSON( ErrorData m)) => --- :: forall (m :: Method ClientToServer Request) c. (HasTracing (MessageParams m)) => + :: forall (m :: Method ClientToServer Request) c. (HasTracing (MessageParams m)) => SMethod m -> (IdeState -> MessageParams m -> LspM c (Either ResponseError (MessageResult m))) -> Handlers (ServerM c) requestHandler m k = LSP.requestHandler m $ \TRequestMessage{_method,_id,_params} resp -> do st@(chan,ide) <- ask env <- LSP.getLspEnv - let resp' :: Either (TResponseError m) (MessageResult m) -> LspM c () + 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) --- writeChan chan $ ReactorRequest (SomeLspId _id) (trace $ LSP.runLspT env $ (resp' . convertToTyped) =<< k ide _params) (LSP.runLspT env . (resp' . convertToTyped) . Left) --- where convertToTyped = left toTypedResponseError + notificationHandler :: forall (m :: Method ClientToServer Notification) c. (HasTracing (MessageParams m)) => diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 56cf7fce5a..62c97bf37d 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -44,6 +44,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.Error import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index c690c0b9bd..36c044cbf0 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -36,10 +36,12 @@ {-# 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, @@ -52,6 +54,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 +93,17 @@ import Development.IDE.Types.Location import Development.Shake (getDirectoryFilesIO) import Ide.Plugin.Config 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.Types.Capabilities -import qualified Language.LSP.Types.Lens as Lens (label) -import qualified Language.LSP.Types.Lens as Lsp (diagnostics, - message, - params) + mkRange, message, diagnostic, executeCommand, applyEdit, id) +import qualified Language.LSP.Protocol.Types as L hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start)) +import Language.LSP.Protocol.Message hiding (error) +import Language.LSP.Protocol.Capabilities import Language.LSP.VFS (VfsLog, applyChange) import Network.URI import System.Directory @@ -145,10 +149,7 @@ import GHC.Stack (emptyCallStack) 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 Ide.TempLSPTypeFunctions import qualified Progress import System.Time.Extra import qualified Test.QuickCheck.Monadic as MonadicQuickCheck @@ -175,14 +176,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 _ _)) -> 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 _ _)) -> Just () _ -> Nothing -- | Wait for all progress to be done @@ -193,7 +194,7 @@ waitForAllProgressDone = loop where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ _)) -> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop @@ -216,7 +217,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 +260,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) @@ -284,16 +285,16 @@ initializeResponseTests = withResource acquire release tests where _documentOnTypeFormattingProvider Nothing , chk "NO renaming" _renameProvider (Just $ InL False) , chk "NO doc link" _documentLinkProvider Nothing - , chk "NO color" (^. L.colorProvider) (Just $ InL False) + , chk "NO color" (^. 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 "NO experimental" (^. L.experimental) Nothing + , chk " workspace" (^. workspace) (Just $ #workspaceFolders .== Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )} .+ #fileOperations .== Nothing) + , chk "NO experimental" (^. 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 +308,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 +328,25 @@ 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 +358,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 +372,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 +384,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 +400,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 +420,16 @@ 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 +444,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 +461,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 +485,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 +506,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 +532,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 +544,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 +558,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 +580,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 +611,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 +639,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 +661,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 +676,10 @@ diagnosticTests = testGroup "diagnostics" notification <- skipManyTill anyMessage diagnostic let offenders = - Lsp.params . - Lsp.diagnostics . + params . + 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 +693,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 +707,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 +723,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 +750,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 +767,8 @@ 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 +808,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 +846,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 +856,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 +877,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 +909,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 +968,15 @@ 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)) = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange) (toLocationLink <$> defLink) + where toLocationLink (DefinitionLink ll) = ll +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 +1027,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 +1052,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 +1075,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 +1101,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 +1254,7 @@ pluginSimpleTests = expectDiagnostics [ ( "KnownNat.hs", - [(DsError, (9, 15), "Variable not in scope: c")] + [(DiagnosticSeverity_Error, (9, 15), "Variable not in scope: c")] ) ] @@ -1306,7 +1295,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 +1303,7 @@ cppTests = _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs", - [(DsError, cursor, "error: unterminated")] + [(DiagnosticSeverity_Error, cursor, "error: unterminated")] ) ] expectNoMoreDiagnostics 0.5 @@ -1330,7 +1319,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 +1380,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 +1428,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 +1439,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 +1450,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 +1483,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 +1518,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 +1551,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,8 +1565,8 @@ completionTest name src pos expected = testSessionWait name $ do CompletionItem{..} <- if expectedSig || expectedDocs then do - rsp <- request SCompletionItemResolve item - case rsp ^. L.result of + rsp <- request SMethod_CompletionItemResolve item + case rsp ^. result of Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) Right x -> pure x else pure item @@ -1593,41 +1582,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 +1625,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 +1635,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 +1645,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 +1657,7 @@ localCompletionTests = [ ," pure ()" ] (Position 2 6) - [("abcdef", CiFunction, "abcdef", True, False, Nothing) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) ], completionTest "do/2" @@ -1682,12 +1671,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 +1685,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 +1697,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 +1722,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 +1763,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 +1784,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 +1796,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 +1844,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 +1864,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 +1889,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 +1933,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 +1952,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,8 +2073,8 @@ completionDocTests = _ <- waitForDiagnostics compls <- getCompletions doc pos rcompls <- forM compls $ \item -> do - rsp <- request SCompletionItemResolve item - case rsp ^. L.result of + rsp <- request SMethod_CompletionItemResolve item + case rsp ^. result of Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) Right x -> pure x let compls' = [ @@ -2097,7 +2082,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 +2093,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 +2163,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 +2193,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 +2210,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_Variable (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_Variable (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 +2269,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 +2295,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 +2303,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 +2313,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 +2517,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 +2540,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 +2573,25 @@ 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 m@(SMethod_CustomMethod _) (NotMess _) -> someMethodToMethodString (SomeMethod m) == cradleLoadedMethod _ -> False -cradleLoadedMethod :: T.Text +cradleLoadedMethod :: String cradleLoadedMethod = "ghcide/cradle/loaded" ignoreFatalWarning :: TestTree @@ -2627,7 +2608,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 +2702,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 +2737,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 +2754,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 +2773,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 +2785,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 +2801,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 +2816,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 +2834,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 +2842,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 +2860,18 @@ 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 +2919,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 +2931,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 +2947,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 +2958,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 +3082,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 +3111,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 +3122,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 @@ -3284,7 +3261,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 +3283,7 @@ unitTests recorder logger = do let plugins = pluginDescToIdePlugins $ [ (priorityPluginDescriptor i) { pluginNotificationHandlers = mconcat - [ mkPluginNotificationHandler LSP.STextDocumentDidOpen $ \_ _ _ _ -> + [ mkPluginNotificationHandler SMethod_TextDocumentDidOpen $ \_ _ _ _ -> liftIO $ atomicModifyIORef_ orderRef (i:) ] } @@ -3381,10 +3360,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 +3526,7 @@ 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 +3580,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 8d7bbf73d9..b6a876928e 100644 --- a/ghcide/test/ghcide-test-utils.cabal +++ b/ghcide/test/ghcide-test-utils.cabal @@ -38,6 +38,7 @@ library 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..72ee8d4d37 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -43,6 +43,7 @@ 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 (..), @@ -50,13 +51,14 @@ import Development.IDE.Plugin.Test (TestRequest (..), ideResultSuccess) import Development.IDE.Test.Diagnostic import Ide.Plugin.Config (CheckParents, checkProject) -import Language.LSP.Test hiding (message) -import qualified Language.LSP.Test as LspTest -import Language.LSP.Types hiding +import Language.LSP.Protocol.Message hiding (error) +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (length, line), SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import Language.LSP.Types.Lens as Lsp + SemanticTokensEdit (_start), + diagnostic) +import Language.LSP.Test hiding (message) +import qualified Language.LSP.Test as LspTest import System.Directory (canonicalizePath) import System.FilePath (equalFilePath) import System.Time.Extra @@ -75,23 +77,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 + expectMessages SMethod_TextDocumentPublishDiagnostics timeout $ \diagsNot -> do let fileUri = diagsNot ^. params . uri actual = diagsNot ^. params . diagnostics - unless (actual == List []) $ liftIO $ + 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 +104,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,7 +120,7 @@ expectDiagnostics = expectDiagnosticsWithTags . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) -unwrapDiagnostic :: NotificationMessage TextDocumentPublishDiagnostics -> (Uri, List Diagnostic) +unwrapDiagnostic :: TServerMessage Method_TextDocumentPublishDiagnostics -> (Uri, [Diagnostic]) unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics) expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () @@ -130,13 +132,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 +180,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 +232,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 cm@(SMethod_CustomMethod _) (NotMess TNotificationMessage{_params = value}) + | someMethodToMethodString (SomeMethod cm) == T.unpack msg -> pred value _ -> Nothing waitForGC :: Session [T.Text] @@ -242,7 +244,7 @@ waitForGC = waitForCustomMessage "ghcide/GC" $ \v -> configureCheckProject :: Bool -> Session () configureCheckProject overrideCheckProject = - sendNotification SWorkspaceDidChangeConfiguration + sendNotification SMethod_WorkspaceDidChangeConfiguration (DidChangeConfigurationParams $ toJSON def{checkProject = overrideCheckProject}) @@ -252,9 +254,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 cm@(SMethod_CustomMethod _) (NotMess TNotificationMessage{_params}) | A.Success fp <- A.fromJSON _params , pred fp + , someMethodToMethodString (SomeMethod cm) == "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..d2f3b8362b 100644 --- a/ghcide/test/src/Development/IDE/Test/Diagnostic.hs +++ b/ghcide/test/src/Development/IDE/Test/Diagnostic.hs @@ -1,10 +1,9 @@ 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.Types -- | (0-based line number, 0-based column number) type Cursor = (UInt, UInt) @@ -33,10 +32,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/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 2762f335ff..ad3216027c 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -38,6 +38,7 @@ library Ide.Plugin.ConfigUtils Ide.Plugin.Properties Ide.Plugin.RangeMap + Ide.TempLSPTypeFunctions Ide.PluginUtils Ide.Types From 33798d9de7d42b48099093730af9304c0b5d5638 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 5 Jun 2023 17:54:13 +0300 Subject: [PATCH 08/70] ghcide: Fix some inaccuracies --- .../Development/IDE/Core/IdeConfiguration.hs | 2 +- ghcide/src/Development/IDE/Core/Shake.hs | 13 +--- .../Development/IDE/LSP/HoverDefinition.hs | 9 +-- ghcide/src/Development/IDE/Plugin/HLS.hs | 4 +- .../src/Ide/TempLSPTypeFunctions.hs | 70 ++++++++++++++++--- 5 files changed, 66 insertions(+), 32 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/IdeConfiguration.hs b/ghcide/src/Development/IDE/Core/IdeConfiguration.hs index 5a1bb632ab..c59fb2fc9d 100644 --- a/ghcide/src/Development/IDE/Core/IdeConfiguration.hs +++ b/ghcide/src/Development/IDE/Core/IdeConfiguration.hs @@ -58,7 +58,7 @@ parseConfiguration InitializeParams {..} = parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri parseWorkspaceFolder WorkspaceFolder{_uri} = - toNormalizedUri (Uri (getUri _uri)) + toNormalizedUri _uri modifyWorkspaceFolders :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO () diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 4701a405d2..60ccf24a47 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -136,7 +136,6 @@ import Development.IDE.GHC.Compat (NameCache, import Development.IDE.GHC.Compat (upNameCache) #endif import qualified Data.Aeson.Types as A -import Data.Maybe (Maybe (Nothing)) import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake @@ -164,15 +163,12 @@ import GHC.Stack (HasCallStack) import HieDb.Types import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS +import Ide.TempLSPTypeFunctions import Ide.Types (IdePlugins (IdePlugins), PluginDescriptor (pluginId), PluginId) import Language.LSP.Diagnostics -import Language.LSP.Protocol.Capabilities import Language.LSP.Protocol.Message hiding (error) -import Language.LSP.Protocol.Types (NotebookDocumentClientCapabilities (NotebookDocumentClientCapabilities), - NotebookDocumentSyncClientCapabilities (NotebookDocumentSyncClientCapabilities), - WindowClientCapabilities (WindowClientCapabilities)) import Language.LSP.Protocol.Types hiding (id, start) import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP @@ -646,13 +642,6 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer let -- TODO: Find some saner default ClientCapabilities so we don't need to -- use Nothing 54 times. clientCapabilities = maybe defClientCapabilities LSP.resClientCapabilities lspEnv - defClientCapabilities = ClientCapabilities defWorkspaceCaps defTextDocumentCaps defNotebookDocumentClientCaps defWindowClientCaps defGeneralClientCaps Nothing - defWorkspaceCaps = Just $ WorkspaceClientCapabilities Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - defTextDocumentCaps = Just $ TextDocumentClientCapabilities Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing - defNotebookDocumentClientCaps = Just $ NotebookDocumentClientCapabilities defNotebookDocumentSyncClientCaps - defNotebookDocumentSyncClientCaps = NotebookDocumentSyncClientCapabilities Nothing Nothing - defWindowClientCaps = Just $ WindowClientCapabilities Nothing Nothing Nothing - defGeneralClientCaps = Just $ GeneralClientCapabilities Nothing Nothing Nothing Nothing dirtyKeys <- newTVarIO mempty -- Take one VFS snapshot at the start vfsVar <- newTVarIO =<< vfsSnapshot lspEnv diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index e9b8d9d1bc..bceb9eb20a 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -33,16 +33,11 @@ gotoDefinition :: IdeState -> TextDocumentPositionParams -> LSP.LspM c (Either R 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 $ InL []) (InR . InL . fmap locationToDefinitionLink) -gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InL []) (InR . InL . fmap locationToDefinitionLink) +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 --- Again not sure this is correct, but lsp-types 2 needs DefinitionLink instead --- of location so we convert like so -locationToDefinitionLink :: Location -> DefinitionLink -locationToDefinitionLink Location{..} = DefinitionLink $ LocationLink Nothing _uri _range _range - references :: IdeState -> ReferenceParams -> LSP.LspM c (Either ResponseError ([Location] |? Null)) references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO $ case uriToFilePath' uri of diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index f7f9250450..1607f7a559 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -178,9 +178,9 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom -- If we have a command, continue to execute it Just (J.Command _ innerCmdId innerArgs) -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs) - Nothing -> return $ Right $ InR Null + Nothing -> return $ Right $ InL $ A.Null - A.Error _str -> return $ Right $ InR Null + A.Error _str -> return $ Right $ InL $ A.Null -- Just an ordinary HIE command Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams diff --git a/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs b/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs index c7b16c824f..ea81de6faf 100644 --- a/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs +++ b/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs @@ -3,16 +3,26 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} module Ide.TempLSPTypeFunctions (takeLefts, dumpNulls, nullToMaybe', NullToMaybe, - toLspId, toTypedResponseError) where -import Data.Aeson (FromJSON, decode, encode) -import Data.Aeson.Types (parseMaybe) + toLspId, defClientCapabilities, + defGeneralClientCapabilities, + defNotebookDocumentClientCapabilities, + defNotebookDocumentSyncClientCapabilities, + defTextDocumentCapabilities, + defWindowClientCapabilities, + defWorkspaceCapabilities, nullToEmpty) where + import Data.Semigroup () import Data.Text (Text) -import Language.LSP.Protocol.Message (ErrorData, - LspId (IdInt, IdString), - ResponseError (ResponseError), - TResponseError (TResponseError)) -import Language.LSP.Protocol.Types (Int32, Null, +import Language.LSP.Protocol.Message (LspId (IdInt, IdString)) +import Language.LSP.Protocol.Types (ClientCapabilities (ClientCapabilities), + GeneralClientCapabilities (GeneralClientCapabilities), + Int32, + NotebookDocumentClientCapabilities (NotebookDocumentClientCapabilities), + NotebookDocumentSyncClientCapabilities (NotebookDocumentSyncClientCapabilities), + Null (Null), + TextDocumentClientCapabilities (TextDocumentClientCapabilities), + WindowClientCapabilities (WindowClientCapabilities), + WorkspaceClientCapabilities (WorkspaceClientCapabilities), WorkspaceEdit (WorkspaceEdit), type (|?) (..)) @@ -33,6 +43,9 @@ dumpNulls = foldr (\x acc -> case nullToMaybe' x of Just x' -> x' : acc Nothing -> acc) [] +nullToEmpty :: Monoid m => (m |? Null) -> m +nullToEmpty (InR Null) = mempty +nullToEmpty (InL ls) = ls instance Semigroup s => Semigroup (s |? Null) where InL x <> InL y = InL (x <> y) InL x <> InR _ = InL x @@ -64,5 +77,42 @@ toLspId :: (Int32 |? Text) -> LspId a toLspId (InL x) = IdInt x toLspId (InR y) = IdString y -toTypedResponseError :: FromJSON (ErrorData m) => ResponseError -> TResponseError m -toTypedResponseError (ResponseError c m d) = TResponseError c m (decode . encode=<< d) +-- TODO: Find some saner default ClientCapabilities so we don't need to +-- use Nothing 54 times. +defClientCapabilities :: ClientCapabilities +defClientCapabilities = + ClientCapabilities (Just defWorkspaceCapabilities) + (Just defTextDocumentCapabilities) + (Just defNotebookDocumentClientCapabilities) + (Just defWindowClientCapabilities) + (Just defGeneralClientCapabilities) + Nothing + +defWorkspaceCapabilities :: WorkspaceClientCapabilities +defWorkspaceCapabilities = + WorkspaceClientCapabilities Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing + +defTextDocumentCapabilities :: TextDocumentClientCapabilities +defTextDocumentCapabilities = + TextDocumentClientCapabilities Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing Nothing Nothing + +defNotebookDocumentClientCapabilities :: NotebookDocumentClientCapabilities +defNotebookDocumentClientCapabilities = + NotebookDocumentClientCapabilities defNotebookDocumentSyncClientCapabilities + +defNotebookDocumentSyncClientCapabilities :: NotebookDocumentSyncClientCapabilities +defNotebookDocumentSyncClientCapabilities = + NotebookDocumentSyncClientCapabilities Nothing Nothing + +defWindowClientCapabilities :: WindowClientCapabilities +defWindowClientCapabilities = WindowClientCapabilities Nothing Nothing Nothing + +defGeneralClientCapabilities :: GeneralClientCapabilities +defGeneralClientCapabilities = GeneralClientCapabilities Nothing Nothing Nothing Nothing From 74a6e34eb637dfbc1bdf472b2eb9ea809442f849 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 5 Jun 2023 17:54:44 +0300 Subject: [PATCH 09/70] ghcide-bench compiles --- ghcide-bench/ghcide-bench.cabal | 1 + ghcide-bench/src/Experiments.hs | 124 ++++++++++++++++---------------- 2 files changed, 64 insertions(+), 61 deletions(-) diff --git a/ghcide-bench/ghcide-bench.cabal b/ghcide-bench/ghcide-bench.cabal index 1d6944aa21..d4e89061f8 100644 --- a/ghcide-bench/ghcide-bench.cabal +++ b/ghcide-bench/ghcide-bench.cabal @@ -89,6 +89,7 @@ library safe-exceptions, shake, text, + row-types default-extensions: BangPatterns DeriveFunctor diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index b6ab82226d..21a4c34c21 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,56 @@ 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 (isn't, (^.)) +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 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 Language.LSP.Protocol.Message hiding (error) +import Language.LSP.Protocol.Types hiding (Null, + SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start), + matches, value, verbose) 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 +116,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 +188,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 +204,15 @@ 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 +232,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 _ = False --------------------------------------------------------------------------------------------- examplesPath :: FilePath @@ -481,7 +487,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 +497,7 @@ waitForProgressDone = loop where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ isn't _workDoneProgressEnd v -> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop @@ -499,13 +505,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,32 +642,28 @@ 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 - stringLiteralP = Position lastLine 15 + stringLiteralP = (Position lastLine 15) -- 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 ^. start findEndOfImports _ = Nothing -------------------------------------------------------------------------------------------- @@ -678,11 +680,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 . BS.fromStrict <$> BS.readFile cachedPath case cachedRes of Left _ -> do result <- loop pos - liftIO $ writeFile cachedPath $ show result + liftIO $ BS.writeFile cachedPath $ BS.toStrict $ A.encode result return result Right res -> return res @@ -708,8 +710,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 +738,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 From ea10046b9bb2ac016fe5f41ffc791fa0cfca7412 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 5 Jun 2023 17:56:33 +0300 Subject: [PATCH 10/70] hls-test-utils compile --- hls-test-utils/hls-test-utils.cabal | 2 +- hls-test-utils/src/Test/Hls.hs | 123 +++++++++++++++------------- hls-test-utils/src/Test/Hls/Util.hs | 44 +++++----- 3 files changed, 92 insertions(+), 77 deletions(-) diff --git a/hls-test-utils/hls-test-utils.cabal b/hls-test-utils/hls-test-utils.cabal index 35bfcaeeb6..e06122aa45 100644 --- a/hls-test-utils/hls-test-utils.cabal +++ b/hls-test-utils/hls-test-utils.cabal @@ -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..aa356bafb1 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -1,15 +1,18 @@ +{-# 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.Test, module Control.Monad.IO.Class, module Control.Applicative.Combinators, @@ -53,62 +56,68 @@ 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 (isn't) +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 hiding (error) +import Language.LSP.Protocol.Types hiding (Null, + SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start), + applyEdit, executeCommand, + message, rename) 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 +424,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)) | not $ isn't _workDoneProgressEnd v-> Just () _ -> Nothing -- | Wait for all progress to be done @@ -425,7 +434,7 @@ waitForAllProgressDone = loop where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams _ (End _))) -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ isn't _workDoneProgressEnd v -> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop @@ -433,23 +442,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 ErrorCodes_InternalError (T.pack err) Nothing A.Success a -> pure a waitForAction :: String -> TextDocumentIdentifier -> Session (Either ResponseError WaitForIdeRuleResult) @@ -464,7 +473,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 +482,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..6219fa1501 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,18 @@ 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 Ide.TempLSPTypeFunctions 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 hiding ( id) +import Language.LSP.Protocol.Message hiding (error) +import qualified Language.LSP.Protocol.Types as L hiding (SemanticTokenAbsolute(..)) +import qualified Language.LSP.Protocol.Message as L import System.Directory import System.FilePath import System.Info.Extra (isMac, isWindows) @@ -75,18 +81,18 @@ import Test.Tasty.ExpectedFailure (expectFailBecause, import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) -noLiteralCaps :: C.ClientCapabilities -noLiteralCaps = def & textDocument ?~ textDocumentCaps +noLiteralCaps :: ClientCapabilities +noLiteralCaps = defClientCapabilities & textDocument ?~ textDocumentCaps where - textDocumentCaps = def { C._codeAction = Just codeActionCaps } + textDocumentCaps = defTextDocumentCapabilities { _codeAction = Just codeActionCaps } codeActionCaps = CodeActionClientCapabilities (Just True) Nothing Nothing Nothing Nothing Nothing Nothing -codeActionSupportCaps :: C.ClientCapabilities -codeActionSupportCaps = def & textDocument ?~ textDocumentCaps +codeActionSupportCaps :: ClientCapabilities +codeActionSupportCaps = defClientCapabilities & textDocument ?~ textDocumentCaps where - textDocumentCaps = def { C._codeAction = Just codeActionCaps } + textDocumentCaps = defTextDocumentCapabilities { _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 +249,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 +278,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 From 05da0d8fc5c6668630c4973aed375cc04d6a3c0e Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 5 Jun 2023 17:57:37 +0300 Subject: [PATCH 11/70] alternate-number-format compiles --- .../src/Ide/Plugin/AlternateNumberFormat.hs | 21 ++++++++++--------- .../test/Main.hs | 7 +++---- 2 files changed, 14 insertions(+), 14 deletions(-) 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..c32021af00 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 Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Types as L 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..b9844f6a6b 100644 --- a/plugins/hls-alternate-number-format-plugin/test/Main.hs +++ b/plugins/hls-alternate-number-format-plugin/test/Main.hs @@ -9,8 +9,7 @@ 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.Types (kind, toEither) import Properties.Conversion (conversions) import System.FilePath ((<.>), ()) import Test.Hls @@ -66,8 +65,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 From 9a0bff54aafd6467e673b532f5ae2ae0f37b9e3f Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 5 Jun 2023 17:58:33 +0300 Subject: [PATCH 12/70] hls-cabal-fmt compiles --- .../src/Ide/Plugin/CabalFmt.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) 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..1b1ac46aec 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,13 @@ 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.Message as J +import Language.LSP.Protocol.Types as J +import Prelude hiding (log) import System.Directory import System.Exit import System.FilePath @@ -46,7 +46,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 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,13 +63,13 @@ 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 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 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 From 45458fbac12171881723b6299b9ed4439143bd23 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 5 Jun 2023 18:00:24 +0300 Subject: [PATCH 13/70] cabal-plugin compiles --- .../hls-cabal-plugin/hls-cabal-plugin.cabal | 3 +- .../hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 21 +++++++------ .../src/Ide/Plugin/Cabal/Diagnostics.hs | 31 ++++++++++--------- .../src/Ide/Plugin/Cabal/LicenseSuggest.hs | 12 +++---- plugins/hls-cabal-plugin/test/Main.hs | 16 +++++----- 5 files changed, 45 insertions(+), 38 deletions(-) diff --git a/plugins/hls-cabal-plugin/hls-cabal-plugin.cabal b/plugins/hls-cabal-plugin/hls-cabal-plugin.cabal index 284b6973ef..c2a7f94489 100644 --- a/plugins/hls-cabal-plugin/hls-cabal-plugin.cabal +++ b/plugins/hls-cabal-plugin/hls-cabal-plugin.cabal @@ -58,7 +58,7 @@ library , stm , text , unordered-containers >=0.2.10.0 - + , containers hs-source-dirs: src default-language: Haskell2010 @@ -79,3 +79,4 @@ test-suite tests , 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..a59ce3f106 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..6d39e19cf5 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.Types as J import System.FilePath import Test.Hls @@ -80,7 +82,7 @@ pluginTests = testGroup "Plugin Tests" liftIO $ do length diags @?= 1 unknownLicenseDiag ^. J.range @?= Range (Position 3 24) (Position 4 0) - unknownLicenseDiag ^. J.severity @?= Just DsError + unknownLicenseDiag ^. J.severity @?= Just DiagnosticSeverity_Error , runCabalTestCaseSession "Clears diagnostics" "" $ do doc <- openDoc "invalid.cabal" "cabal" diags <- waitForDiagnosticsFrom doc @@ -88,7 +90,7 @@ pluginTests = testGroup "Plugin Tests" liftIO $ do length diags @?= 1 unknownLicenseDiag ^. J.range @?= Range (Position 3 24) (Position 4 0) - unknownLicenseDiag ^. J.severity @?= Just DsError + unknownLicenseDiag ^. J.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,14 @@ 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 ^. J.severity @?= Just DiagnosticSeverity_Error ] , testGroup "Code Actions" [ runCabalTestCaseSession "BSD-3" "" $ do @@ -122,7 +124,7 @@ pluginTests = testGroup "Plugin Tests" liftIO $ do length diags @?= 1 reduceDiag ^. J.range @?= Range (Position 3 24) (Position 4 0) - reduceDiag ^. J.severity @?= Just DsError + reduceDiag ^. J.severity @?= Just DiagnosticSeverity_Error [codeAction] <- getLicenseAction "BSD-3-Clause" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0)) executeCodeAction codeAction contents <- documentContents doc @@ -144,7 +146,7 @@ pluginTests = testGroup "Plugin Tests" liftIO $ do length diags @?= 1 reduceDiag ^. J.range @?= Range (Position 3 25) (Position 4 0) - reduceDiag ^. J.severity @?= Just DsError + reduceDiag ^. J.severity @?= Just DiagnosticSeverity_Error [codeAction] <- getLicenseAction "Apache-2.0" <$> getCodeActions doc (Range (Position 3 24) (Position 4 0)) executeCodeAction codeAction contents <- documentContents doc From e2651cf68cfbc0882cb07603b272d1aa2439e781 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 5 Jun 2023 18:02:11 +0300 Subject: [PATCH 14/70] call-hierarchy compiles --- .../src/Ide/Plugin/CallHierarchy.hs | 8 +- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 66 ++++++++-------- .../hls-call-hierarchy-plugin/test/Main.hs | 76 +++++++++---------- 3 files changed, 76 insertions(+), 74 deletions(-) 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..d6abd7ee6c 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 @@ -16,7 +16,7 @@ module Ide.Plugin.CallHierarchy.Internal ( import Control.Lens ((^.)) import Control.Monad.IO.Class import Data.Aeson as A -import Data.List (groupBy, sortBy) +import Data.List (groupBy, singleton, sortBy) import qualified Data.Map as M import Data.Maybe import qualified Data.Set as S @@ -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 Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Types as L 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_Variable (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_TypeParameter + -- which is 26 + skUnknown = SymbolKind_TypeParameter mkCallHierarchyItem' = mkCallHierarchyItem nfp @@ -165,15 +168,15 @@ mkSymbol = \case -------------- Incoming calls and outgoing calls --------------------- ---------------------------------------------------------------------- -deriving instance Ord SymbolKind +{- deriving instance Ord SymbolKind deriving instance Ord SymbolTag -deriving instance Ord CallHierarchyItem +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 +185,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 +200,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 +212,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 +227,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 +237,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 +261,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..c2efddef9e 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.Types 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_Variable 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_Variable 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,8 @@ outgoingCallsTests = ] ] -deriving instance Ord CallHierarchyIncomingCall -deriving instance Ord CallHierarchyOutgoingCall +{- 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 +530,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" From adbc9aec08c2bb3b5878381b2bf516c8925de11d Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 5 Jun 2023 18:04:49 +0300 Subject: [PATCH 15/70] change-type-signature compiles --- .../hls-change-type-signature-plugin.cabal | 2 +- .../src/Ide/Plugin/ChangeTypeSignature.hs | 34 ++++++++++--------- 2 files changed, 19 insertions(+), 17 deletions(-) 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 6b43a31507..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 @@ -36,7 +36,7 @@ library , text , transformers , unordered-containers - + , containers ghc-options: -Wall default-language: Haskell2010 default-extensions: 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 From 7f3ed6ea9ef6652445c8b69f439d605e371c2cbe Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 5 Jun 2023 18:06:59 +0300 Subject: [PATCH 16/70] class-plugin compiles --- .../hls-class-plugin/src/Ide/Plugin/Class.hs | 10 ++++---- .../src/Ide/Plugin/Class/CodeAction.hs | 24 ++++++++++--------- .../src/Ide/Plugin/Class/CodeLens.hs | 13 +++++----- .../src/Ide/Plugin/Class/ExactPrint.hs | 4 ++-- .../src/Ide/Plugin/Class/Types.hs | 3 +-- .../src/Ide/Plugin/Class/Utils.hs | 2 +- plugins/hls-class-plugin/test/Main.hs | 14 ++++++----- 7 files changed, 37 insertions(+), 33 deletions(-) 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 6b18a8e1df..ec82d03ad8 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -34,9 +34,10 @@ import Ide.Plugin.Class.Utils import qualified Ide.Plugin.Config import Ide.PluginUtils import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (Null) +import qualified Language.LSP.Protocol.Types as J 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 @@ -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 (VersionedTextDocumentIdentifier uri (Just 0)) (List [InL edit]) + TextDocumentEdit (OptionalVersionedTextDocumentIdentifier uri (InL 0)) [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,14 +82,14 @@ 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 nfp <- getNormalizedFilePath uri actions <- join <$> mapM (mkActions nfp) methodDiags - pure $ List actions + pure $ InL actions where uri = docId ^. J.uri - List diags = context ^. J.diagnostics + diags = context ^. J.diagnostics ghcDiags = filter (\d -> d ^. J.source == Just "typecheck") diags methodDiags = filter (\d -> isClassMethodWarning (d ^. J.message)) ghcDiags @@ -141,15 +142,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 uri range (List methodGroup) withSig)] + [toJSON (AddMinimalMethodsParams uri 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..b6e3cd39ab 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 Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (Null) +import qualified Language.LSP.Protocol.Types as J 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,7 +61,7 @@ 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 @@ -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 @@ -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..1740e20831 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,7 @@ 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 +import Language.LSP.Protocol.Types #if MIN_VERSION_ghc(9,2,0) import Data.Either.Extra (eitherToMaybe) @@ -28,7 +28,7 @@ makeEditText :: Monad m => ParsedModule -> DynFlags -> AddMinimalMethodsParams - -- 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) 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 8530b0f18f..5366b759bc 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Types.hs @@ -4,7 +4,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE BangPatterns #-} module Ide.Plugin.Class.Types where @@ -35,7 +34,7 @@ defaultIndent = 2 data AddMinimalMethodsParams = AddMinimalMethodsParams { uri :: Uri , 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 b8c8cfaebc..729bdef5b9 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -9,12 +9,14 @@ 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 qualified Data.Text as T +import qualified Ide.Plugin.Class as Class +import Language.LSP.Protocol.Message +import qualified Language.LSP.Protocol.Types as J import System.FilePath import Test.Hls @@ -123,7 +125,7 @@ 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) + void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) goldenWithClass ::TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree goldenWithClass title path desc act = From e723ed20d5eb99fcc85f1c7fc594d22eb70b29ac Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 5 Jun 2023 18:12:02 +0300 Subject: [PATCH 17/70] code-range compiles --- .../hls-code-range-plugin.cabal | 2 + .../src/Ide/Plugin/CodeRange.hs | 39 +++++---- .../src/Ide/Plugin/CodeRange/Rules.hs | 10 +-- .../test/Ide/Plugin/CodeRangeTest.hs | 16 ++-- plugins/hls-code-range-plugin/test/Main.hs | 24 +++--- .../folding-range/Function.golden.txt | 82 +++++++++---------- 6 files changed, 88 insertions(+), 85 deletions(-) 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 1e2dfeccad..807a2285b1 100644 --- a/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal +++ b/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal @@ -72,3 +72,5 @@ test-suite tests , text , transformers , vector + -- Dump this once dumpNulls has gotten into lsp types + , hls-plugin-api 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..ecb4375709 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,8 @@ 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), + HasEnd (end), HasStart (start)) import Prelude hiding (log) @@ -195,6 +195,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..51fa78d489 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 Ide.TempLSPTypeFunctions +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 . nullToEmpty) 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 . nullToEmpty) 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 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 From 04b5c148417b53746226a8e8da0aa2583edcaf59 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 5 Jun 2023 21:47:51 +0300 Subject: [PATCH 18/70] eval-plugin compiles --- plugins/hls-eval-plugin/hls-eval-plugin.cabal | 1 + .../hls-eval-plugin/src/Ide/Plugin/Eval.hs | 26 +++---- .../src/Ide/Plugin/Eval/Code.hs | 29 ++++--- .../src/Ide/Plugin/Eval/CodeLens.hs | 76 +++++++++---------- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 11 +-- .../src/Ide/Plugin/Eval/Types.hs | 2 +- .../src/Ide/Plugin/Eval/Util.hs | 45 ++++++----- plugins/hls-eval-plugin/test/Main.hs | 47 ++++++------ 8 files changed, 123 insertions(+), 114 deletions(-) diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index c901471dc0..fa33dd99ff 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -115,3 +115,4 @@ test-suite tests , 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..0c79a90f7b 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs @@ -6,23 +6,22 @@ -- | 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 Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..)) +import System.IO.Extra (newTempFile, readFile') -- | Return the ranges of the expression and result parts of the given test testRanges :: Test -> (Range, Range) 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..93ae630c74 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,19 @@ import Ide.PluginUtils (handleMaybe, handleMaybeM, pluginResponse) import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + codeLens, id, + text) 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 +171,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 +192,7 @@ codeLens st plId CodeLensParams{_textDocument} = , "lenses." ] - return $ List lenses + return $ InL lenses where trivial (Range p p') = p == p' @@ -234,7 +234,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 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 f3479fa42c..88be21c961 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 @@ -38,9 +38,10 @@ import Development.IDE (Position, 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 Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..)) + import qualified Text.Megaparsec as P import Text.Megaparsec import Text.Megaparsec.Char (alphaNumChar, char, @@ -73,7 +74,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 +110,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 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..c94952912e 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 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..de147ef227 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.Message hiding (error) +import Language.LSP.Protocol.Types (arguments, command, range, + title) +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) From 5e163ca68d977e7a63ad2d7977714c5143e7acbe Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 5 Jun 2023 22:24:49 +0300 Subject: [PATCH 19/70] Update helper functions --- hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs | 9 ++++----- plugins/hls-code-range-plugin/test/Main.hs | 4 ++-- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs b/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs index ea81de6faf..1ac1c9a8a1 100644 --- a/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs +++ b/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs @@ -9,7 +9,7 @@ module Ide.TempLSPTypeFunctions (takeLefts, dumpNulls, nullToMaybe', NullToMaybe defNotebookDocumentSyncClientCapabilities, defTextDocumentCapabilities, defWindowClientCapabilities, - defWorkspaceCapabilities, nullToEmpty) where + defWorkspaceCapabilities, maybeToNull) where import Data.Semigroup () import Data.Text (Text) @@ -26,7 +26,6 @@ import Language.LSP.Protocol.Types (ClientCapabilities (ClientCapabi WorkspaceEdit (WorkspaceEdit), type (|?) (..)) - -- The functions below may be added to the lsp-types package if they end up being -- useful. temporarily including them here now. @@ -43,9 +42,9 @@ dumpNulls = foldr (\x acc -> case nullToMaybe' x of Just x' -> x' : acc Nothing -> acc) [] -nullToEmpty :: Monoid m => (m |? Null) -> m -nullToEmpty (InR Null) = mempty -nullToEmpty (InL ls) = ls +maybeToNull :: Maybe a -> a |? Null +maybeToNull (Just x) = InL x +maybeToNull Nothing = InR Null instance Semigroup s => Semigroup (s |? Null) where InL x <> InL y = InL (x <> y) InL x <> InR _ = InL x diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index 51fa78d489..7865c247a4 100644 --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -46,7 +46,7 @@ selectionRangeGoldenTest testName positions = goldenGitDiff testName (testDataDi 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 . nullToEmpty) res + pure $ fmap (showSelectionRangesForTest . absorbNull) res case res of Left err -> assertFailure (show err) Right golden -> pure golden @@ -74,7 +74,7 @@ foldingRangeGoldenTest testName = goldenGitDiff testName (testDataDir testN doc <- openDoc (testName <.> "hs") "haskell" resp <- request SMethod_TextDocumentFoldingRange $ FoldingRangeParams Nothing Nothing doc let res = resp ^. result - pure $ fmap (showFoldingRangesForTest . nullToEmpty) res + pure $ fmap (showFoldingRangesForTest . absorbNull) res case res of Left err -> assertFailure (show err) From 70dd0087a59538de895dcf0a674b82ca30cda4f6 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 5 Jun 2023 22:25:49 +0300 Subject: [PATCH 20/70] explicit-fixity compiles --- .../src/Ide/Plugin/ExplicitFixity.hs | 12 +++++++----- plugins/hls-explicit-fixity-plugin/test/Main.hs | 5 +++-- 2 files changed, 10 insertions(+), 7 deletions(-) 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..33af9991c6 100644 --- a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs +++ b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs @@ -31,19 +31,21 @@ import GHC.Generics (Generic) import Ide.PluginUtils (getNormalizedFilePath, handleMaybeM, pluginResponse) +import Ide.TempLSPTypeFunctions (maybeToNull) import Ide.Types hiding (pluginId) -import Language.LSP.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (hover) 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 +53,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 +62,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..dd8455277e 100644 --- a/plugins/hls-explicit-fixity-plugin/test/Main.hs +++ b/plugins/hls-explicit-fixity-plugin/test/Main.hs @@ -59,11 +59,12 @@ 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 From 2030f0e59eb34da03f3874865123c3f57e4da43f Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 6 Jun 2023 22:35:37 +0300 Subject: [PATCH 21/70] Update to the latest lsp* changes --- cabal.project | 6 +- ghcide-bench/src/Experiments.hs | 10 +- .../session-loader/Development/IDE/Session.hs | 3 +- ghcide/src/Development/IDE/Core/OfInterest.hs | 1 - .../Development/IDE/Core/ProgressReporting.hs | 4 +- ghcide/src/Development/IDE/Core/Shake.hs | 4 +- .../Development/IDE/LSP/HoverDefinition.hs | 5 +- .../src/Development/IDE/LSP/LanguageServer.hs | 4 +- .../src/Development/IDE/Plugin/Completions.hs | 6 +- .../IDE/Plugin/Completions/Logic.hs | 8 +- ghcide/src/Development/IDE/Plugin/HLS.hs | 33 +++---- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 3 +- ghcide/src/Development/IDE/Plugin/Test.hs | 6 +- ghcide/src/Development/IDE/Spans/AtPoint.hs | 4 +- ghcide/src/Development/IDE/Types/Options.hs | 12 +-- ghcide/test/exe/Main.hs | 32 +++--- ghcide/test/src/Development/IDE/Test.hs | 15 ++- .../src/Development/IDE/Test/Diagnostic.hs | 1 + hls-plugin-api/src/Ide/PluginUtils.hs | 32 +++--- hls-plugin-api/src/Ide/Types.hs | 97 +++++++++---------- hls-test-utils/src/Test/Hls.hs | 11 +-- hls-test-utils/src/Test/Hls/Util.hs | 11 +-- .../src/Ide/Plugin/AlternateNumberFormat.hs | 2 +- .../test/Main.hs | 3 +- plugins/hls-cabal-plugin/test/Main.hs | 22 ++--- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 2 +- .../hls-call-hierarchy-plugin/test/Main.hs | 16 +-- .../src/Ide/Plugin/Class/CodeAction.hs | 16 +-- .../src/Ide/Plugin/Class/CodeLens.hs | 8 +- .../src/Ide/Plugin/Class/ExactPrint.hs | 1 - plugins/hls-class-plugin/test/Main.hs | 8 +- .../src/Ide/Plugin/CodeRange/Rules.hs | 5 +- plugins/hls-code-range-plugin/test/Main.hs | 1 + .../src/Ide/Plugin/Eval/Code.hs | 9 +- .../src/Ide/Plugin/Eval/CodeLens.hs | 13 +-- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 23 +++-- .../src/Ide/Plugin/Eval/Util.hs | 2 +- plugins/hls-eval-plugin/test/Main.hs | 4 +- .../src/Ide/Plugin/ExplicitFixity.hs | 2 +- 39 files changed, 208 insertions(+), 237 deletions(-) diff --git a/cabal.project b/cabal.project index 69433e35cf..56c58396ce 100644 --- a/cabal.project +++ b/cabal.project @@ -95,17 +95,17 @@ source-repository-package source-repository-package type:git location: https://github.com/joyfulmantis/lsp - tag: 98d34d93d8bd93ec603b77f5e5085ba09c74b9c1 + tag: 395018160475a37f51e2ec8222e763bb92592506 subdir: lsp source-repository-package type:git location: https://github.com/joyfulmantis/lsp - tag: 98d34d93d8bd93ec603b77f5e5085ba09c74b9c1 + tag: 395018160475a37f51e2ec8222e763bb92592506 subdir: lsp-types source-repository-package type:git location: https://github.com/joyfulmantis/lsp - tag: 98d34d93d8bd93ec603b77f5e5085ba09c74b9c1 + tag: 395018160475a37f51e2ec8222e763bb92592506 subdir: lsp-test diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index 21a4c34c21..a8ff09a31a 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -54,12 +54,10 @@ import Development.Shake (CmdOption (Cwd, FileStdout) cmd_) import Experiments.Types import Language.LSP.Protocol.Capabilities -import Language.LSP.Protocol.Message hiding (error) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types hiding (Null, - SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start), - matches, value, verbose) + SemanticTokenAbsolute (..)) import Language.LSP.Test import Numeric.Natural import Options.Applicative @@ -663,7 +661,7 @@ findEndOfImports (DocumentSymbol{_kind = SymbolKind_Module, _name = "imports", _ findEndOfImports [DocumentSymbol{_kind = SymbolKind_File, _children = Just (cc)}] = findEndOfImports cc findEndOfImports (DocumentSymbol{_range} : _) = - Just $ _range ^. start + Just $ _range ^. L.start findEndOfImports _ = Nothing -------------------------------------------------------------------------------------------- diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 17b04ec63a..8777fe4846 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -79,8 +79,7 @@ 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 hiding (error) -import Language.LSP.Protocol.Types hiding (id) +import Language.LSP.Protocol.Message hiding (error, id) import Language.LSP.Server import System.Directory import qualified System.Directory.Extra as IO diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index e6d31819e7..ddb919a424 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -48,7 +48,6 @@ import Development.IDE.Types.Logger (Pretty (pretty), import Development.IDE.Types.Options (IdeTesting (..)) import GHC.TypeLits (KnownSymbol) import qualified Language.LSP.Protocol.Message as LSP -import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP data Log = LogShake Shake.Log diff --git a/ghcide/src/Development/IDE/Core/ProgressReporting.hs b/ghcide/src/Development/IDE/Core/ProgressReporting.hs index ff54d7fa4e..598e4d649b 100644 --- a/ghcide/src/Development/IDE/Core/ProgressReporting.hs +++ b/ghcide/src/Development/IDE/Core/ProgressReporting.hs @@ -31,8 +31,8 @@ import Development.IDE.Graph hiding (ShakeValue) import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified Focus -import Language.LSP.Protocol.Message hiding (error) -import Language.LSP.Protocol.Types hiding (id) +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 qualified StmContainers.Map as STM diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 60ccf24a47..448c7145f9 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -168,8 +168,8 @@ import Ide.Types (IdePlugins (IdePlugins) PluginDescriptor (pluginId), PluginId) import Language.LSP.Diagnostics -import Language.LSP.Protocol.Message hiding (error) -import Language.LSP.Protocol.Types hiding (id, start) +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.VFS hiding (start) diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index bceb9eb20a..b2a7b5b5c9 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -23,8 +23,7 @@ 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 hiding (documentHighlight, - hover, id, references) +import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP import qualified Data.Text as T @@ -47,7 +46,7 @@ references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO "References request at position " <> T.pack (showPosition pos) <> " in file: " <> T.pack path Right <$> (runAction "references" ide $ refsAtPoint filePath pos) - Nothing -> pure $ Left $ ResponseError ErrorCodes_InvalidParams ("Invalid URI " <> T.pack (show uri)) Nothing + Nothing -> pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) ("Invalid URI " <> T.pack (show uri)) Nothing wsSymbols :: IdeState -> WorkspaceSymbolParams -> LSP.LspM c (Either ResponseError [SymbolInformation]) wsSymbols ide (WorkspaceSymbolParams _ _ query) = liftIO $ do diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index d6aebc27a1..22421125b5 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -234,11 +234,11 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa case cancelOrRes of Left () -> do log Debug $ LogCancelledRequest _id - k $ ResponseError (ErrorCodes_Custom (-32800)) "" Nothing + k $ ResponseError (InL LSPErrorCodes_RequestCancelled) "" Nothing Right res -> pure res ) $ \(e :: SomeException) -> do exceptionInHandler e - k $ ResponseError ErrorCodes_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) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 1b79d87b9c..a3d36723c5 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -41,9 +41,9 @@ 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.Protocol.Types as J import qualified Language.LSP.Server as LSP import qualified Language.LSP.VFS as VFS import Numeric.Natural @@ -154,8 +154,8 @@ resolveCompletion ide _ comp@CompletionItem{_detail,_documentation,_data_} 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 & J.detail .~ (det1 <> _detail) - & J.documentation .~ Just doc1 + pure (Right $ comp & L.detail .~ (det1 <> _detail) + & L.documentation .~ Just doc1 ) where stripForall ty = case splitForAllTyCoVars ty of diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 62c97bf37d..b11e242fbf 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -67,10 +67,8 @@ import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), IdePlugins (..), PluginId) -import Language.LSP.Protocol.Capabilities -import Language.LSP.Protocol.Types hiding (id, - insertText, label, - name) +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) @@ -534,7 +532,7 @@ toggleSnippets ClientCapabilities {_textDocument} CompletionsConfig{..} = removeSnippetsWhen (not $ enableSnippets && supported) where supported = - Just True == (_textDocument >>= _completion >>= view completionItem >>= (\x -> x .! #snippetSupport)) + Just True == (_textDocument >>= _completion >>= view L.completionItem >>= (\x -> x .! #snippetSupport)) toggleAutoExtend :: CompletionsConfig -> CompItem -> CompItem toggleAutoExtend CompletionsConfig{enableAutoExtend=False} x = x {additionalTextEdits = Nothing} diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 1607f7a559..c134a26045 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -36,10 +36,9 @@ import Development.IDE.Types.Logger hiding (Error) import Ide.Plugin.Config 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 hiding (id) -import qualified Language.LSP.Protocol.Types as J -import qualified Language.LSP.Protocol.Types as LSP +import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP import Language.LSP.VFS import Prettyprinter.Render.String (renderString) @@ -68,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 = @@ -94,7 +93,7 @@ failedToParseArgs (CommandId com) (PluginId pid) err arg = <> T.pack err <> ", arg = " <> T.pack (show arg) -- | Build a ResponseError and log it before returning to the caller -logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> ErrorCodes -> 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 @@ -158,7 +157,7 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom _ -> Nothing -- The parameters to the HLS command are always the first element - execCmd :: IdeState -> ExecuteCommandParams -> LSP.LspT Config IO (Either ResponseError (A.Value |? LSP.Null)) + execCmd :: IdeState -> ExecuteCommandParams -> LSP.LspT Config IO (Either ResponseError (A.Value |? Null)) execCmd ide (ExecuteCommandParams _ cmdId args) = do let cmdParams :: A.Value cmdParams = case args of @@ -176,11 +175,11 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom 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 $ InL $ A.Null + Nothing -> return $ Right $ InL A.Null - A.Error _str -> return $ Right $ InL $ A.Null + A.Error _str -> return $ Right $ InL A.Null -- Just an ordinary HIE command Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams @@ -188,16 +187,16 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom -- Couldn't parse the command identifier _ -> do logWith recorder Warning LogInvalidCommandIdentifier - return $ Left $ ResponseError ErrorCodes_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 ErrorCodes_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 ErrorCodes_InvalidRequest (commandDoesntExist com p xs) + 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 ErrorCodes_InvalidParams (failedToParseArgs com p err arg) + A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg) A.Success a -> fmap InL <$> f ide a -- --------------------------------------------------------------------- @@ -222,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 ErrorCodes_InvalidRequest msg Nothing + let err = ResponseError (InR ErrorCodes_InvalidRequest) msg Nothing msg = pluginNotEnabled m fs' return $ Left err Just fs -> do @@ -277,11 +276,11 @@ 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 ErrorCodes_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 ErrorCodes_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 :: Method ClientToServer Request) diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index ae85621b81..ecc632355d 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -16,8 +16,7 @@ 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 hiding (documentHighlight, - hover, references) +import Language.LSP.Protocol.Types import Language.LSP.Server (LspM) import Text.Regex.TDFA.Text () diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 7407d8d440..8d403ce8ab 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -46,7 +46,7 @@ import GHC.Generics (Generic) import Ide.Plugin.Config (CheckParents) import Ide.Types import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding (Null, retry) +import Language.LSP.Protocol.Types hiding (Null) import qualified Language.LSP.Server as LSP import qualified "list-t" ListT import qualified StmContainers.Map as STM @@ -84,7 +84,7 @@ plugin = (defaultPluginDescriptor "test") { = testRequestHandler ide customReq | otherwise = return $ Left - $ ResponseError ErrorCodes_InvalidRequest "Cannot parse request" Nothing + $ ResponseError (InR ErrorCodes_InvalidRequest) "Cannot parse request" Nothing testRequestHandler :: IdeState @@ -147,7 +147,7 @@ getDatabaseKeys field db = do return [ k | (k, res) <- keys, field res == Step step] mkResponseError :: Text -> ResponseError -mkResponseError msg = ResponseError ErrorCodes_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 diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index cddc98befc..9c01629cb6 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.Protocol.Types hiding (documentHighlight) +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..)) -- compiler and infrastructure import Development.IDE.Core.PositionMapping @@ -426,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/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 0b56e03abb..17bf035439 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -20,16 +20,16 @@ module Development.IDE.Types.Options , ProgressReportingStyle(..) ) where import Control.Lens -import qualified Data.Text as T +import qualified Data.Text as T import Data.Typeable import Development.IDE.Core.RuleTypes -import Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Compat as GHC import Development.IDE.Graph import Development.IDE.Types.Diagnostics import Ide.Plugin.Config -import Ide.Types (DynFlagsModifications) -import qualified Language.LSP.Protocol.Capabilities as LSP -import qualified Language.LSP.Protocol.Types as LSP +import Ide.Types (DynFlagsModifications) +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 @@ -111,7 +111,7 @@ data ProgressReportingStyle clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress clientSupportsProgress caps = IdeReportProgress $ Just True == - ((\x -> x ^. 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 36c044cbf0..fa0a725b75 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -94,16 +94,11 @@ import Development.Shake (getDirectoryFilesIO) import Ide.Plugin.Config import Language.LSP.Test import Language.LSP.Protocol.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start), - mkRange, message, diagnostic, executeCommand, applyEdit, id) -import qualified Language.LSP.Protocol.Types as L hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import Language.LSP.Protocol.Message hiding (error) -import Language.LSP.Protocol.Capabilities + (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 @@ -149,7 +144,6 @@ import GHC.Stack (emptyCallStack) import qualified HieDbRetry import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types -import Ide.TempLSPTypeFunctions import qualified Progress import System.Time.Extra import qualified Test.QuickCheck.Monadic as MonadicQuickCheck @@ -285,11 +279,11 @@ initializeResponseTests = withResource acquire release tests where _documentOnTypeFormattingProvider Nothing , chk "NO renaming" _renameProvider (Just $ InL False) , chk "NO doc link" _documentLinkProvider Nothing - , chk "NO color" (^. colorProvider) (Just $ InL False) + , chk "NO color" (^. L.colorProvider) (Just $ InL False) , chk "NO folding range" _foldingRangeProvider (Just $ InL False) , che " execute command" _executeCommandProvider [typeLensCommandId, blockCommandId] - , chk " workspace" (^. workspace) (Just $ #workspaceFolders .== Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )} .+ #fileOperations .== Nothing) - , chk "NO experimental" (^. experimental) Nothing + , 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 @@ -676,8 +670,8 @@ diagnosticTests = testGroup "diagnostics" notification <- skipManyTill anyMessage diagnostic let offenders = - params . - diagnostics . + L.params . + L.diagnostics . Lens.folded . L.message . Lens.filtered (T.isInfixOf ("/" <> name <> ".hs:")) @@ -1566,7 +1560,7 @@ completionTest name src pos expected = testSessionWait name $ do if expectedSig || expectedDocs then do rsp <- request SMethod_CompletionItemResolve item - case rsp ^. result of + case rsp ^. L.result of Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) Right x -> pure x else pure item @@ -2074,7 +2068,7 @@ completionDocTests = compls <- getCompletions doc pos rcompls <- forM compls $ \item -> do rsp <- request SMethod_CompletionItemResolve item - case rsp ^. result of + case rsp ^. L.result of Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) Right x -> pure x let compls' = [ @@ -3238,7 +3232,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 diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 72ee8d4d37..714d562530 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -51,12 +51,9 @@ import Development.IDE.Plugin.Test (TestRequest (..), ideResultSuccess) import Development.IDE.Test.Diagnostic import Ide.Plugin.Config (CheckParents, checkProject) -import Language.LSP.Protocol.Message hiding (error) -import Language.LSP.Protocol.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start), - diagnostic) +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 System.Directory (canonicalizePath) @@ -78,8 +75,8 @@ requireDiagnosticM actuals expected = case requireDiagnostic actuals expected of expectNoMoreDiagnostics :: HasCallStack => Seconds -> Session () expectNoMoreDiagnostics timeout = expectMessages SMethod_TextDocumentPublishDiagnostics timeout $ \diagsNot -> do - let fileUri = diagsNot ^. params . uri - actual = diagsNot ^. params . diagnostics + let fileUri = diagsNot ^. L.params . L.uri + actual = diagsNot ^. L.params . L.diagnostics unless (actual == []) $ liftIO $ assertFailure $ "Got unexpected diagnostics for " <> show fileUri @@ -121,7 +118,7 @@ expectDiagnostics . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) unwrapDiagnostic :: TServerMessage Method_TextDocumentPublishDiagnostics -> (Uri, [Diagnostic]) -unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics) +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 diff --git a/ghcide/test/src/Development/IDE/Test/Diagnostic.hs b/ghcide/test/src/Development/IDE/Test/Diagnostic.hs index d2f3b8362b..86c1b8bb9d 100644 --- a/ghcide/test/src/Development/IDE/Test/Diagnostic.hs +++ b/ghcide/test/src/Development/IDE/Test/Diagnostic.hs @@ -3,6 +3,7 @@ module Development.IDE.Test.Diagnostic where 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) diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 0fdfe1c0fd..1705fb42c0 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -57,11 +57,7 @@ import Ide.Plugin.Config import Ide.Plugin.Properties import Ide.Types import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import qualified Language.LSP.Protocol.Types as J +import Language.LSP.Protocol.Types import Language.LSP.Server import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P @@ -123,8 +119,8 @@ diffTextEdit fText f2Text withDeletions = 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 @@ -136,28 +132,28 @@ diffTextEdit fText f2Text withDeletions = 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,7 +166,7 @@ diffText' supports (f,fText) f2Text withDeletions = diff = diffTextEdit fText f2Text withDeletions h = M.singleton f diff docChanges = [InL docEdit] - docEdit = J.TextDocumentEdit (J.OptionalVersionedTextDocumentIdentifier f (InL 0)) $ fmap InL diff + docEdit = TextDocumentEdit (OptionalVersionedTextDocumentIdentifier f (InL 0)) $ fmap InL diff -- --------------------------------------------------------------------- @@ -280,7 +276,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 ErrorCodes_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 3d3ed7f795..c1d7421f8a 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -60,7 +60,7 @@ import System.Posix.Signals import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) import Control.Lens ((.~), (^.)) -import Data.Aeson hiding (defaultOptions) +import Data.Aeson hiding (Null, defaultOptions) import Data.Default import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap @@ -83,12 +83,9 @@ import GHC (DynFlags) import GHC.Generics import Ide.Plugin.Properties import Ide.TempLSPTypeFunctions +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), id) -import qualified Language.LSP.Protocol.Types as J +import Language.LSP.Protocol.Types import Language.LSP.Server (LspM, getVirtualFile) import Language.LSP.VFS import Numeric.Natural @@ -368,11 +365,11 @@ class HasTracing (MessageParams m) => PluginMethod (k :: MessageKind) (m :: Meth -- ^ 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 @@ -404,12 +401,12 @@ 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 Method_TextDocumentCodeAction where combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _ _) (CodeActionParams _ _ _ _ context) resps = case fmap compat $ filter wasRequested $ concat $ dumpNulls resps of - [] -> InR J.Null + [] -> InR Null x -> InL x where compat :: (Command |? CodeAction) -> (Command |? CodeAction) @@ -419,8 +416,8 @@ instance PluginRequestMethod Method_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 @@ -432,7 +429,7 @@ instance PluginRequestMethod Method_TextDocumentCodeAction where -- 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 -- Copied form lsp-types 1.6 to get compilation working. May make more @@ -446,25 +443,25 @@ 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 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 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 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 Method_WorkspaceSymbol where -- Unconditionally enabled, but should it really be? @@ -474,24 +471,24 @@ 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 Method_TextDocumentRename where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc && pluginEnabledConfig plcRenameOn (configForPlugin config pluginDesc) where - uri = msgParams ^. J.textDocument . J.uri + 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 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 Method_CompletionItemResolve where pluginEnabled _ msgParams pluginDesc config = pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) @@ -500,40 +497,40 @@ 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 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 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 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 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 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 Method_CallHierarchyIncomingCalls where -- This method has no URI parameter, thus no call to 'pluginResponsible' @@ -568,24 +565,24 @@ instance PluginRequestMethod Method_TextDocumentRename where instance PluginRequestMethod Method_TextDocumentHover where combineResponses _ _ _ _ (dumpNulls -> hs :: [Hover]) = - if mcontent ^. value == "" - then InR J.Null + if mcontent ^. L.value == "" + then InR Null else InL $ Hover (InL mcontent) r where - r = listToMaybe $ mapMaybe (^. range) hs + 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 (^. contents) hs + 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 :: [Either [SymbolInformation] [DocumentSymbol]] dsOrSi = toEither <$> dumpNulls xs - res :: [SymbolInformation] |? ([DocumentSymbol] |? J.Null) + res :: [SymbolInformation] |? ([DocumentSymbol] |? Null) res | supportsHierarchy = InR $ InL $ concatMap (either (fmap siToDs) id) dsOrSi | otherwise = InL $ concatMap (either id ( concatMap dsToSi)) dsOrSi @@ -598,10 +595,10 @@ instance PluginRequestMethod Method_TextDocumentDocumentSymbol where go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation] go parent ds = let children' :: [SymbolInformation] - children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children)) - loc = Location uri' (ds ^. range) - name' = ds ^. name - si = SymbolInformation name' (ds ^. kind) Nothing parent (ds ^. deprecated) loc + 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 Method_CompletionItemResolve where @@ -611,9 +608,9 @@ instance PluginRequestMethod Method_CompletionItemResolve where 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 Method_TextDocumentCompletion where @@ -630,7 +627,7 @@ instance PluginRequestMethod Method_TextDocumentCompletion where go comp (acc <> DList.fromList ls) rest go comp acc ( (InR (InL (CompletionList comp' _ ls))) : rest) = go (comp && comp') (acc <> DList.fromList ls) rest - go comp acc ( (InR (InR J.Null)) : rest) = + go comp acc ( (InR (InR Null)) : rest) = go comp acc rest -- boolean disambiguators isCompleteResponse, isIncompleteResponse :: Bool @@ -645,7 +642,7 @@ instance PluginRequestMethod Method_TextDocumentCompletion 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 J.Null)) = (n, InR (InR J.Null)) + consumeCompletionResponse n (InR (InR Null)) = (n, InR (InR Null)) instance PluginRequestMethod Method_TextDocumentFormatting where combineResponses _ _ _ _ (x :| _) = x @@ -879,8 +876,8 @@ data FormattingType = FormatText type FormattingMethod m = - ( J.HasOptions (MessageParams m) FormattingOptions - , J.HasTextDocument (MessageParams m) TextDocumentIdentifier + ( L.HasOptions (MessageParams m) FormattingOptions + , L.HasTextDocument (MessageParams m) TextDocumentIdentifier , MessageResult m ~ ([TextEdit] |? Null) ) @@ -904,20 +901,20 @@ mkFormattingHandlers f = mkPluginHandler SMethod_TextDocumentFormatting ( provid Just vf -> do let typ = case m of SMethod_TextDocumentFormatting -> FormatText - SMethod_TextDocumentRangeFormatting -> FormatRange (params ^. J.range) + 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 ErrorCodes_InvalidParams txt Nothing +responseError txt = ResponseError (InR ErrorCodes_InvalidParams) txt Nothing -- --------------------------------------------------------------------- @@ -937,8 +934,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 diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index aa356bafb1..ea4df83ed2 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -95,13 +95,8 @@ import GHC.Stack (emptyCallStack) import GHC.TypeLits import Ide.Types import Language.LSP.Protocol.Capabilities -import Language.LSP.Protocol.Message hiding (error) -import Language.LSP.Protocol.Types hiding (Null, - SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start), - applyEdit, executeCommand, - message, rename) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding (Null) import Language.LSP.Test import Prelude hiding (log) import System.Directory (getCurrentDirectory, @@ -458,7 +453,7 @@ callTestPlugin cmd = do return $ do e <- _result case A.fromJSON e of - A.Error err -> Left $ ResponseError ErrorCodes_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) diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index 6219fa1501..85ade5421e 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -65,10 +65,9 @@ import qualified Data.Text as T import Development.IDE (GhcVersion (..), ghcVersion) import Ide.TempLSPTypeFunctions import qualified Language.LSP.Test as Test -import Language.LSP.Protocol.Types hiding ( id) -import Language.LSP.Protocol.Message hiding (error) -import qualified Language.LSP.Protocol.Types as L hiding (SemanticTokenAbsolute(..)) -import qualified Language.LSP.Protocol.Message 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) @@ -82,13 +81,13 @@ import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) noLiteralCaps :: ClientCapabilities -noLiteralCaps = defClientCapabilities & textDocument ?~ textDocumentCaps +noLiteralCaps = defClientCapabilities & L.textDocument ?~ textDocumentCaps where textDocumentCaps = defTextDocumentCapabilities { _codeAction = Just codeActionCaps } codeActionCaps = CodeActionClientCapabilities (Just True) Nothing Nothing Nothing Nothing Nothing Nothing codeActionSupportCaps :: ClientCapabilities -codeActionSupportCaps = defClientCapabilities & textDocument ?~ textDocumentCaps +codeActionSupportCaps = defClientCapabilities & L.textDocument ?~ textDocumentCaps where textDocumentCaps = defTextDocumentCapabilities { _codeAction = Just codeActionCaps } codeActionCaps = CodeActionClientCapabilities (Just True) (Just literalSupport) (Just True) Nothing Nothing Nothing Nothing 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 c32021af00..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 @@ -31,9 +31,9 @@ import qualified Ide.Plugin.RangeMap as RangeMap import Ide.PluginUtils (getNormalizedFilePath, handleMaybeM, pluginResponse) 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.Protocol.Types as L newtype Log = LogShake Shake.Log deriving Show diff --git a/plugins/hls-alternate-number-format-plugin/test/Main.hs b/plugins/hls-alternate-number-format-plugin/test/Main.hs index b9844f6a6b..5955247f7a 100644 --- a/plugins/hls-alternate-number-format-plugin/test/Main.hs +++ b/plugins/hls-alternate-number-format-plugin/test/Main.hs @@ -9,7 +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.Protocol.Types (kind, toEither) +import Language.LSP.Protocol.Lens (kind) +import Language.LSP.Protocol.Types (toEither) import Properties.Conversion (conversions) import System.FilePath ((<.>), ()) import Test.Hls diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index 6d39e19cf5..a29f35f11f 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -17,7 +17,7 @@ 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.Protocol.Types as J +import qualified Language.LSP.Protocol.Lens as L import System.FilePath import Test.Hls @@ -81,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 DiagnosticSeverity_Error + 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 DiagnosticSeverity_Error + 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 @?= [] @@ -113,8 +113,8 @@ pluginTests = testGroup "Plugin Tests" expectNoMoreDiagnostics 1 hsDoc "typechecking" liftIO $ do length cabalDiags @?= 1 - unknownLicenseDiag ^. J.range @?= Range (Position 3 24) (Position 4 0) - unknownLicenseDiag ^. J.severity @?= Just DiagnosticSeverity_Error + unknownLicenseDiag ^. L.range @?= Range (Position 3 24) (Position 4 0) + unknownLicenseDiag ^. L.severity @?= Just DiagnosticSeverity_Error ] , testGroup "Code Actions" [ runCabalTestCaseSession "BSD-3" "" $ do @@ -123,8 +123,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 DiagnosticSeverity_Error + 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 @@ -145,8 +145,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 DiagnosticSeverity_Error + 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/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index d6abd7ee6c..b85e13962c 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,9 +33,9 @@ import Ide.PluginUtils (getNormalizedFilePath, handleMaybe, pluginResponse, throwPluginError) 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.Protocol.Types as L import Text.Read (readMaybe) -- | Render prepare call hierarchy request. diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index c2efddef9e..b42149c464 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.Protocol.Types as L -import qualified Language.LSP.Test as Test +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" 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 ec82d03ad8..4286c65130 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -34,9 +34,9 @@ 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 qualified Language.LSP.Protocol.Types as J import Language.LSP.Server addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams @@ -88,11 +88,11 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe actions <- join <$> mapM (mkActions nfp) methodDiags pure $ InL actions where - uri = docId ^. J.uri - diags = context ^. J.diagnostics + uri = docId ^. L.uri + 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 +104,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 +121,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] 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 b6e3cd39ab..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,9 +19,9 @@ 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 qualified Language.LSP.Protocol.Types as J import Language.LSP.Server (sendRequest) codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens @@ -63,7 +63,7 @@ codeLens state plId CodeLensParams{..} = pluginResponse $ do 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`, @@ -133,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) " ")] 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 1740e20831..2eca5fa513 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.Protocol.Types #if MIN_VERSION_ghc(9,2,0) import Data.Either.Extra (eitherToMaybe) diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index 729bdef5b9..480cd7ffc5 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -15,8 +15,8 @@ import Control.Monad (void) import Data.Maybe 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 qualified Language.LSP.Protocol.Types as J import System.FilePath import Test.Hls @@ -87,7 +87,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" @@ -124,7 +124,7 @@ 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 + executeCommand $ fromJust $ (lens !! idx) ^. L.command void $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) goldenWithClass ::TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree @@ -142,7 +142,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/src/Ide/Plugin/CodeRange/Rules.hs b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange/Rules.hs index ecb4375709..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.Protocol.Types (FoldingRangeKind (FoldingRangeKind_Comment, FoldingRangeKind_Imports, FoldingRangeKind_Region), - 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) diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index 7865c247a4..4e521be9b2 100644 --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -15,6 +15,7 @@ import Ide.Plugin.CodeRange (Log, descriptor) import qualified Ide.Plugin.CodeRange.RulesTest import qualified Ide.Plugin.CodeRangeTest import Ide.TempLSPTypeFunctions +import Language.LSP.Protocol.Lens import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import System.FilePath ((<.>), ()) 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 0c79a90f7b..846d8ce160 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs @@ -19,14 +19,15 @@ import Ide.Plugin.Eval.Types (Language (Plain), Loc, Located (..), Section (sectionLanguage), Test (..), Txt, locate, locate0) -import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), - SemanticTokenRelative (..)) +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 @@ -71,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 93ae630c74..2287200697 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -125,12 +125,9 @@ 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 hiding - (SemanticTokenAbsolute (..), - SemanticTokenRelative (..), - codeLens, id, - text) +import Language.LSP.Protocol.Types import Language.LSP.Server import Language.LSP.VFS (virtualFileText) @@ -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 88be21c961..faea9e32e6 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 @@ -38,9 +38,8 @@ import Development.IDE (Position, import Development.IDE.Types.Location (Position (..)) import GHC.Generics hiding (UInt, to) import Ide.Plugin.Eval.Types -import Language.LSP.Protocol.Types hiding - (SemanticTokenAbsolute (..), - SemanticTokenRelative (..)) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types import qualified Text.Megaparsec as P import Text.Megaparsec @@ -125,8 +124,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) -> @@ -148,8 +147,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) = @@ -206,7 +205,7 @@ parseBlockMaybe isLhs blockRange p i = st { statePosState = (statePosState st) - { pstateSourcePos = positionToSourcePos $ blockRange ^. start + { pstateSourcePos = positionToSourcePos $ blockRange ^. L.start } } p @@ -331,8 +330,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 @@ -421,7 +420,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 = @@ -569,5 +568,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/Util.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs index c94952912e..f8e44fa19e 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -72,7 +72,7 @@ response' act = do `catchAny` showErr case res of Left e -> - return $ Left (ResponseError ErrorCodes_InternalError (fromString e) Nothing) + return $ Left (ResponseError (InR ErrorCodes_InternalError) (fromString e) Nothing) Right a -> do _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ()) return $ Right Null diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index de147ef227..d903421d4f 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/plugins/hls-eval-plugin/test/Main.hs @@ -24,9 +24,9 @@ import qualified Ide.Plugin.Eval as Eval import Ide.Plugin.Eval.Types (EvalParams (..), Section (..), testOutput) import Ide.Types (IdePlugins (IdePlugins)) -import Language.LSP.Protocol.Message hiding (error) -import Language.LSP.Protocol.Types (arguments, command, range, +import Language.LSP.Protocol.Lens (arguments, command, range, title) +import Language.LSP.Protocol.Message hiding (error) import System.FilePath (()) import Test.Hls 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 33af9991c6..b211bcf37d 100644 --- a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs +++ b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs @@ -34,7 +34,7 @@ import Ide.PluginUtils (getNormalizedFilePath, import Ide.TempLSPTypeFunctions (maybeToNull) import Ide.Types hiding (pluginId) import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding (hover) +import Language.LSP.Protocol.Types descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder pluginId = (defaultPluginDescriptor pluginId) From 1c75cd62c97af4eb3cf7782a70bdcae24e67b224 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 6 Jun 2023 22:50:28 +0300 Subject: [PATCH 22/70] explicit-imports compile --- .../hls-explicit-imports-plugin.cabal | 1 + .../src/Ide/Plugin/ExplicitImports.hs | 46 ++++++++++--------- .../hls-explicit-imports-plugin/test/Main.hs | 13 +++--- 3 files changed, 33 insertions(+), 27 deletions(-) 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 44a7eb3ac4..fe8a7c8365 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -54,3 +54,4 @@ test-suite tests , hls-explicit-imports-plugin , hls-test-utils , text + , lsp-types 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..ed9ff11cca 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 [] -------------------------------------------------------------------------------- @@ -266,15 +267,18 @@ extractMinimalImports (Just hsc) (Just TcModuleResult {..}) = do not $ any (\e -> ("module " ++ moduleNameString name) == e) exports extractMinimalImports _ _ = return ([], Nothing) + +#if MIN_VERSION_ghc (9,5,0) mkExplicitEdit :: (ModuleName -> Bool) -> PositionMapping -> LImportDecl GhcRn -> T.Text -> Maybe TextEdit mkExplicitEdit pred posMapping (L (locA -> src) imp) explicit -- Explicit import list case -#if MIN_VERSION_ghc (9,5,0) - | ImportDecl {ideclImportList = Just (Exactly, _)} <- imp = + | ImportDecl {ideclImportList = Just (Exactly, _)} <- imp = Nothing #else - | ImportDecl {ideclHiding = Just (False, _)} <- imp = +mkExplicitEdit :: (ModuleName -> Bool) -> PositionMapping -> LImportDecl GhcRn -> T.Text -> Maybe TextEdit +mkExplicitEdit pred posMapping (L (locA -> src) imp) explicit + -- Explicit import list case + | ImportDecl {ideclHiding = Just (False, _)} <- imp = Nothing #endif - Nothing | not (isQualifiedImport imp), RealSrcSpan l _ <- src, L _ mn <- ideclName imp, @@ -298,10 +302,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 () From cc95de4027024d27bebd697e8749e33b8bd7e0b1 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 6 Jun 2023 22:55:11 +0300 Subject: [PATCH 23/70] explicit-fields compile --- .../src/Ide/Plugin/ExplicitFields.hs | 35 +++++++++---------- 1 file changed, 17 insertions(+), 18 deletions(-) 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 12a0791b6c..db15a3c276 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,9 +21,9 @@ import Control.Monad.Trans.Except (ExceptT) import Data.Functor ((<&>)) import Data.Generics (GenericQ, everything, extQ, mkQ) -import qualified Data.HashMap.Strict as HashMap -import Data.Maybe (isJust, listToMaybe, - maybeToList, fromMaybe) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, isJust, + listToMaybe, maybeToList) import Data.Text (Text) import Development.IDE (IdeState, NormalizedFilePath, Pretty (..), Recorder (..), @@ -36,8 +36,8 @@ import Development.IDE.Core.Shake (define, use) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat (HsConDetails (RecCon), HsRecFields (..), LPat, - Outputable, getLoc, unLoc, - recDotDot) + Outputable, getLoc, recDotDot, + unLoc) import Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns), GhcPass, HsExpr (RecordCon, rcon_flds), @@ -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 (map unExt -> 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 = From b7d15ea457e553e19b5a71bd6dcbf7f236a9ebf4 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 6 Jun 2023 22:57:29 +0300 Subject: [PATCH 24/70] floskell compiles --- .../hls-floskell-plugin/src/Ide/Plugin/Floskell.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) 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. From 5e8500df901c5019a6098c51866d55b0816f543a Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 6 Jun 2023 23:02:18 +0300 Subject: [PATCH 25/70] fourmolu compiles --- .../src/Ide/Plugin/Fourmolu.hs | 15 ++++++++------- plugins/hls-fourmolu-plugin/test/Main.hs | 4 ++-- 2 files changed, 10 insertions(+), 9 deletions(-) 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 056003cc7e..151e688acd 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 From dfc2da83cef4fd1854038aebbef9afc17d243498 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 7 Jun 2023 14:48:52 +0300 Subject: [PATCH 26/70] new orphans and fixes --- hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs | 10 ++++++++-- hls-test-utils/src/Test/Hls.hs | 1 + 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs b/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs index 1ac1c9a8a1..b1ef3400b9 100644 --- a/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs +++ b/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs @@ -11,15 +11,16 @@ module Ide.TempLSPTypeFunctions (takeLefts, dumpNulls, nullToMaybe', NullToMaybe defWindowClientCapabilities, defWorkspaceCapabilities, maybeToNull) where +import Data.Hashable import Data.Semigroup () import Data.Text (Text) import Language.LSP.Protocol.Message (LspId (IdInt, IdString)) import Language.LSP.Protocol.Types (ClientCapabilities (ClientCapabilities), GeneralClientCapabilities (GeneralClientCapabilities), - Int32, + Int32, Location, NotebookDocumentClientCapabilities (NotebookDocumentClientCapabilities), NotebookDocumentSyncClientCapabilities (NotebookDocumentSyncClientCapabilities), - Null (Null), + Null (Null), Position, Range, TextDocumentClientCapabilities (TextDocumentClientCapabilities), WindowClientCapabilities (WindowClientCapabilities), WorkspaceClientCapabilities (WorkspaceClientCapabilities), @@ -53,7 +54,12 @@ instance Semigroup s => Semigroup (s |? Null) where instance Semigroup WorkspaceEdit where (WorkspaceEdit a b c) <> (WorkspaceEdit a' b' c') = WorkspaceEdit (a <> a') (b <> b') (c <> c') +instance Monoid WorkspaceEdit where + mempty = WorkspaceEdit Nothing Nothing Nothing +instance Hashable Location +instance Hashable Range +instance Hashable Position class NullToMaybe a b where nullToMaybe' :: a -> Maybe b diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index ea4df83ed2..336c013e03 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -13,6 +13,7 @@ module Test.Hls module Test.Tasty.ExpectedFailure, module Test.Hls.Util, module Language.LSP.Protocol.Types, + module Language.LSP.Protocol.Message, module Language.LSP.Test, module Control.Monad.IO.Class, module Control.Applicative.Combinators, From 4fc8fece5a367fed941de7684057dbddcb91b2c6 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 7 Jun 2023 14:49:16 +0300 Subject: [PATCH 27/70] cabal-fmt compiles --- .../hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) 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 1b1ac46aec..807179872d 100644 --- a/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs +++ b/plugins/hls-cabal-fmt-plugin/src/Ide/Plugin/CabalFmt.hs @@ -9,8 +9,9 @@ import qualified Data.Text as T import Development.IDE hiding (pluginHandlers) import Ide.PluginUtils import Ide.Types -import Language.LSP.Protocol.Message as J -import Language.LSP.Protocol.Types as J +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 @@ -46,7 +47,7 @@ descriptor recorder plId = provider :: Recorder (WithPriority Log) -> FormattingHandler IdeState provider recorder _ (FormatRange _) _ _ _ = do logWith recorder Info LogInvalidInvocationInfo - pure $ Left (ResponseError ErrorCodes_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 ErrorCodes_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 $ InL fmtDiff Nothing -> do log Error LogCabalFmtNotFound - pure $ Left (ResponseError ErrorCodes_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 From c7386e66ee1cb885f904d209fa1cc6e4b55ad491 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 7 Jun 2023 14:53:59 +0300 Subject: [PATCH 28/70] refactor-plugin compiles --- .../src/Development/IDE/GHC/ExactPrint.hs | 3 +- .../src/Development/IDE/Plugin/CodeAction.hs | 78 ++++++++++--------- .../Development/IDE/Plugin/CodeAction/Args.hs | 23 +++--- .../IDE/Plugin/CodeAction/ExactPrint.hs | 4 +- .../IDE/Plugin/CodeAction/PositionIndexed.hs | 4 +- .../IDE/Plugin/Plugins/AddArgument.hs | 10 +-- .../IDE/Plugin/Plugins/FillHole.hs | 2 +- .../IDE/Plugin/Plugins/FillTypeWildcard.hs | 5 +- .../IDE/Plugin/Plugins/ImportUtils.hs | 10 +-- plugins/hls-refactor-plugin/test/Main.hs | 56 ++++++------- .../test/Test/AddArgument.hs | 4 +- 11 files changed, 101 insertions(+), 98 deletions(-) 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 a265a1b505..a3a13a84f0 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 6e21a129dc..e6f00e21e5 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 @@ -106,8 +106,8 @@ import GHC (AddEpAnn (Ad DeltaPos (..), EpAnn (..), EpaLocation (..), - hsmodAnn, - LEpaComment) + LEpaComment, + hsmodAnn) #else import Language.Haskell.GHC.ExactPrint.Types (Annotation (annsDP), DeltaPos, @@ -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 ------------------------------------------------------------------------------------------------- @@ -152,7 +152,7 @@ iePluginDescriptor recorder plId = , wrap suggestNewImport ] 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 $ @@ -199,10 +199,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 " @@ -210,8 +210,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 {..} @@ -248,7 +248,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 @@ -492,14 +492,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{..} @@ -507,7 +507,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] @@ -536,24 +536,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{..} @@ -561,7 +561,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]) @@ -1607,11 +1607,10 @@ findPositionAfterModuleName ps hsmodName' = do epaLocationToLine :: EpaLocation -> Maybe Int #if MIN_VERSION_ghc(9,5,0) - epaLocationToLine (EpaSpan sp _) + epaLocationToLine (EpaSpan sp _) = Just . srcLocLine . realSrcSpanEnd $ sp #else - epaLocationToLine (EpaSpan sp) + epaLocationToLine (EpaSpan sp) = Just . srcLocLine . realSrcSpanEnd $ sp #endif - = Just . srcLocLine . realSrcSpanEnd $ sp epaLocationToLine (EpaDelta (SameLine _) priorComments) = Just $ sumCommentsOffset priorComments -- 'priorComments' contains the comments right before the current EpaLocation -- Summing line offset of priorComments is necessary, as 'line' is the gap between the last comment and @@ -1852,14 +1851,17 @@ textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCo -- | Returns the ranges for a binding in an import declaration rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range] -rangesForBindingImport ImportDecl{ #if MIN_VERSION_ghc(9,5,0) +rangesForBindingImport ImportDecl{ ideclImportList = Just (Exactly, L _ lies) + } b = + concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies #else +rangesForBindingImport ImportDecl{ ideclHiding = Just (False, L _ lies) -#endif - } b = + } b = concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies +#endif where b' = wrapOperatorInParens b rangesForBindingImport _ _ = [] 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..988ce6755a 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 @@ -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,5 @@ 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 2200d29b3c..65ad86ffe4 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,7 +87,7 @@ 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) , che " execute command" _executeCommandProvider [extendImportCommandId] @@ -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 :: @@ -1855,7 +1855,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") @@ -2309,7 +2309,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 @@ -2333,9 +2333,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 #-}" @@ -2354,9 +2354,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 #-}" @@ -2376,9 +2376,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 #-}" @@ -2399,12 +2399,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\"’") @@ -2427,9 +2427,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 #-}" @@ -2451,9 +2451,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 From 74befec7d2c682f3be2b13538c0c8732eadbf70c Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 7 Jun 2023 14:54:37 +0300 Subject: [PATCH 29/70] gadt-plugin compiles --- .../hls-gadt-plugin/src/Ide/Plugin/GADT.hs | 27 ++++++++++--------- plugins/hls-gadt-plugin/test/Main.hs | 4 +-- 2 files changed, 16 insertions(+), 15 deletions(-) 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" From 7a028588043d095c3d0486c15b287b5055fec89a Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 7 Jun 2023 14:56:01 +0300 Subject: [PATCH 30/70] hlint-plugin compiles --- .../hls-hlint-plugin/hls-hlint-plugin.cabal | 1 + .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 46 ++++++++++--------- plugins/hls-hlint-plugin/test/Main.hs | 43 +++++++++-------- 3 files changed, 47 insertions(+), 43 deletions(-) diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index 13478ead07..e149a4256a 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -95,4 +95,5 @@ test-suite tests , 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 89c07e55f1..f2a22237aa 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,15 +121,14 @@ 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), 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), @@ -192,7 +192,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 @@ -243,13 +243,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:" @@ -267,12 +269,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 @@ -403,11 +407,11 @@ 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) - = liftIO $ fmap (Right . LSP.List . map LSP.InR) $ do + = liftIO $ fmap (Right . InL . map LSP.InR) $ do allDiagnostics <- atomically $ getDiagnostics ideState let numHintsInDoc = length [diagnostic | (diagnosticNormalizedFilePath, _, diagnostic) <- allDiagnostics @@ -433,21 +437,21 @@ codeActionProvider ideState pluginId (CodeActionParams _ _ documentId _ context) else pure singleHintCodeActions | otherwise - = pure $ Right $ LSP.List [] + = pure $ Right $ InL [] where applyAllAction = let args = Just [toJSON (documentId ^. LSP.uri)] 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 @@ -461,7 +465,7 @@ diagnosticToCodeActions dynFlags fileContents pluginId documentId diagnostic , let suppressHintTextEdits = mkSuppressHintTextEdits dynFlags fileContents hint , let suppressHintWorkspaceEdit = LSP.WorkspaceEdit - (Just (Map.singleton uri (List suppressHintTextEdits))) + (Just (M.singleton uri suppressHintTextEdits)) Nothing Nothing = catMaybes @@ -481,13 +485,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] @@ -522,7 +526,7 @@ applyAllCmd recorder ide uri = 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 -- --------------------------------------------------------------------- @@ -553,7 +557,7 @@ applyOneCmd recorder ide (AOP uri 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 -> IO (Either String WorkspaceEdit) diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 17ba75046c..6a739e7e8b 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,12 @@ 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 +322,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 From 5338a4174532ea57e22ea7d4659db492b45c24a9 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 7 Jun 2023 14:56:41 +0300 Subject: [PATCH 31/70] module-name compiles --- .../hls-module-name-plugin.cabal | 1 + .../src/Ide/Plugin/ModuleName.hs | 18 ++++++++---------- plugins/hls-module-name-plugin/test/Main.hs | 10 +++++----- 3 files changed, 14 insertions(+), 15 deletions(-) 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 0472627f0a..167575e510 100644 --- a/plugins/hls-module-name-plugin/hls-module-name-plugin.cabal +++ b/plugins/hls-module-name-plugin/hls-module-name-plugin.cabal @@ -30,6 +30,7 @@ library build-depends: , aeson , base >=4.12 && <5 + , containers , directory , filepath , ghcide == 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" From 40afc8af59e122c6d4def4c67ad7902de7d36fe5 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 7 Jun 2023 14:57:18 +0300 Subject: [PATCH 32/70] ormolu-plugin compiles --- plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs | 9 +++++---- plugins/hls-ormolu-plugin/test/Main.hs | 4 ++-- 2 files changed, 7 insertions(+), 6 deletions(-) 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 From 8606cfe5a2de8a62af1dffa0fcfb7478152584c4 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 7 Jun 2023 14:58:22 +0300 Subject: [PATCH 33/70] pragmas-plugin compile --- .../src/Ide/Plugin/Pragmas.hs | 75 ++++++++++--------- plugins/hls-pragmas-plugin/test/Main.hs | 22 +++--- 2 files changed, 49 insertions(+), 48 deletions(-) diff --git a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs index c26d9cbc79..d0639a310a 100644 --- a/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs +++ b/plugins/hls-pragmas-plugin/src/Ide/Plugin/Pragmas.hs @@ -16,8 +16,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 @@ -25,9 +25,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 @@ -35,8 +36,8 @@ import qualified Text.Fuzzy as Fuzzy descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler J.STextDocumentCodeAction codeActionProvider - <> mkPluginHandler J.STextDocumentCompletion completion + { pluginHandlers = mkPluginHandler LSP.SMethod_TextDocumentCodeAction codeActionProvider + <> mkPluginHandler LSP.SMethod_TextDocumentCompletion completion , pluginPriority = ghcideCompletionsPluginPriority + 1 } @@ -47,10 +48,10 @@ type PragmaEdit = (T.Text, Pragma) data Pragma = LangExt T.Text | OptGHC T.Text deriving (Show, Eq, Ord) -codeActionProvider :: PluginMethodHandler IdeState 'J.TextDocumentCodeAction -codeActionProvider state _plId (J.CodeActionParams _ _ docId _ (J.CodeActionContext (J.List diags) _monly)) - | let J.TextDocumentIdentifier{ _uri = uri } = docId - , Just normalizedFilePath <- J.uriToNormalizedFilePath $ toNormalizedUri uri = do +codeActionProvider :: PluginMethodHandler IdeState 'LSP.Method_TextDocumentCodeAction +codeActionProvider 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 @@ -62,17 +63,17 @@ codeActionProvider state _plId (J.CodeActionParams _ _ docId _ (J.CodeActionCont let nextPragmaInfo = Pragmas.getNextPragmaInfo sessionDynFlags fileContents pedits = nubOrdOn snd . concat $ suggest 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" @@ -82,13 +83,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 @@ -101,7 +102,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 = [] @@ -174,27 +175,27 @@ 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) -> result <$> VFS.getCompletionPrefix position cnts where result (Just pfix) | "{-# language" `T.isPrefixOf` line - = J.List $ map buildCompletion + = map buildCompletion (Fuzzy.simpleFilter (VFS.prefixText pfix) allPragmas) | "{-# options_ghc" `T.isPrefixOf` line - = J.List $ map buildCompletion + = map buildCompletion (Fuzzy.simpleFilter (VFS.prefixText pfix) flags) | "{-#" `T.isPrefixOf` line - = J.List $ [ mkPragmaCompl (a <> suffix) b c + = [ mkPragmaCompl (a <> suffix) b c | (a, b, c, w) <- validPragmas, w == NewLine ] | otherwise - = J.List $ [ mkPragmaCompl (prefix <> a <> suffix) b c + = [ mkPragmaCompl (prefix <> a <> suffix) b c | (a, b, c, _) <- validPragmas, Fuzzy.test word b] where line = T.toLower $ VFS.fullLine pfix @@ -211,8 +212,8 @@ completion _ide _ complParams = do | "-}" `T.isSuffixOf` line = " #" | "}" `T.isSuffixOf` line = " #-" | otherwise = " #-}" - result Nothing = J.List [] - _ -> return $ J.List [] + result Nothing = [] + _ -> return $ [] ----------------------------------------------------------------------- @@ -249,11 +250,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 @@ -263,11 +264,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 4285062f05..2b3e9d4037 100644 --- a/plugins/hls-pragmas-plugin/test/Main.hs +++ b/plugins/hls-pragmas-plugin/test/Main.hs @@ -4,13 +4,13 @@ module Main ( main ) where -import Control.Lens ((<&>), (^.)) -import qualified Data.Text as T +import Control.Lens ((<&>), (^.)) +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 @@ -109,11 +109,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] @@ -130,7 +130,7 @@ completionSnippetTests = (\(insertText, label, detail, _) -> let input = 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]) @@ -145,7 +145,7 @@ completionTest testComment fileName te' label textFormat insertText detail [a, b item <- getCompletionByLabel label compls liftIO $ do item ^. L.label @?= label - item ^. L.kind @?= Just CiKeyword + item ^. L.kind @?= Just CompletionItemKind_Keyword item ^. L.insertTextFormat @?= textFormat item ^. L.insertText @?= insertText item ^. L.detail @?= detail From a144c09e15ca1899cbc2aee5161f9dde0a2362fd Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 7 Jun 2023 14:58:59 +0300 Subject: [PATCH 34/70] qualify-imported-names compile --- .../src/Ide/Plugin/QualifyImportedNames.hs | 153 +++++++++--------- 1 file changed, 76 insertions(+), 77 deletions(-) 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 [] From a97efe4917dbda12044e91352f3b59e778af4d22 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 7 Jun 2023 15:08:41 +0300 Subject: [PATCH 35/70] refine-imports compile --- .../src/Ide/Plugin/RefineImports.hs | 50 +++++++++---------- .../hls-refine-imports-plugin/test/Main.hs | 2 +- 2 files changed, 26 insertions(+), 26 deletions(-) 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..dadfc2f56a 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 [] -------------------------------------------------------------------------------- @@ -215,10 +213,12 @@ refineImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \RefineIm -> Maybe (Map.Map ModuleName [AvailInfo]) #if MIN_VERSION_ghc(9,5,0) filterByImport (L _ ImportDecl{ideclImportList = Just (_, L _ names)}) avails = + let #else filterByImport (L _ ImportDecl{ideclHiding = Just (_, L _ names)}) avails = + let #endif - let importedNames = S.fromList $ map (ieName . unLoc) names + importedNames = S.fromList $ map (ieName . unLoc) names res = flip Map.filter avails $ \a -> any (`S.member` importedNames) $ concatMap availNamesWithSelectors a @@ -299,10 +299,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 () From 34acc00940f110b35ed9bc6e385a5d5acb11b8ee Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 7 Jun 2023 15:09:17 +0300 Subject: [PATCH 36/70] rename-plugin compiles --- .../src/Ide/Plugin/Rename.hs | 20 ++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index f711eea36a..f77ab8abaa 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -6,9 +6,9 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE RecordWildCards #-} module Ide.Plugin.Rename (descriptor, E.Log) where @@ -17,20 +17,21 @@ import GHC.Parser.Annotation (AnnContext, AnnList, AnnParen, AnnPragma) #endif +import Compat.HieTypes import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Except -import Data.Generics import Data.Bifunctor (first) +import Data.Generics import Data.Hashable import Data.HashSet (HashSet) import qualified Data.HashSet as HS import Data.List.Extra hiding (length) import qualified Data.Map as M -import qualified Data.Set as S import Data.Maybe import Data.Mod.Word +import qualified Data.Set as S import qualified Data.Text as T import Development.IDE (Recorder, WithPriority, usePropertyAction) @@ -51,22 +52,23 @@ import Development.IDE.Types.Location import HieDb.Query import Ide.Plugin.Properties import Ide.PluginUtils +import Ide.TempLSPTypeFunctions import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import Language.LSP.Server -import Language.LSP.Types -import Compat.HieTypes 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 (TextDocumentIdentifier uri) pos _prog newNameText) = +renameProvider :: PluginMethodHandler IdeState Method_TextDocumentRename +renameProvider state pluginId (RenameParams _prog (TextDocumentIdentifier uri) pos newNameText) = pluginResponse $ do nfp <- handleUriToNfp uri directOldNames <- getNamesAtPos state nfp pos @@ -94,7 +96,7 @@ renameProvider state pluginId (RenameParams (TextDocumentIdentifier uri) pos _pr filesRefs = collectWith locToUri refs getFileEdit = flip $ getSrcEdit state . replaceRefs newName fileEdits <- mapM (uncurry getFileEdit) filesRefs - pure $ foldl' (<>) mempty fileEdits + pure $ InL $ foldl' (<>) mempty fileEdits -- | Limit renaming across modules. failWhenImportOrExport :: From c231c59be814ca6c8ffbe62a64ef0989b031d4b5 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 7 Jun 2023 15:09:55 +0300 Subject: [PATCH 37/70] retrie-plugin compiles --- .../hls-retrie-plugin/hls-retrie-plugin.cabal | 1 + .../src/Ide/Plugin/Retrie.hs | 45 ++++++++++--------- 2 files changed, 24 insertions(+), 22 deletions(-) diff --git a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal index e157db1004..94c965047c 100644 --- a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal +++ b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal @@ -32,6 +32,7 @@ library , hashable , hls-plugin-api == 2.1.0.0 , hls-refactor-plugin + , lens , lsp , lsp-types , retrie >=0.1.1.0 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 = [] From cd32951efab25518e9bd2d4aba752d492e5142d4 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 7 Jun 2023 15:17:51 +0300 Subject: [PATCH 38/70] splice-plugin compiles --- .../hls-splice-plugin/hls-splice-plugin.cabal | 1 + .../src/Ide/Plugin/Splice.hs | 27 ++++++++++--------- plugins/hls-splice-plugin/test/Main.hs | 9 ++++--- 3 files changed, 20 insertions(+), 17 deletions(-) diff --git a/plugins/hls-splice-plugin/hls-splice-plugin.cabal b/plugins/hls-splice-plugin/hls-splice-plugin.cabal index b731619473..e4bf4a1573 100644 --- a/plugins/hls-splice-plugin/hls-splice-plugin.cabal +++ b/plugins/hls-splice-plugin/hls-splice-plugin.cabal @@ -71,3 +71,4 @@ test-suite tests , hls-splice-plugin , 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 6cd0b9ab7a..7fe63f601d 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -64,15 +64,16 @@ 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 Language.LSP.Protocol.Capabilities +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 +98,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 +108,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 +187,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 +196,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 +416,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,9 +484,9 @@ 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 _) = liftIO $ - fmap (maybe (Right $ List []) Right) $ + fmap (maybe (Right $ InL []) Right) $ runMaybeT $ do fp <- MaybeT $ pure $ uriToNormalizedFilePath $ toNormalizedUri theUri ParsedModule {..} <- @@ -500,9 +501,9 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $ 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/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index d72fc8e45f..c1d91986ec 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,7 @@ 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 +103,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 From 6c32020d8e283d580ed90ba12136ba99186bc0c7 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 7 Jun 2023 15:18:17 +0300 Subject: [PATCH 39/70] stylish-haskell compiles --- .../src/Ide/Plugin/StylishHaskell.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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) From 2c3d5fdebf76015441f9fc19bb49b33bce66ae2c Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 7 Jun 2023 15:18:39 +0300 Subject: [PATCH 40/70] exe compiles --- exe/Main.hs | 60 +++++++++++++++++++++++++------------------------- exe/Wrapper.hs | 24 +++++++++++--------- 2 files changed, 43 insertions(+), 41 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index c519bdd5ea..64c5321aee 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -5,37 +5,37 @@ {-# 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 (Debug, 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 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 (Debug, 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 #if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter (Pretty (pretty), vsep) +import Prettyprinter (Pretty (pretty), vsep) #else -import Data.Text.Prettyprint.Doc (Pretty (pretty), vsep) +import Data.Text.Prettyprint.Doc (Pretty (pretty), vsep) #endif data Log @@ -59,7 +59,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..6871bd26dd 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -54,16 +54,18 @@ import Development.IDE.Types.Logger (Doc, Logger (Logger), toCologActionWithPrio) import GHC.Stack.Types (emptyCallStack) import Ide.Plugin.Config (Config) +import Ide.TempLSPTypeFunctions 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 +290,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 +316,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 From 58605c980e09789b8cfd3552a70bb1133c65b95a Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 8 Jun 2023 15:49:20 +0300 Subject: [PATCH 41/70] ghc 9.0 codepath fixes --- ghcide/src/Development/IDE/Core/Compile.hs | 1 + ghcide/src/Development/IDE/LSP/Outline.hs | 2 +- plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs | 3 ++- .../src/Development/IDE/Plugin/Plugins/AddArgument.hs | 2 +- 4 files changed, 5 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 872dd04712..28b73d0795 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 diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index 7c44a73e80..2ee19efff5 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -145,7 +145,7 @@ 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 = SymbolKind_Field 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 2eca5fa513..90ccc6b578 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/ExactPrint.hs @@ -21,6 +21,7 @@ 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) @@ -75,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-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/AddArgument.hs index 988ce6755a..c9160a5e9a 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) From a62937fe088063cd359f90fb4714c8d5dd5b0a15 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 8 Jun 2023 15:50:43 +0300 Subject: [PATCH 42/70] haddock-comments compile --- .../src/Ide/Plugin/HaddockComments.hs | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) 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 From c9997cbaa2bbb01b356b02614c6501b56059943c Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 8 Jun 2023 15:51:37 +0300 Subject: [PATCH 43/70] tactics-old compiles --- .../new/src/Wingman/AbstractLSP.hs | 14 ++++---- .../new/src/Wingman/LanguageServer.hs | 16 +++++----- .../src/Wingman/LanguageServer/Metaprogram.hs | 4 +-- .../new/src/Wingman/Plugin.hs | 4 +-- plugins/hls-tactics-plugin/new/test/Utils.hs | 8 ++--- .../old/src/Wingman/AbstractLSP.hs | 31 +++++++++--------- .../old/src/Wingman/AbstractLSP/Types.hs | 2 +- .../old/src/Wingman/EmptyCase.hs | 4 +-- .../old/src/Wingman/LanguageServer.hs | 32 +++++++++---------- .../src/Wingman/LanguageServer/Metaprogram.hs | 14 ++++---- .../Wingman/LanguageServer/TacticProviders.hs | 4 +-- .../src/Wingman/Metaprogramming/ProofState.hs | 2 +- .../old/src/Wingman/Plugin.hs | 6 ++-- plugins/hls-tactics-plugin/old/test/Utils.hs | 8 ++--- 14 files changed, 76 insertions(+), 73 deletions(-) diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP.hs index 000e2f3740..f98046e123 100644 --- a/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP.hs +++ b/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP.hs @@ -59,9 +59,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 ------------------------------------------------------------------------------ @@ -89,7 +89,7 @@ runContinuation runContinuation plId cont state (fc, b) = do fromMaybeT (Left $ ResponseError - { _code = InternalError + { _code = ErrorCodes_InternalError , _message = T.pack "TODO(sandy)" , _xdata = Nothing } ) $ do @@ -114,7 +114,7 @@ runContinuation plId cont state (fc, b) = do case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_uri le_fileContext) (unTrack pm) gr of Left errs -> pure $ Just $ ResponseError - { _code = InternalError + { _code = ErrorCodes_InternalError , _message = T.pack $ show errs , _xdata = Nothing } @@ -129,7 +129,7 @@ sendEdits :: WorkspaceEdit -> MaybeT (LspM Plugin.Config) () sendEdits edits = void $ lift $ sendRequest - SWorkspaceApplyEdit + SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (const $ pure ()) @@ -174,7 +174,7 @@ codeActionProvider -> TargetArgs target -> MaybeT (LspM Plugin.Config) [(Metadata, b)] ) - -> PluginMethodHandler IdeState TextDocumentCodeAction + -> PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionProvider sort k state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do fromMaybeT (Right $ List []) $ do @@ -201,7 +201,7 @@ codeLensProvider -> TargetArgs target -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)] ) - -> PluginMethodHandler IdeState TextDocumentCodeLens + -> PluginMethodHandler IdeState Method_TextDocumentCodeLens codeLensProvider sort k state plId (CodeLensParams _ _ (TextDocumentIdentifier uri)) = do fromMaybeT (Right $ List []) $ do diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs index c382082ed0..8860d63bd9 100644 --- a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs @@ -174,9 +174,9 @@ 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 DiagnosticSeverity_Error, "error") + , (Just DiagnosticSeverity_Warning, "warning") + , (Just DiagnosticSeverity_Information, "info") , (Just DsHint, "hint") , (Nothing, "none") ] @@ -523,10 +523,10 @@ isRhsHoleWithoutWhere (unTrack -> rss) (unTrack -> tcs) = ufmSeverity :: UserFacingMessage -> MessageType -ufmSeverity NotEnoughGas = MtInfo +ufmSeverity NotEnoughGas = MessageType_Info ufmSeverity TacticErrors = MtError -ufmSeverity TimedOut = MtInfo -ufmSeverity NothingToDo = MtInfo +ufmSeverity TimedOut = MessageType_Info +ufmSeverity NothingToDo = MessageType_Info ufmSeverity (InfrastructureError _) = MtError @@ -535,7 +535,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 @@ -614,7 +614,7 @@ mkDiagnostic severity r = (Just $ InR "hole") (Just "wingman") "Hole" - (Just $ List [DtUnnecessary]) + (Just $ List [DiagnosticTag_Unnecessary]) Nothing diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/Metaprogram.hs b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/Metaprogram.hs index 272f60e1a2..6400c82db7 100644 --- a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/Metaprogram.hs +++ b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/Metaprogram.hs @@ -29,7 +29,7 @@ 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 @@ -48,7 +48,7 @@ hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurr z <- liftIO $ attempt_it rsl ctx jdg $ T.unpack program pure $ Hover { _contents = HoverContents - $ MarkupContent MkMarkdown + $ MarkupContent MarkupKind_Markdown $ either T.pack T.pack z , _range = Just $ unTrack tr_range } diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs index b55ee31ae3..ea426ce5fe 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 @@ -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/new/test/Utils.hs b/plugins/hls-tactics-plugin/new/test/Utils.hs index 85a15bb436..173217de4c 100644 --- a/plugins/hls-tactics-plugin/new/test/Utils.hs +++ b/plugins/hls-tactics-plugin/new/test/Utils.hs @@ -115,7 +115,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 @@ -151,7 +151,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 @@ -201,7 +201,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 @@ -259,5 +259,5 @@ executeCommandWithResp :: Command -> Session (ResponseMessage 'WorkspaceExecuteC 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/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs index 000e2f3740..49f5199aa7 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs @@ -24,8 +24,9 @@ import Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource(GetAnn import qualified Ide.Plugin.Config as Plugin import Ide.Types import Language.LSP.Server (LspM, sendRequest, getClientCapabilities) -import qualified Language.LSP.Types as LSP -import Language.LSP.Types hiding (CodeLens, CodeAction) +import qualified Language.LSP.Protocol.Types as LSP +import Language.LSP.Protocol.Message +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) @@ -59,9 +60,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 ------------------------------------------------------------------------------ @@ -89,7 +90,7 @@ 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 @@ -114,7 +115,7 @@ runContinuation plId cont state (fc, b) = do case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_uri le_fileContext) (unTrack pm) gr of Left errs -> pure $ Just $ ResponseError - { _code = InternalError + { _code = InR ErrorCodes_InternalError , _message = T.pack $ show errs , _xdata = Nothing } @@ -129,7 +130,7 @@ sendEdits :: WorkspaceEdit -> MaybeT (LspM Plugin.Config) () sendEdits edits = void $ lift $ sendRequest - SWorkspaceApplyEdit + SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (const $ pure ()) @@ -174,10 +175,10 @@ codeActionProvider -> TargetArgs target -> MaybeT (LspM Plugin.Config) [(Metadata, b)] ) - -> PluginMethodHandler IdeState TextDocumentCodeAction + -> PluginMethodHandler IdeState Method_TextDocumentCodeAction codeActionProvider sort k state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do - fromMaybeT (Right $ List []) $ do + fromMaybeT (Right $ InL []) $ do let fc = FileContext { fc_uri = uri , fc_range = Just $ unsafeMkCurrent range @@ -187,7 +188,7 @@ codeActionProvider sort k state plId actions <- k env args pure $ Right - $ List + $ InL $ fmap (InR . uncurry (makeCodeAction plId fc sort)) actions @@ -201,10 +202,10 @@ codeLensProvider -> TargetArgs target -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)] ) - -> PluginMethodHandler IdeState TextDocumentCodeLens + -> PluginMethodHandler IdeState Method_TextDocumentCodeLens codeLensProvider sort k state plId (CodeLensParams _ _ (TextDocumentIdentifier uri)) = do - fromMaybeT (Right $ List []) $ do + fromMaybeT (Right $ InL []) $ do let fc = FileContext { fc_uri = uri , fc_range = Nothing @@ -214,7 +215,7 @@ codeLensProvider sort k state plId actions <- k env args pure $ Right - $ List + $ InL $ fmap (uncurry3 $ makeCodeLens plId sort fc) actions @@ -239,7 +240,7 @@ makeCodeAction plId fc sort (Metadata title kind preferred) b = , _disabled = Nothing , _edit = Nothing , _command = Just cmd - , _xdata = Nothing + , _data_ = Nothing } @@ -261,6 +262,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/Types.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/Types.hs index 750bdfaa2d..59f4d507a2 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/Types.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP/Types.hs @@ -19,7 +19,7 @@ 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 Language.LSP.Protocol.Types hiding (CodeLens, CodeAction) import Wingman.LanguageServer (judgementForHole) import Wingman.Types diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/EmptyCase.hs b/plugins/hls-tactics-plugin/old/src/Wingman/EmptyCase.hs index a13d7c1a65..a896898ad5 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/EmptyCase.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/EmptyCase.hs @@ -26,7 +26,7 @@ import Development.IDE.GHC.ExactPrint import Development.IDE.Spans.LocalBindings (getLocalScope) import Ide.Types import Language.LSP.Server -import Language.LSP.Types +import Language.LSP.Protocol.Types import Prelude hiding (span) import Wingman.AbstractLSP.Types import Wingman.CodeGen (destructionFor) @@ -76,7 +76,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 ad6d1b3ca1..716c4710a8 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..9e2b07ec73 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,9 @@ 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 Ide.TempLSPTypeFunctions +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 +31,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 +49,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 02e203a1d3..b7cf36705b 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 Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.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..8dda54f43d 100644 --- a/plugins/hls-tactics-plugin/old/test/Utils.hs +++ b/plugins/hls-tactics-plugin/old/test/Utils.hs @@ -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 @@ -262,5 +262,5 @@ executeCommandWithResp :: Command -> Session (ResponseMessage 'WorkspaceExecuteC executeCommandWithResp cmd = do let args = decode $ encode $ fromJust $ cmd ^. arguments execParams = ExecuteCommandParams Nothing (cmd ^. command) args - request SWorkspaceExecuteCommand execParams + request SMethod_WorkspaceExecuteCommand execParams From 3e11e09632f0e1c233c761f1f9e141dcff3e72fe Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 8 Jun 2023 15:55:13 +0300 Subject: [PATCH 44/70] functional tests compile Now the whole project should compile on ghc 9.0 and 9.2 . ghc versions 8.10 and 9.4 and up have not yet been tested --- haskell-language-server.cabal | 1 + test/functional/Command.hs | 20 +++--- test/functional/Completion.hs | 70 ++++++++++----------- test/functional/Config.hs | 39 ++++++------ test/functional/Deferred.hs | 40 ++++++------ test/functional/Definition.hs | 12 ++-- test/functional/Diagnostic.hs | 6 +- test/functional/Format.hs | 26 ++++---- test/functional/FunctionalBadProject.hs | 2 +- test/functional/FunctionalCodeAction.hs | 40 ++++++------ test/functional/HieBios.hs | 10 +-- test/functional/Highlight.hs | 8 +-- test/functional/Progress.hs | 81 ++++++++++++------------- test/functional/Reference.hs | 2 +- test/functional/Symbol.hs | 75 +++++++++++------------ test/functional/TypeDefinition.hs | 2 +- 16 files changed, 216 insertions(+), 218 deletions(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 5cb44ce2b6..06a9c65be2 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -556,6 +556,7 @@ test-suite func-test , lsp-test , containers , unordered-containers + , row-types hs-source-dirs: test/functional test/utils 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..ddf06afe5e 100644 --- a/test/functional/Deferred.hs +++ b/test/functional/Deferred.hs @@ -3,10 +3,10 @@ {-# 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 qualified Language.LSP.Types.Lens as LSP import Test.Hls import Test.Hls.Command @@ -19,18 +19,18 @@ tests = testGroup "deferred responses" [ -- testCase "do not affect hover requests" $ runSession hlsCommand fullCaps "test/testdata" $ do -- doc <- openDoc "FuncTest.hs" "haskell" - -- id1 <- sendRequest TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing) + -- id1 <- sendRequest Method_TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing) -- skipMany anyNotification -- hoverRsp <- message :: Session HoverResponse -- liftIO $ hoverRsp ^? result . _Just . _Just . contents @?= Nothing -- liftIO $ hoverRsp ^. LSP.id @?= responseId id1 - -- id2 <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) + -- id2 <- sendRequest Method_TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) -- symbolsRsp <- skipManyTill anyNotification message :: Session DocumentSymbolsResponse -- liftIO $ symbolsRsp ^. LSP.id @?= responseId id2 - -- id3 <- sendRequest TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing) + -- id3 <- sendRequest Method_TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing) -- hoverRsp2 <- skipManyTill anyNotification message :: Session HoverResponse -- liftIO $ hoverRsp2 ^. LSP.id @?= responseId id3 @@ -39,56 +39,56 @@ tests = testGroup "deferred responses" [ -- -- Now that we have cache the following request should be instant -- let highlightParams = TextDocumentPositionParams doc (Position 7 0) Nothing - -- highlightRsp <- request TextDocumentDocumentHighlight highlightParams + -- highlightRsp <- request Method_TextDocumentDocumentHighlight highlightParams -- let (Just (List locations)) = highlightRsp ^. result -- liftIO $ locations @?= [ DocumentHighlight -- { _range = Range -- { _start = Position {_line = 7, _character = 0} -- , _end = Position {_line = 7, _character = 2} -- } - -- , _kind = Just HkWrite + -- , _kind = Just DocumentHighlightKind_Write -- } -- , DocumentHighlight -- { _range = Range -- { _start = Position {_line = 7, _character = 0} -- , _end = Position {_line = 7, _character = 2} -- } - -- , _kind = Just HkWrite + -- , _kind = Just DocumentHighlightKind_Write -- } -- , DocumentHighlight -- { _range = Range -- { _start = Position {_line = 5, _character = 6} -- , _end = Position {_line = 5, _character = 8} -- } - -- , _kind = Just HkRead + -- , _kind = Just DocumentHighlightKind_Read -- } -- , DocumentHighlight -- { _range = Range -- { _start = Position {_line = 7, _character = 0} -- , _end = Position {_line = 7, _character = 2} -- } - -- , _kind = Just HkWrite + -- , _kind = Just DocumentHighlightKind_Write -- } -- , DocumentHighlight -- { _range = Range -- { _start = Position {_line = 7, _character = 0} -- , _end = Position {_line = 7, _character = 2} -- } - -- , _kind = Just HkWrite + -- , _kind = Just DocumentHighlightKind_Write -- } -- , DocumentHighlight -- { _range = Range -- { _start = Position {_line = 5, _character = 6} -- , _end = Position {_line = 5, _character = 8} -- } - -- , _kind = Just HkRead + -- , _kind = Just DocumentHighlightKind_Read -- } -- ] 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 (InL []) -- TODO: the benefits of caching parsed modules is doubted. -- TODO: add issue link @@ -111,7 +111,7 @@ tests = testGroup "deferred responses" [ -- , _diagnostics = List -- [ Diagnostic -- (Range (Position 9 6) (Position 10 18)) - -- (Just DsInfo) + -- (Just DiagnosticSeverity_Information) -- (Just (StringValue "Redundant do")) -- (Just "hlint") -- "Redundant do\nFound:\n do putStrLn \"hello\"\nWhy not:\n putStrLn \"hello\"\n" @@ -154,17 +154,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/FunctionalBadProject.hs b/test/functional/FunctionalBadProject.hs index 6d4d68206f..667a19f568 100644 --- a/test/functional/FunctionalBadProject.hs +++ b/test/functional/FunctionalBadProject.hs @@ -31,7 +31,7 @@ tests = testGroup "behaviour on malformed projects" [ -- liftIO $ do -- length diags @?= 1 -- d ^. range @?= Range (Position 0 0) (Position 1 0) - -- d ^. severity @?= (Just DsError) + -- d ^. severity @?= (Just DiagnosticSeverity_Error) -- d ^. code @?= Nothing -- d ^. source @?= Just "bios" -- d ^. message @?= 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..f8d13e704a 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 ProgressParams + | ProgressReport ProgressParams + | ProgressEnd ProgressParams data InterestingMessage a = InterestingMessage a @@ -93,15 +92,18 @@ progressMessage :: Session ProgressMessage progressMessage = progressCreate <|> progressBegin <|> progressReport <|> progressEnd where - progressCreate = ProgressCreate . view L.params <$> message SWindowWorkDoneProgressCreate + progressCreate = ProgressCreate . view L.params <$> message SMethod_WindowWorkDoneProgressCreate progressBegin = ProgressBegin <$> satisfyMaybe (\case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Begin x))) -> Just (ProgressParams t x) + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams t x)) + | not $ isn't _workDoneProgressBegin x-> Just (ProgressParams t x) _ -> Nothing) progressReport = ProgressReport <$> satisfyMaybe (\case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (Report x))) -> Just (ProgressParams t x) + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams t x)) + | not $ isn't _workDoneProgressReport x-> Just (ProgressParams t x) _ -> Nothing) progressEnd = ProgressEnd <$> satisfyMaybe (\case - FromServerMess SProgress (NotificationMessage _ _ (ProgressParams t (End x))) -> Just (ProgressParams t x) + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams t x)) + | not $ isn't _workDoneProgressEnd x -> Just (ProgressParams t x) _ -> Nothing) interestingMessage :: Session a -> Session (InterestingMessage a) @@ -142,28 +144,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 (ProgressParams token (preview _workDoneProgressBegin -> Just params)) -> do + liftIO $ token `expectedIn` activeProgressTokens + f (delete (params ^. L.title) expectedTitles) activeProgressTokens + ProgressReport (ProgressParams token (preview _workDoneProgressBegin -> Just params)) -> 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 (ProgressParams token (preview _workDoneProgressBegin -> Just params)) -> 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..b500993f54 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, to, (^?)) 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_Variable Nothing Nothing aR aSR Nothing + b = DocumentSymbol "B" Nothing SymbolKind_Variable 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_Variable Nothing (Just "MyData") Nothing (Location testUri aR) + b = SymbolInformation "B" SymbolKind_Variable 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 From 5d4852832e7c44670140f92af6505fb729dd9ffa Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 9 Jun 2023 15:26:18 +0300 Subject: [PATCH 45/70] Cleanup of changes --- .../session-loader/Development/IDE/Session.hs | 2 +- ghcide/src/Development/IDE/Core/Compile.hs | 7 +++--- ghcide/src/Development/IDE/Core/FileStore.hs | 1 - .../Development/IDE/Core/PositionMapping.hs | 6 ++--- ghcide/src/Development/IDE/Core/Shake.hs | 5 ++--- .../src/Development/IDE/LSP/Notifications.hs | 4 ++-- ghcide/src/Development/IDE/LSP/Outline.hs | 8 +++---- ghcide/src/Development/IDE/LSP/Server.hs | 1 - .../src/Development/IDE/Plugin/Completions.hs | 4 ++-- .../IDE/Plugin/Completions/Logic.hs | 13 +++-------- .../IDE/Plugin/Completions/Types.hs | 2 +- ghcide/src/Development/IDE/Spans/AtPoint.hs | 2 +- ghcide/test/exe/Main.hs | 15 ++++++------- hls-plugin-api/src/Ide/Types.hs | 7 ++---- .../src/Ide/Plugin/Cabal/LicenseSuggest.hs | 4 ++-- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 5 +---- .../hls-call-hierarchy-plugin/test/Main.hs | 6 ++--- .../hls-code-range-plugin.cabal | 2 -- plugins/hls-code-range-plugin/test/Main.hs | 1 - .../hls-explicit-fixity-plugin/test/Main.hs | 1 - .../hls-explicit-imports-plugin.cabal | 1 - .../src/Ide/Plugin/ExplicitImports.hs | 11 ++++------ .../src/Development/IDE/Plugin/CodeAction.hs | 14 +++++------- .../IDE/Plugin/Plugins/AddArgument.hs | 1 - .../src/Ide/Plugin/RefineImports.hs | 4 +--- .../src/Ide/Plugin/Splice.hs | 1 - test/functional/Deferred.hs | 22 +++++++++---------- test/functional/FunctionalBadProject.hs | 2 +- test/functional/Symbol.hs | 8 +++---- 29 files changed, 63 insertions(+), 97 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 8777fe4846..cfc9796c33 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -79,7 +79,7 @@ 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 hiding (error, id) +import Language.LSP.Protocol.Message import Language.LSP.Server import System.Directory import qualified System.Directory.Extra as IO diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 28b73d0795..6786f0fa7d 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -134,7 +134,6 @@ import GHC (Anchor (anchor), import qualified GHC as G import GHC.Hs (LEpaComment) import qualified GHC.Types.Error as Error -import Data.Data (Proxy(Proxy)) #endif #if MIN_VERSION_ghc(9,5,0) @@ -792,9 +791,9 @@ tagDiag (w@(Reason warning), (nfp, sh, fd)) | wflag `elem` unnecessaryDeprecationWarningFlags = Just DiagnosticTag_Unnecessary requiresTag _ = Nothing - addTag :: DiagnosticTag -> Maybe ([DiagnosticTag]) -> Maybe ([DiagnosticTag]) - addTag t Nothing = Just ( [t]) - addTag t (Just ( ts)) = Just ( (t : ts)) + addTag :: DiagnosticTag -> Maybe [DiagnosticTag] -> Maybe [DiagnosticTag] + addTag t Nothing = Just [t] + addTag t (Just ts) = Just (t : ts) -- other diagnostics are left unaffected tagDiag t = t diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 82deb02dc0..89d50432cf 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -74,7 +74,6 @@ import Language.LSP.Protocol.Message (toUntypedRegistra import qualified Language.LSP.Protocol.Message as LSP import Language.LSP.Protocol.Types (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions), FileSystemWatcher (..), - WatchKind (..), _watchers) import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP diff --git a/ghcide/src/Development/IDE/Core/PositionMapping.hs b/ghcide/src/Development/IDE/Core/PositionMapping.hs index 3bf1589ede..b80e515cc2 100644 --- a/ghcide/src/Development/IDE/Core/PositionMapping.hs +++ b/ghcide/src/Development/IDE/Core/PositionMapping.hs @@ -35,8 +35,8 @@ import qualified Data.Vector.Unboxed as V import Language.LSP.Protocol.Types (Position (Position), Range (Range), TextDocumentContentChangeEvent (TextDocumentContentChangeEvent), - UInt) -import qualified Language.LSP.Protocol.Types as J + UInt, type (|?) (InL)) + -- | Either an exact position, or the range of text that was substituted data PositionResult a = PositionRange -- ^ Fields need to be non-strict otherwise bind is exponential @@ -126,7 +126,7 @@ 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 (J.InL x)) = PositionDelta +applyChange PositionDelta{..} (TextDocumentContentChangeEvent (InL x)) = PositionDelta { toDelta = toCurrent (x .! #range) (x .! #text) <=< toDelta , fromDelta = fromDelta <=< fromCurrent (x .! #range) (x .! #text) } diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 448c7145f9..067e2f501c 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -684,7 +684,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer getStateKeys :: ShakeExtras -> IO [Key] getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . state --- | Must be called in the 'Method_Initialized' handler and only once +-- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO () shakeSessionInit recorder ide@IdeState{..} = do -- Take a snapshot of the VFS - it should be empty as we've received no notifications @@ -1343,6 +1343,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 = _version diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index e57b330fb1..80b956904d 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -59,7 +59,7 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeSta descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = mconcat [ mkPluginNotificationHandler LSP.SMethod_TextDocumentDidOpen $ \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri,_version}) -> liftIO $ do - atomically $ updatePositionMapping ide (VersionedTextDocumentIdentifier _uri _version) [] + 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 @@ -127,7 +127,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId) { pluginNotificationHa setSomethingModified (VFSModified vfs) ide [toKey GetClientSettings emptyFilePath] "config change" , mkPluginNotificationHandler LSP.SMethod_Initialized $ \ide _ _ _ -> do - --------- Method_Initialize Shake session -------------------------------------------------------------------- + --------- Initialize Shake session -------------------------------------------------------------------- liftIO $ shakeSessionInit (cmapWithPrio LogShake recorder) ide --------- Set up file watchers ------------------------------------------------------------------------ diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index 2ee19efff5..64c7e14bd9 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -26,7 +26,7 @@ import Language.LSP.Server (LspM) import Language.LSP.Protocol.Types (DocumentSymbol (..), DocumentSymbolParams (DocumentSymbolParams, _textDocument), SymbolInformation, - SymbolKind (SymbolKind_Variable, SymbolKind_Field, SymbolKind_File, SymbolKind_Function, SymbolKind_Interface, SymbolKind_Method, SymbolKind_Module, SymbolKind_Object, SymbolKind_Struct, SymbolKind_TypeParameter), + SymbolKind (..), TextDocumentIdentifier (TextDocumentIdentifier), type (|?) (InL, InR), uriToFilePath, Null) import Language.LSP.Protocol.Message (ResponseError) @@ -59,7 +59,7 @@ moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentif allSymbols = case moduleSymbol of Nothing -> importSymbols <> declSymbols Just x -> - [ x { _children = Just (importSymbols <> declSymbols) + [ x { _children = Just (importSymbols <> declSymbols) } ] in @@ -107,10 +107,10 @@ documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLNam Just $ [ (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable n - , _kind = SymbolKind_Variable + , _kind = SymbolKind_Constructor , _selectionRange = realSrcSpanToRange l' #if MIN_VERSION_ghc(9,2,0) - , _children = toList <$> nonEmpty childs + , _children = toList <$> nonEmpty childs } | con <- extract_cons dd_cons , let (cs, flds) = hsConDeclsBinders con diff --git a/ghcide/src/Development/IDE/LSP/Server.hs b/ghcide/src/Development/IDE/LSP/Server.hs index 6875fac4b8..bdfe407d5b 100644 --- a/ghcide/src/Development/IDE/LSP/Server.hs +++ b/ghcide/src/Development/IDE/LSP/Server.hs @@ -44,7 +44,6 @@ requestHandler m k = LSP.requestHandler m $ \TRequestMessage{_method,_id,_params x writeChan chan $ ReactorRequest (SomeLspId _id) (trace $ LSP.runLspT env $ resp' =<< k ide _params) (LSP.runLspT env . resp' . Left) - notificationHandler :: forall (m :: Method ClientToServer Notification) c. (HasTracing (MessageParams m)) => SMethod m diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index a3d36723c5..2a1841131c 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -222,8 +222,8 @@ getCompletionsLSP ide plId allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri pure $ InL (orderedCompletions allCompletions) - _ -> return (InL $ []) - _ -> return (InL $ []) + _ -> 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 b11e242fbf..54df3b791c 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -143,13 +143,11 @@ getCContext pos pm goInline _ = Nothing importGo :: GHC.LImportDecl GhcPs -> Maybe Context -#if MIN_VERSION_ghc(9,5,0) importGo (L (locA -> r) impDecl) | pos `isInsideSrcSpan` r +#if MIN_VERSION_ghc(9,5,0) = importInline importModuleName (fmap (fmap reLoc) $ ideclImportList impDecl) #else - importGo (L (locA -> r) impDecl) - | pos `isInsideSrcSpan` r = importInline importModuleName (fmap (fmap reLoc) $ ideclHiding impDecl) #endif <|> Just (ImportContext importModuleName) @@ -160,23 +158,18 @@ getCContext pos pm -- importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context #if MIN_VERSION_ghc(9,5,0) importInline modName (Just (EverythingBut, L r _)) - | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName - | otherwise = Nothing #else importInline modName (Just (True, L r _)) +#endif | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName | otherwise = Nothing -#endif - #if MIN_VERSION_ghc(9,5,0) importInline modName (Just (Exactly, L r _)) - | pos `isInsideSrcSpan` r = Just $ ImportListContext modName - | otherwise = Nothing #else importInline modName (Just (False, L r _)) +#endif | pos `isInsideSrcSpan` r = Just $ ImportListContext modName | otherwise = Nothing -#endif importInline _ _ = Nothing occNameToComKind :: OccName -> CompletionItemKind diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs index a37b309e0a..9151e03955 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs @@ -88,7 +88,7 @@ data Provenance data CompItem = CI { compKind :: CompletionItemKind - , insertText :: T.Text -- ^ InsertTextFormat_Snippet for the completion + , insertText :: T.Text -- ^ Snippet for the completion , provenance :: Provenance -- ^ From where this item is imported from. , label :: T.Text -- ^ Label to display to the user. , typeText :: Maybe T.Text diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 9c01629cb6..c047ff4f33 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -396,7 +396,7 @@ defRowToSymbolInfo (DefRow{..}:.(modInfoSrcFile -> Just srcFile)) where kind | isVarOcc defNameOcc = SymbolKind_Variable - | isDataOcc 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 diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index fa0a725b75..411d0f39c1 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -170,14 +170,14 @@ instance Pretty Log where -- | Wait for the next progress begin step waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ _)) -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ isn't _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 SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ _)) -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ isn't _workDoneProgressEnd v -> Just () _ -> Nothing -- | Wait for all progress to be done @@ -188,7 +188,7 @@ waitForAllProgressDone = loop where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ _)) -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ isn't _workDoneProgressEnd v-> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop @@ -965,8 +965,7 @@ addSigLensesTests = defToLocation :: Definition |? ([DefinitionLink] |? Null) -> [Location] defToLocation (InL (Definition (InL l))) = [l] defToLocation (InL (Definition (InR ls))) = ls -defToLocation (InR (InL defLink)) = map (\LocationLink{_targetUri,_targetRange} -> Location _targetUri _targetRange) (toLocationLink <$> defLink) - where toLocationLink (DefinitionLink ll) = ll +defToLocation (InR (InL defLink)) = (\(DefinitionLink LocationLink{_targetUri,_targetRange}) -> Location _targetUri _targetRange) <$> defLink defToLocation (InR (InR Null)) = [] checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session () @@ -1095,7 +1094,7 @@ findDefinitionAndHoverTests = let hover = (getHover , checkHover) -- search locations expectations on results - fffL4 = fffR ^. L.start ; 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 @@ -2245,7 +2244,7 @@ outlineTests = testGroup [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 0 10) - [docSymbol "C" SymbolKind_Variable (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}"] @@ -2253,7 +2252,7 @@ outlineTests = testGroup symbols <- getDocumentSymbols docId liftIO $ symbols @?= Right [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 2 13) - [ docSymbolWithChildren' "B" SymbolKind_Variable (R 0 9 2 13) (R 0 9 0 10) + [ 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) ] diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index c1d7421f8a..f074d5db17 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -384,7 +384,7 @@ class PluginMethod Request m => PluginRequestMethod (m :: Method ClientToServer -- glorious hover box. -- -- However, sometimes only one handler of a request can realistically exist, - -- such as Method_TextDocumentFormatting, it is safe to just unconditionally report + -- such as TextDocumentFormatting, it is safe to just unconditionally report -- back one arbitrary result (arbitrary since it should only be one anyway). combineResponses :: SMethod m @@ -405,9 +405,7 @@ instance PluginMethod Request Method_TextDocumentCodeAction where instance PluginRequestMethod Method_TextDocumentCodeAction where combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _ _) (CodeActionParams _ _ _ _ context) resps = - case fmap compat $ filter wasRequested $ concat $ dumpNulls resps of - [] -> InR Null - x -> InL x + InL $ fmap compat $ filter wasRequested $ concat $ dumpNulls resps where compat :: (Command |? CodeAction) -> (Command |? CodeAction) compat x@(InL _) = x @@ -986,4 +984,3 @@ getProcessID = fromIntegral <$> P.getProcessID installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing #endif - 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 a59ce3f106..5580f2b31d 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal/LicenseSuggest.hs @@ -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 $ tedit) Nothing Nothing - in CodeAction title (Just CodeActionKind_QuickFix) (Just $ []) 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-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index b85e13962c..7a125ec687 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 @@ -93,7 +93,7 @@ construct nfp hf (ident, contexts, ssp) | Just ctx <- declInfo contexts = Just $ case ctx of Decl ClassDec span -> mkCallHierarchyItem' ident SymbolKind_Interface (renderSpan span) ssp - Decl ConDec span -> mkCallHierarchyItem' ident SymbolKind_Variable (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 @@ -168,9 +168,6 @@ 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 diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index b42149c464..678b970e57 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -59,7 +59,7 @@ prepareCallHierarchyTests = let contents = T.unlines ["data A=A"] range = mkRange 0 7 0 8 selRange = mkRange 0 7 0 8 - expected = mkCallHierarchyItemC "A" SymbolKind_Variable 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}"] @@ -164,7 +164,7 @@ prepareCallHierarchyTests = ] range = mkRange 1 13 1 26 selRange = mkRange 1 13 1 14 - expected = mkCallHierarchyItemC "A" SymbolKind_Variable range selRange + expected = mkCallHierarchyItemC "A" SymbolKind_Constructor range selRange oneCaseWithCreate contents 1 13 expected , testGroup "type signature" [ testCase "next line" $ do @@ -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 -> 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 807a2285b1..1e2dfeccad 100644 --- a/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal +++ b/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal @@ -72,5 +72,3 @@ test-suite tests , text , transformers , vector - -- Dump this once dumpNulls has gotten into lsp types - , hls-plugin-api diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index 4e521be9b2..31e9fc9ffa 100644 --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -14,7 +14,6 @@ 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 Ide.TempLSPTypeFunctions import Language.LSP.Protocol.Lens import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types diff --git a/plugins/hls-explicit-fixity-plugin/test/Main.hs b/plugins/hls-explicit-fixity-plugin/test/Main.hs index dd8455277e..344f155202 100644 --- a/plugins/hls-explicit-fixity-plugin/test/Main.hs +++ b/plugins/hls-explicit-fixity-plugin/test/Main.hs @@ -64,7 +64,6 @@ hoverTest' docName title pos expected = testCase title $ runSessionWithServer pl $ 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 fe8a7c8365..44a7eb3ac4 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -54,4 +54,3 @@ test-suite tests , hls-explicit-imports-plugin , hls-test-utils , text - , lsp-types 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 ed9ff11cca..741d3a87c3 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -267,18 +267,15 @@ extractMinimalImports (Just hsc) (Just TcModuleResult {..}) = do not $ any (\e -> ("module " ++ moduleNameString name) == e) exports extractMinimalImports _ _ = return ([], Nothing) - -#if MIN_VERSION_ghc (9,5,0) mkExplicitEdit :: (ModuleName -> Bool) -> PositionMapping -> LImportDecl GhcRn -> T.Text -> Maybe TextEdit mkExplicitEdit pred posMapping (L (locA -> src) imp) explicit -- Explicit import list case - | ImportDecl {ideclImportList = Just (Exactly, _)} <- imp = Nothing +#if MIN_VERSION_ghc (9,5,0) + | ImportDecl {ideclImportList = Just (Exactly, _)} <- imp = #else -mkExplicitEdit :: (ModuleName -> Bool) -> PositionMapping -> LImportDecl GhcRn -> T.Text -> Maybe TextEdit -mkExplicitEdit pred posMapping (L (locA -> src) imp) explicit - -- Explicit import list case - | ImportDecl {ideclHiding = Just (False, _)} <- imp = Nothing + | ImportDecl {ideclHiding = Just (False, _)} <- imp = #endif + Nothing | not (isQualifiedImport imp), RealSrcSpan l _ <- src, L _ mn <- ideclName imp, 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 e6f00e21e5..c00620f3da 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -1607,10 +1607,11 @@ findPositionAfterModuleName ps hsmodName' = do epaLocationToLine :: EpaLocation -> Maybe Int #if MIN_VERSION_ghc(9,5,0) - epaLocationToLine (EpaSpan sp _) = Just . srcLocLine . realSrcSpanEnd $ sp + epaLocationToLine (EpaSpan sp _) #else - epaLocationToLine (EpaSpan sp) = Just . srcLocLine . realSrcSpanEnd $ sp + epaLocationToLine (EpaSpan sp) #endif + = Just . srcLocLine . realSrcSpanEnd $ sp epaLocationToLine (EpaDelta (SameLine _) priorComments) = Just $ sumCommentsOffset priorComments -- 'priorComments' contains the comments right before the current EpaLocation -- Summing line offset of priorComments is necessary, as 'line' is the gap between the last comment and @@ -1851,17 +1852,14 @@ textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCo -- | Returns the ranges for a binding in an import declaration rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range] -#if MIN_VERSION_ghc(9,5,0) rangesForBindingImport ImportDecl{ +#if MIN_VERSION_ghc(9,5,0) ideclImportList = Just (Exactly, L _ lies) - } b = - concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies #else -rangesForBindingImport ImportDecl{ ideclHiding = Just (False, L _ lies) - } b = - concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies #endif + } b = + concatMap (mapMaybe srcSpanToRange . rangesForBinding' b') lies where b' = wrapOperatorInParens b rangesForBindingImport _ _ = [] 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 c9160a5e9a..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 @@ -163,5 +163,4 @@ addTyHoleToTySigArg loc (L annHsSig (HsSig xHsSig tyVarBndrs lsigTy)) = lsigTy' = hsTypeFromFunTypeAsList (insertArg loc args, res) in L annHsSig (HsSig xHsSig tyVarBndrs lsigTy') - #endif 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 dadfc2f56a..42a401e2ad 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -213,12 +213,10 @@ refineImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \RefineIm -> Maybe (Map.Map ModuleName [AvailInfo]) #if MIN_VERSION_ghc(9,5,0) filterByImport (L _ ImportDecl{ideclImportList = Just (_, L _ names)}) avails = - let #else filterByImport (L _ ImportDecl{ideclHiding = Just (_, L _ names)}) avails = - let #endif - importedNames = S.fromList $ map (ieName . unLoc) names + let importedNames = S.fromList $ map (ieName . unLoc) names res = flip Map.filter avails $ \a -> any (`S.member` importedNames) $ concatMap availNamesWithSelectors a diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 7fe63f601d..809599d79a 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -66,7 +66,6 @@ import Language.Haskell.GHC.ExactPrint (uniqueSrcSpanT) import Language.LSP.Server import Language.LSP.Protocol.Types hiding (Null) import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Capabilities import qualified Language.LSP.Protocol.Lens as J descriptor :: PluginId -> PluginDescriptor IdeState diff --git a/test/functional/Deferred.hs b/test/functional/Deferred.hs index ddf06afe5e..2df1948d08 100644 --- a/test/functional/Deferred.hs +++ b/test/functional/Deferred.hs @@ -19,18 +19,18 @@ tests = testGroup "deferred responses" [ -- testCase "do not affect hover requests" $ runSession hlsCommand fullCaps "test/testdata" $ do -- doc <- openDoc "FuncTest.hs" "haskell" - -- id1 <- sendRequest Method_TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing) + -- id1 <- sendRequest TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing) -- skipMany anyNotification -- hoverRsp <- message :: Session HoverResponse -- liftIO $ hoverRsp ^? result . _Just . _Just . contents @?= Nothing -- liftIO $ hoverRsp ^. LSP.id @?= responseId id1 - -- id2 <- sendRequest Method_TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) + -- id2 <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) -- symbolsRsp <- skipManyTill anyNotification message :: Session DocumentSymbolsResponse -- liftIO $ symbolsRsp ^. LSP.id @?= responseId id2 - -- id3 <- sendRequest Method_TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing) + -- id3 <- sendRequest TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing) -- hoverRsp2 <- skipManyTill anyNotification message :: Session HoverResponse -- liftIO $ hoverRsp2 ^. LSP.id @?= responseId id3 @@ -39,49 +39,49 @@ tests = testGroup "deferred responses" [ -- -- Now that we have cache the following request should be instant -- let highlightParams = TextDocumentPositionParams doc (Position 7 0) Nothing - -- highlightRsp <- request Method_TextDocumentDocumentHighlight highlightParams + -- highlightRsp <- request TextDocumentDocumentHighlight highlightParams -- let (Just (List locations)) = highlightRsp ^. result -- liftIO $ locations @?= [ DocumentHighlight -- { _range = Range -- { _start = Position {_line = 7, _character = 0} -- , _end = Position {_line = 7, _character = 2} -- } - -- , _kind = Just DocumentHighlightKind_Write + -- , _kind = Just HkWrite -- } -- , DocumentHighlight -- { _range = Range -- { _start = Position {_line = 7, _character = 0} -- , _end = Position {_line = 7, _character = 2} -- } - -- , _kind = Just DocumentHighlightKind_Write + -- , _kind = Just HkWrite -- } -- , DocumentHighlight -- { _range = Range -- { _start = Position {_line = 5, _character = 6} -- , _end = Position {_line = 5, _character = 8} -- } - -- , _kind = Just DocumentHighlightKind_Read + -- , _kind = Just HkRead -- } -- , DocumentHighlight -- { _range = Range -- { _start = Position {_line = 7, _character = 0} -- , _end = Position {_line = 7, _character = 2} -- } - -- , _kind = Just DocumentHighlightKind_Write + -- , _kind = Just HkWrite -- } -- , DocumentHighlight -- { _range = Range -- { _start = Position {_line = 7, _character = 0} -- , _end = Position {_line = 7, _character = 2} -- } - -- , _kind = Just DocumentHighlightKind_Write + -- , _kind = Just HkWrite -- } -- , DocumentHighlight -- { _range = Range -- { _start = Position {_line = 5, _character = 6} -- , _end = Position {_line = 5, _character = 8} -- } - -- , _kind = Just DocumentHighlightKind_Read + -- , _kind = Just HkRead -- } -- ] @@ -111,7 +111,7 @@ tests = testGroup "deferred responses" [ -- , _diagnostics = List -- [ Diagnostic -- (Range (Position 9 6) (Position 10 18)) - -- (Just DiagnosticSeverity_Information) + -- (Just DsInfo) -- (Just (StringValue "Redundant do")) -- (Just "hlint") -- "Redundant do\nFound:\n do putStrLn \"hello\"\nWhy not:\n putStrLn \"hello\"\n" diff --git a/test/functional/FunctionalBadProject.hs b/test/functional/FunctionalBadProject.hs index 667a19f568..6d4d68206f 100644 --- a/test/functional/FunctionalBadProject.hs +++ b/test/functional/FunctionalBadProject.hs @@ -31,7 +31,7 @@ tests = testGroup "behaviour on malformed projects" [ -- liftIO $ do -- length diags @?= 1 -- d ^. range @?= Range (Position 0 0) (Position 1 0) - -- d ^. severity @?= (Just DiagnosticSeverity_Error) + -- d ^. severity @?= (Just DsError) -- d ^. code @?= Nothing -- d ^. source @?= Just "bios" -- d ^. message @?= diff --git a/test/functional/Symbol.hs b/test/functional/Symbol.hs index b500993f54..4b17dcdec7 100644 --- a/test/functional/Symbol.hs +++ b/test/functional/Symbol.hs @@ -22,8 +22,8 @@ v310Tests = testGroup "3.10 hierarchical document symbols" [ Right symbs <- getDocumentSymbols doc let myData = DocumentSymbol "MyData" Nothing SymbolKind_Struct Nothing Nothing myDataR myDataSR (Just [a, b]) - a = DocumentSymbol "A" Nothing SymbolKind_Variable Nothing Nothing aR aSR Nothing - b = DocumentSymbol "B" Nothing SymbolKind_Variable Nothing Nothing bR bSR Nothing + 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" @@ -68,8 +68,8 @@ pre310Tests = testGroup "pre 3.10 symbol information" [ Left symbs <- getDocumentSymbols doc let myData = SymbolInformation "MyData" SymbolKind_Struct Nothing (Just "Symbols") Nothing (Location testUri myDataR) - a = SymbolInformation "A" SymbolKind_Variable Nothing (Just "MyData") Nothing (Location testUri aR) - b = SymbolInformation "B" SymbolKind_Variable Nothing (Just "MyData") Nothing (Location testUri bR) + 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" From cb5ab6a4cd80e29561dc163e1e81948d1307f3cc Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 9 Jun 2023 15:30:04 +0300 Subject: [PATCH 46/70] stan-plugin compiles --- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 2 +- .../hls-stan-plugin/src/Ide/Plugin/Stan.hs | 24 +++---------------- plugins/hls-stan-plugin/test/Main.hs | 4 ++-- 3 files changed, 6 insertions(+), 24 deletions(-) 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 7a125ec687..59736f139a 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 @@ -16,7 +16,7 @@ module Ide.Plugin.CallHierarchy.Internal ( import Control.Lens ((^.)) import Control.Monad.IO.Class import Data.Aeson as A -import Data.List (groupBy, singleton, sortBy) +import Data.List (groupBy, sortBy) import qualified Data.Map as M import Data.Maybe import qualified Data.Set as S diff --git a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs index 2388bf2613..2f954571dd 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 (..)) @@ -98,23 +99,4 @@ rules recorder plId = do message :: T.Text message = T.unlines $ - [ " ✲ Name: " <> inspectionName inspection, - " ✲ Description: " <> inspectionDescription inspection, - " ✲ Severity: " <> (T.pack $ show $ inspectionSeverity inspection), - " ✲ Category: " <> T.intercalate " " - (map (("#" <>) . unCategory) $ toList $ inspectionCategory inspection), - "Possible solutions:" - ] - ++ map (" - " <>) (inspectionSolution inspection) - return ( file, - ShowDiag, - LSP.Diagnostic - { _range = realSrcSpanToRange observationSrcSpan, - _severity = Just LSP.DsHint, - _code = Just (LSP.InR $ unId (inspectionId inspection)), - _source = Just "stan", - _message = message, - _relatedInformation = Nothing, - _tags = Nothing - } - ) + [ " \ No newline at end of file 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" From bbd2c44988f31083e4961ba0d712b9e1b3ab2f12 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 9 Jun 2023 15:30:05 +0300 Subject: [PATCH 47/70] cleanup --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- .../src/Development/IDE/LSP/LanguageServer.hs | 3 ++ ghcide/test/exe/Main.hs | 6 +-- .../src/Ide/TempLSPTypeFunctions.hs | 37 ++----------------- hls-plugin-api/src/Ide/Types.hs | 17 ++++++--- 5 files changed, 23 insertions(+), 42 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 067e2f501c..be98ae7993 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1332,7 +1332,7 @@ getAllDiagnostics = fmap (concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v)) . ListT.toList . STM.listT updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> STM () -updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} (changes) = +updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = STM.focus (Focus.alter f) uri positionMapping where uri = toNormalizedUri _uri diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 22421125b5..2cf121c112 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -266,6 +266,9 @@ untilMVar mvar io = void $ cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) 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 SMethod_Shutdown $ \_ resp -> do diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 411d0f39c1..24805202fb 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -170,14 +170,14 @@ instance Pretty Log where -- | Wait for the next progress begin step waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ isn't _workDoneProgressBegin v-> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ Lens.isn't _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 SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ isn't _workDoneProgressEnd v -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ Lens.isn't _workDoneProgressEnd v -> Just () _ -> Nothing -- | Wait for all progress to be done @@ -188,7 +188,7 @@ waitForAllProgressDone = loop where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ isn't _workDoneProgressEnd v-> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ Lens.isn't _workDoneProgressEnd v-> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop diff --git a/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs b/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs index b1ef3400b9..d4ee4a8538 100644 --- a/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs +++ b/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs @@ -2,8 +2,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} -module Ide.TempLSPTypeFunctions (takeLefts, dumpNulls, nullToMaybe', NullToMaybe, - toLspId, defClientCapabilities, + +module Ide.TempLSPTypeFunctions (defClientCapabilities, defGeneralClientCapabilities, defNotebookDocumentClientCapabilities, defNotebookDocumentSyncClientCapabilities, @@ -31,17 +31,7 @@ import Language.LSP.Protocol.Types (ClientCapabilities (ClientCapabi -- useful. temporarily including them here now. -takeLefts :: Foldable f => f (a |? b) -> [a] -takeLefts = foldr (\x acc -> case x of - InL x' -> x' : acc - InR _ -> acc) [] --- Especially when we want to use concat, we are not interested in nulls, --- because of this we need to filter them out -dumpNulls :: (Foldable f, NullToMaybe a b) => f a -> [b] -dumpNulls = foldr (\x acc -> case nullToMaybe' x of - Just x' -> x' : acc - Nothing -> acc) [] maybeToNull :: Maybe a -> a |? Null maybeToNull (Just x) = InL x @@ -60,27 +50,8 @@ instance Monoid WorkspaceEdit where instance Hashable Location instance Hashable Range instance Hashable Position -class NullToMaybe a b where - nullToMaybe' :: a -> Maybe b - -instance NullToMaybe (a |? Null) a where - nullToMaybe' (InL x) = Just x - nullToMaybe' (InR _) = Nothing - -instance NullToMaybe (a |? (b |? Null)) (a |? b) where - nullToMaybe' (InL x) = Just $ InL x - nullToMaybe' (InR (InL x)) = Just $ InR x - nullToMaybe' (InR (InR _)) = Nothing - -instance NullToMaybe (a |? (b |? (c |? Null))) (a |? (b |? c)) where - nullToMaybe' (InL x) = Just $ InL x - nullToMaybe' (InR (InL x)) = Just $ InR $ InL x - nullToMaybe' (InR (InR (InL x))) = Just $ InR $ InR x - nullToMaybe' (InR (InR (InR _))) = Nothing - -toLspId :: (Int32 |? Text) -> LspId a -toLspId (InL x) = IdInt x -toLspId (InR y) = IdString y + + -- TODO: Find some saner default ClientCapabilities so we don't need to -- use Nothing 54 times. diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index f074d5db17..118089dcd1 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 @@ -405,7 +405,7 @@ instance PluginMethod Request Method_TextDocumentCodeAction where instance PluginRequestMethod Method_TextDocumentCodeAction where combineResponses _method _config (ClientCapabilities _ textDocCaps _ _ _ _) (CodeActionParams _ _ _ _ context) resps = - InL $ fmap compat $ filter wasRequested $ concat $ dumpNulls resps + InL $ fmap compat $ filter wasRequested $ concat $ mapMaybe nullToMaybe $ toList resps where compat :: (Command |? CodeAction) -> (Command |? CodeAction) compat x@(InL _) = x @@ -555,14 +555,14 @@ instance PluginRequestMethod Method_TextDocumentReferences 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 xs + combineResponses _ _ _ _ xs = InL $ mconcat $ takeLefts $ toList xs instance PluginRequestMethod Method_TextDocumentCodeLens where instance PluginRequestMethod Method_TextDocumentRename where instance PluginRequestMethod Method_TextDocumentHover where - combineResponses _ _ _ _ (dumpNulls -> hs :: [Hover]) = + combineResponses _ _ _ _ (mapMaybe nullToMaybe . toList -> hs :: [Hover]) = if mcontent ^. L.value == "" then InR Null else InL $ Hover (InL mcontent) r @@ -579,7 +579,7 @@ instance PluginRequestMethod Method_TextDocumentDocumentSymbol where uri' = params ^. L.textDocument . L.uri supportsHierarchy = Just True == (tdc >>= _documentSymbol >>= _hierarchicalDocumentSymbolSupport) dsOrSi :: [Either [SymbolInformation] [DocumentSymbol]] - dsOrSi = toEither <$> dumpNulls xs + dsOrSi = toEither <$> mapMaybe nullToMaybe' (toList xs) res :: [SymbolInformation] |? ([DocumentSymbol] |? Null) res | supportsHierarchy = InR $ InL $ concatMap (either (fmap siToDs) id) dsOrSi @@ -662,6 +662,13 @@ instance PluginRequestMethod Method_CallHierarchyOutgoingCalls 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 -- --------------------------------------------------------------------- From 39ceb5ca74d366c76b85769cae64815889b89105 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 9 Jun 2023 20:33:03 +0300 Subject: [PATCH 48/70] revert new-wingman changes as that's dead code also update the lsp we are tracking --- cabal.project | 6 +++--- .../new/src/Wingman/AbstractLSP.hs | 14 +++++++------- .../new/src/Wingman/LanguageServer.hs | 16 ++++++++-------- .../src/Wingman/LanguageServer/Metaprogram.hs | 4 ++-- .../hls-tactics-plugin/new/src/Wingman/Plugin.hs | 2 +- plugins/hls-tactics-plugin/new/test/Utils.hs | 8 ++++---- 6 files changed, 25 insertions(+), 25 deletions(-) diff --git a/cabal.project b/cabal.project index 56c58396ce..147e8d957e 100644 --- a/cabal.project +++ b/cabal.project @@ -95,17 +95,17 @@ source-repository-package source-repository-package type:git location: https://github.com/joyfulmantis/lsp - tag: 395018160475a37f51e2ec8222e763bb92592506 + tag: 078340365ef8a336d22386c398209818e9b96734 subdir: lsp source-repository-package type:git location: https://github.com/joyfulmantis/lsp - tag: 395018160475a37f51e2ec8222e763bb92592506 + tag: 078340365ef8a336d22386c398209818e9b96734 subdir: lsp-types source-repository-package type:git location: https://github.com/joyfulmantis/lsp - tag: 395018160475a37f51e2ec8222e763bb92592506 + tag: 078340365ef8a336d22386c398209818e9b96734 subdir: lsp-test diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP.hs index f98046e123..000e2f3740 100644 --- a/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP.hs +++ b/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP.hs @@ -59,9 +59,9 @@ buildHandlers cs = flip foldMap cs $ \(Interaction (c :: Continuation sort target b)) -> case c_makeCommand c of SynthesizeCodeAction k -> - mkPluginHandler SMethod_TextDocumentCodeAction $ codeActionProvider @target (c_sort c) k + mkPluginHandler STextDocumentCodeAction $ codeActionProvider @target (c_sort c) k SynthesizeCodeLens k -> - mkPluginHandler SMethod_TextDocumentCodeLens $ codeLensProvider @target (c_sort c) k + mkPluginHandler STextDocumentCodeLens $ codeLensProvider @target (c_sort c) k ------------------------------------------------------------------------------ @@ -89,7 +89,7 @@ runContinuation runContinuation plId cont state (fc, b) = do fromMaybeT (Left $ ResponseError - { _code = ErrorCodes_InternalError + { _code = InternalError , _message = T.pack "TODO(sandy)" , _xdata = Nothing } ) $ do @@ -114,7 +114,7 @@ runContinuation plId cont state (fc, b) = do case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_uri le_fileContext) (unTrack pm) gr of Left errs -> pure $ Just $ ResponseError - { _code = ErrorCodes_InternalError + { _code = InternalError , _message = T.pack $ show errs , _xdata = Nothing } @@ -129,7 +129,7 @@ sendEdits :: WorkspaceEdit -> MaybeT (LspM Plugin.Config) () sendEdits edits = void $ lift $ sendRequest - SMethod_WorkspaceApplyEdit + SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (const $ pure ()) @@ -174,7 +174,7 @@ codeActionProvider -> TargetArgs target -> MaybeT (LspM Plugin.Config) [(Metadata, b)] ) - -> PluginMethodHandler IdeState Method_TextDocumentCodeAction + -> PluginMethodHandler IdeState TextDocumentCodeAction codeActionProvider sort k state plId (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do fromMaybeT (Right $ List []) $ do @@ -201,7 +201,7 @@ codeLensProvider -> TargetArgs target -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)] ) - -> PluginMethodHandler IdeState Method_TextDocumentCodeLens + -> PluginMethodHandler IdeState TextDocumentCodeLens codeLensProvider sort k state plId (CodeLensParams _ _ (TextDocumentIdentifier uri)) = do fromMaybeT (Right $ List []) $ do diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs index 8860d63bd9..c382082ed0 100644 --- a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs @@ -174,9 +174,9 @@ 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 DiagnosticSeverity_Error, "error") - , (Just DiagnosticSeverity_Warning, "warning") - , (Just DiagnosticSeverity_Information, "info") + [ (Just DsError, "error") + , (Just DsWarning, "warning") + , (Just DsInfo, "info") , (Just DsHint, "hint") , (Nothing, "none") ] @@ -523,10 +523,10 @@ isRhsHoleWithoutWhere (unTrack -> rss) (unTrack -> tcs) = ufmSeverity :: UserFacingMessage -> MessageType -ufmSeverity NotEnoughGas = MessageType_Info +ufmSeverity NotEnoughGas = MtInfo ufmSeverity TacticErrors = MtError -ufmSeverity TimedOut = MessageType_Info -ufmSeverity NothingToDo = MessageType_Info +ufmSeverity TimedOut = MtInfo +ufmSeverity NothingToDo = MtInfo ufmSeverity (InfrastructureError _) = MtError @@ -535,7 +535,7 @@ mkShowMessageParams ufm = ShowMessageParams (ufmSeverity ufm) $ T.pack $ show uf showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m () -showLspMessage = sendNotification SMethod_WindowShowMessage +showLspMessage = sendNotification SWindowShowMessage -- This rule only exists for generating file diagnostics @@ -614,7 +614,7 @@ mkDiagnostic severity r = (Just $ InR "hole") (Just "wingman") "Hole" - (Just $ List [DiagnosticTag_Unnecessary]) + (Just $ List [DtUnnecessary]) Nothing diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/Metaprogram.hs b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/Metaprogram.hs index 6400c82db7..272f60e1a2 100644 --- a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/Metaprogram.hs +++ b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/Metaprogram.hs @@ -29,7 +29,7 @@ import Wingman.Types ------------------------------------------------------------------------------ -- | Provide the "empty case completion" code lens -hoverProvider :: PluginMethodHandler IdeState Method_TextDocumentHover +hoverProvider :: PluginMethodHandler IdeState TextDocumentHover hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurrent -> pos) _) | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do let loc = fmap (realSrcLocSpan . positionToRealSrcLoc nfp) pos @@ -48,7 +48,7 @@ hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurr z <- liftIO $ attempt_it rsl ctx jdg $ T.unpack program pure $ Hover { _contents = HoverContents - $ MarkupContent MarkupKind_Markdown + $ MarkupContent MkMarkdown $ either T.pack T.pack z , _range = Just $ unTrack tr_range } diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs index ea426ce5fe..bbde652ae9 100644 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs @@ -35,7 +35,7 @@ descriptor recorder plId : fmap makeTacticInteraction [minBound .. maxBound] ) $ (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler SMethod_TextDocumentHover hoverProvider + { pluginHandlers = mkPluginHandler STextDocumentHover hoverProvider , pluginRules = wingmanRules (cmapWithPrio LogWingmanLanguageServer recorder) plId , pluginConfigDescriptor = defaultConfigDescriptor diff --git a/plugins/hls-tactics-plugin/new/test/Utils.hs b/plugins/hls-tactics-plugin/new/test/Utils.hs index 173217de4c..85a15bb436 100644 --- a/plugins/hls-tactics-plugin/new/test/Utils.hs +++ b/plugins/hls-tactics-plugin/new/test/Utils.hs @@ -115,7 +115,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 SMethod_WorkspaceApplyEdit + void $ skipManyTill anyMessage $ message SWorkspaceApplyEdit _ -> error $ show actions @@ -151,7 +151,7 @@ mkCodeLensTest input = lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc for_ lenses $ \(CodeLens _ (Just cmd) _) -> executeCommand cmd - _resp <- skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) + _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) edited <- documentContents doc let expected_name = input <.> "expected" <.> "hs" -- Write golden tests if they don't already exist @@ -201,7 +201,7 @@ mkShowMessageTest tc occ line col input ufm = Just (InR CodeAction {_command = Just c}) <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions executeCommand c - TNotificationMessage _ _ err <- skipManyTill anyMessage (message SMethod_WindowShowMessage) + NotificationMessage _ _ err <- skipManyTill anyMessage (message SWindowShowMessage) liftIO $ err `shouldBe` mkShowMessageParams ufm @@ -259,5 +259,5 @@ executeCommandWithResp :: Command -> Session (ResponseMessage 'WorkspaceExecuteC executeCommandWithResp cmd = do let args = decode $ encode $ fromJust $ cmd ^. arguments execParams = ExecuteCommandParams Nothing (cmd ^. command) args - request SMethod_WorkspaceExecuteCommand execParams + request SWorkspaceExecuteCommand execParams From 9a361d049069bae3e73f6db345f8135402ee2613 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 9 Jun 2023 23:12:03 +0300 Subject: [PATCH 49/70] Move lsp functions & instances to the lsp package --- cabal.project | 6 +- exe/Wrapper.hs | 1 - ghcide/src/Development/IDE/Core/Shake.hs | 5 +- .../src/Development/IDE/LSP/LanguageServer.hs | 1 - hls-plugin-api/hls-plugin-api.cabal | 1 - .../src/Ide/TempLSPTypeFunctions.hs | 94 ------------------- hls-plugin-api/src/Ide/Types.hs | 1 - hls-test-utils/src/Test/Hls/Util.hs | 11 +-- .../src/Ide/Plugin/ExplicitFixity.hs | 1 - .../src/Ide/Plugin/Rename.hs | 1 - .../src/Wingman/LanguageServer/Metaprogram.hs | 1 - 11 files changed, 9 insertions(+), 114 deletions(-) delete mode 100644 hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs diff --git a/cabal.project b/cabal.project index 147e8d957e..f2f0bcd186 100644 --- a/cabal.project +++ b/cabal.project @@ -95,17 +95,17 @@ source-repository-package source-repository-package type:git location: https://github.com/joyfulmantis/lsp - tag: 078340365ef8a336d22386c398209818e9b96734 + tag: 75826fbf344d62b59532008c190e72927158ea7a subdir: lsp source-repository-package type:git location: https://github.com/joyfulmantis/lsp - tag: 078340365ef8a336d22386c398209818e9b96734 + tag: 75826fbf344d62b59532008c190e72927158ea7a subdir: lsp-types source-repository-package type:git location: https://github.com/joyfulmantis/lsp - tag: 078340365ef8a336d22386c398209818e9b96734 + tag: 75826fbf344d62b59532008c190e72927158ea7a subdir: lsp-test diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 6871bd26dd..6bebc98923 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -54,7 +54,6 @@ import Development.IDE.Types.Logger (Doc, Logger (Logger), toCologActionWithPrio) import GHC.Stack.Types (emptyCallStack) import Ide.Plugin.Config (Config) -import Ide.TempLSPTypeFunctions import Ide.Types (IdePlugins (IdePlugins)) import Language.LSP.Protocol.Message (Method (Method_Initialize), ResponseError, diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index be98ae7993..4ba1090087 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -163,7 +163,6 @@ import GHC.Stack (HasCallStack) import HieDb.Types import Ide.Plugin.Config import qualified Ide.PluginUtils as HLS -import Ide.TempLSPTypeFunctions import Ide.Types (IdePlugins (IdePlugins), PluginDescriptor (pluginId), PluginId) @@ -639,9 +638,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins logger debouncer else noProgressReporting actionQueue <- newQueue - let -- TODO: Find some saner default ClientCapabilities so we don't need to - -- use Nothing 54 times. - clientCapabilities = maybe defClientCapabilities LSP.resClientCapabilities lspEnv + let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv dirtyKeys <- newTVarIO mempty -- Take one VFS snapshot at the start vfsVar <- newTVarIO =<< vfsSnapshot lspEnv diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 2cf121c112..3593b2aa0b 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -44,7 +44,6 @@ import qualified Development.IDE.Session as Session import Development.IDE.Types.Logger import qualified Development.IDE.Types.Logger as Logger import Development.IDE.Types.Shake (WithHieDb) -import Ide.TempLSPTypeFunctions import Language.LSP.Server (LanguageContextEnv, LspServerLog, type (<~>)) diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index ad3216027c..2762f335ff 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -38,7 +38,6 @@ library Ide.Plugin.ConfigUtils Ide.Plugin.Properties Ide.Plugin.RangeMap - Ide.TempLSPTypeFunctions Ide.PluginUtils Ide.Types diff --git a/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs b/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs deleted file mode 100644 index d4ee4a8538..0000000000 --- a/hls-plugin-api/src/Ide/TempLSPTypeFunctions.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} - -module Ide.TempLSPTypeFunctions (defClientCapabilities, - defGeneralClientCapabilities, - defNotebookDocumentClientCapabilities, - defNotebookDocumentSyncClientCapabilities, - defTextDocumentCapabilities, - defWindowClientCapabilities, - defWorkspaceCapabilities, maybeToNull) where - -import Data.Hashable -import Data.Semigroup () -import Data.Text (Text) -import Language.LSP.Protocol.Message (LspId (IdInt, IdString)) -import Language.LSP.Protocol.Types (ClientCapabilities (ClientCapabilities), - GeneralClientCapabilities (GeneralClientCapabilities), - Int32, Location, - NotebookDocumentClientCapabilities (NotebookDocumentClientCapabilities), - NotebookDocumentSyncClientCapabilities (NotebookDocumentSyncClientCapabilities), - Null (Null), Position, Range, - TextDocumentClientCapabilities (TextDocumentClientCapabilities), - WindowClientCapabilities (WindowClientCapabilities), - WorkspaceClientCapabilities (WorkspaceClientCapabilities), - WorkspaceEdit (WorkspaceEdit), - type (|?) (..)) - --- The functions below may be added to the lsp-types package if they end up being --- useful. temporarily including them here now. - - - - -maybeToNull :: Maybe a -> a |? Null -maybeToNull (Just x) = InL x -maybeToNull Nothing = InR Null -instance Semigroup s => Semigroup (s |? Null) where - InL x <> InL y = InL (x <> y) - InL x <> InR _ = InL x - InR _ <> InL x = InL x - InR _ <> InR y = InR y - -instance Semigroup WorkspaceEdit where - (WorkspaceEdit a b c) <> (WorkspaceEdit a' b' c') = WorkspaceEdit (a <> a') (b <> b') (c <> c') -instance Monoid WorkspaceEdit where - mempty = WorkspaceEdit Nothing Nothing Nothing - -instance Hashable Location -instance Hashable Range -instance Hashable Position - - - --- TODO: Find some saner default ClientCapabilities so we don't need to --- use Nothing 54 times. -defClientCapabilities :: ClientCapabilities -defClientCapabilities = - ClientCapabilities (Just defWorkspaceCapabilities) - (Just defTextDocumentCapabilities) - (Just defNotebookDocumentClientCapabilities) - (Just defWindowClientCapabilities) - (Just defGeneralClientCapabilities) - Nothing - -defWorkspaceCapabilities :: WorkspaceClientCapabilities -defWorkspaceCapabilities = - WorkspaceClientCapabilities Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing Nothing - Nothing Nothing - -defTextDocumentCapabilities :: TextDocumentClientCapabilities -defTextDocumentCapabilities = - TextDocumentClientCapabilities Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing - Nothing Nothing Nothing Nothing Nothing - -defNotebookDocumentClientCapabilities :: NotebookDocumentClientCapabilities -defNotebookDocumentClientCapabilities = - NotebookDocumentClientCapabilities defNotebookDocumentSyncClientCapabilities - -defNotebookDocumentSyncClientCapabilities :: NotebookDocumentSyncClientCapabilities -defNotebookDocumentSyncClientCapabilities = - NotebookDocumentSyncClientCapabilities Nothing Nothing - -defWindowClientCapabilities :: WindowClientCapabilities -defWindowClientCapabilities = WindowClientCapabilities Nothing Nothing Nothing - -defGeneralClientCapabilities :: GeneralClientCapabilities -defGeneralClientCapabilities = GeneralClientCapabilities Nothing Nothing Nothing Nothing diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 118089dcd1..b83e7b2eb4 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -82,7 +82,6 @@ import Development.IDE.Graph import GHC (DynFlags) import GHC.Generics import Ide.Plugin.Properties -import Ide.TempLSPTypeFunctions import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types diff --git a/hls-test-utils/src/Test/Hls/Util.hs b/hls-test-utils/src/Test/Hls/Util.hs index 85ade5421e..d361b0a8ec 100644 --- a/hls-test-utils/src/Test/Hls/Util.hs +++ b/hls-test-utils/src/Test/Hls/Util.hs @@ -63,7 +63,6 @@ import Data.List.Extra (find) import qualified Data.Set as Set import qualified Data.Text as T import Development.IDE (GhcVersion (..), ghcVersion) -import Ide.TempLSPTypeFunctions import qualified Language.LSP.Test as Test import Language.LSP.Protocol.Types import Language.LSP.Protocol.Message @@ -81,15 +80,15 @@ import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) noLiteralCaps :: ClientCapabilities -noLiteralCaps = defClientCapabilities & L.textDocument ?~ textDocumentCaps +noLiteralCaps = def & L.textDocument ?~ textDocumentCaps where - textDocumentCaps = defTextDocumentCapabilities { _codeAction = Just codeActionCaps } + textDocumentCaps = def { _codeAction = Just codeActionCaps } codeActionCaps = CodeActionClientCapabilities (Just True) Nothing Nothing Nothing Nothing Nothing Nothing codeActionSupportCaps :: ClientCapabilities -codeActionSupportCaps = defClientCapabilities & L.textDocument ?~ textDocumentCaps +codeActionSupportCaps = def & L.textDocument ?~ textDocumentCaps where - textDocumentCaps = defTextDocumentCapabilities { _codeAction = Just codeActionCaps } + textDocumentCaps = def { _codeAction = Just codeActionCaps } codeActionCaps = CodeActionClientCapabilities (Just True) (Just literalSupport) (Just True) Nothing Nothing Nothing Nothing literalSupport = #codeActionKind .== (#valueSet .== []) @@ -249,7 +248,7 @@ inspectCommand cars s = fromCommand <$> onMatch cars predicate err waitForDiagnosticsFrom :: TextDocumentIdentifier -> Test.Session [Diagnostic] waitForDiagnosticsFrom doc = do diagsNot <- skipManyTill Test.anyMessage (Test.message SMethod_TextDocumentPublishDiagnostics) - let ( diags) = diagsNot ^. L.params . L.diagnostics + let diags = diagsNot ^. L.params . L.diagnostics if doc ^. L.uri /= diagsNot ^. L.params . L.uri then waitForDiagnosticsFrom doc else return diags 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 b211bcf37d..db483d469d 100644 --- a/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs +++ b/plugins/hls-explicit-fixity-plugin/src/Ide/Plugin/ExplicitFixity.hs @@ -31,7 +31,6 @@ import GHC.Generics (Generic) import Ide.PluginUtils (getNormalizedFilePath, handleMaybeM, pluginResponse) -import Ide.TempLSPTypeFunctions (maybeToNull) import Ide.Types hiding (pluginId) import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index f77ab8abaa..669d5685be 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -52,7 +52,6 @@ import Development.IDE.Types.Location import HieDb.Query import Ide.Plugin.Properties import Ide.PluginUtils -import Ide.TempLSPTypeFunctions import Ide.Types import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types 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 9e2b07ec73..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,6 @@ import Development.IDE.Core.Shake (IdeState (..)) import Development.IDE.Core.UseStale import Development.IDE.GHC.Compat hiding (empty) import Ide.Types -import Ide.TempLSPTypeFunctions import Language.LSP.Protocol.Types import Language.LSP.Protocol.Message import Prelude hiding (span) From b244f3f747500bf05c3b5a2e1cbc83494f551ab2 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 9 Jun 2023 23:35:57 +0300 Subject: [PATCH 50/70] overload-record-dot compiles --- .../src/Ide/Plugin/OverloadedRecordDot.hs | 31 +++++++++---------- 1 file changed, 15 insertions(+), 16 deletions(-) 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 _) = From a4f2500b3648929d587e49b23c1c3dff04aec08f Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sat, 10 Jun 2023 22:50:55 +0300 Subject: [PATCH 51/70] cleanup and implementing michaelpj's suggestions --- cabal.project | 12 +---- ghcide-bench/src/Experiments.hs | 23 +++++++--- ghcide/src/Development/IDE/Core/Actions.hs | 6 +-- ghcide/src/Development/IDE/Core/Compile.hs | 11 ++--- .../Development/IDE/LSP/HoverDefinition.hs | 2 +- .../src/Development/IDE/LSP/LanguageServer.hs | 2 +- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 2 +- ghcide/src/Development/IDE/Spans/AtPoint.hs | 4 +- ghcide/test/exe/Main.hs | 46 +++++++++++++------ hls-plugin-api/src/Ide/Types.hs | 3 +- hls-test-utils/src/Test/Hls.hs | 6 +-- plugins/hls-cabal-plugin/test/Main.hs | 4 +- .../src/Ide/Plugin/CallHierarchy/Internal.hs | 6 +-- plugins/hls-hlint-plugin/test/Main.hs | 8 +++- plugins/hls-splice-plugin/test/Main.hs | 4 +- .../hls-stan-plugin/src/Ide/Plugin/Stan.hs | 21 ++++++++- test/functional/Progress.hs | 33 +++++++------ 17 files changed, 118 insertions(+), 75 deletions(-) diff --git a/cabal.project b/cabal.project index ff79028b08..bf6f251eff 100644 --- a/cabal.project +++ b/cabal.project @@ -97,17 +97,7 @@ source-repository-package type:git location: https://github.com/joyfulmantis/lsp tag: 75826fbf344d62b59532008c190e72927158ea7a - subdir: lsp -source-repository-package - type:git - location: https://github.com/joyfulmantis/lsp - tag: 75826fbf344d62b59532008c190e72927158ea7a - subdir: lsp-types -source-repository-package - type:git - location: https://github.com/joyfulmantis/lsp - tag: 75826fbf344d62b59532008c190e72927158ea7a - subdir: lsp-test + subdir: lsp lsp-types lsp-test allow-newer: diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index a8ff09a31a..422004141e 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -29,7 +29,8 @@ import Control.Applicative.Combinators (skipManyTill) import Control.Concurrent.Async (withAsync) import Control.Exception.Safe (IOException, handleAny, try) -import Control.Lens (isn't, (^.)) +import Control.Lens ((^.)) +import Control.Lens.Extras (is) import Control.Monad.Extra (allM, forM, forM_, forever, unless, void, when, whenJust, (&&^)) @@ -59,6 +60,7 @@ import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types hiding (Null, SemanticTokenAbsolute (..)) import Language.LSP.Test +import qualified Lanuguage.LSP.Protocol.Types as LSP import Numeric.Natural import Options.Applicative import System.Directory @@ -72,7 +74,9 @@ import Text.Printf charEdit :: Position -> TextDocumentContentChangeEvent charEdit p = - TextDocumentContentChangeEvent $ InL $ #range .== 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 @@ -210,7 +214,9 @@ experiments = benchWithSetup "hole fit suggestions" ( mapM_ $ \DocumentPositions{..} -> do - let edit =TextDocumentContentChangeEvent $ InL $ #range .== Range bottom bottom .+ #rangeLength .== Nothing .+ #text .== t + let edit =TextDocumentContentChangeEvent $ InL $ #range .== Range bottom bottom + .+ #rangeLength .== Nothing + .+ #text .== t bottom = Position maxBound 0 t = T.unlines ["" @@ -238,7 +244,7 @@ experiments = where hasDefinitions (InL (Definition (InL _))) = True hasDefinitions (InL (Definition (InR ls))) = not $ null ls hasDefinitions (InR (InL ds)) = not $ null ds - hasDefinitions _ = False + hasDefinitions (InR (InR LSP.Null)) = False --------------------------------------------------------------------------------------------- examplesPath :: FilePath @@ -495,7 +501,7 @@ waitForProgressDone = loop where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ isn't _workDoneProgressEnd v -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | is _workDoneProgressEnd v -> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop @@ -640,11 +646,14 @@ setupDocumentContents config = -- Setup the special positions used by the experiments lastLine <- fromIntegral . length . T.lines <$> documentContents doc - changeDoc doc [TextDocumentContentChangeEvent $ InL $ #range .== (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 - stringLiteralP = (Position lastLine 15) + stringLiteralP = Position lastLine 15 -- Find an identifier defined in another file in this project symbols <- getDocumentSymbols doc diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index b49229065f..c8e384c1b5 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -31,9 +31,7 @@ import Development.IDE.Types.HscEnvEq (hscEnv) import Development.IDE.Types.Location import qualified HieDb import Language.LSP.Protocol.Types (DocumentHighlight (..), - Null, - SymbolInformation (..), - type (|?) (..)) + SymbolInformation (..)) -- | Eventually this will lookup/generate URIs for files in dependencies, but not in the @@ -110,7 +108,7 @@ highlightAtPoint file pos = runMaybeT $ do mapMaybe toCurrentHighlight <$>AtPoint.documentHighlight hf rf pos' -- Refs are not an IDE action, so it is OK to be slow and (more) accurate -refsAtPoint :: NormalizedFilePath -> Position -> Action ([Location] |? Null) +refsAtPoint :: NormalizedFilePath -> Position -> Action [Location] refsAtPoint file pos = do ShakeExtras{withHieDb} <- getShakeExtras fs <- HM.keys <$> getFilesOfInterestUntracked diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 13d39bb886..bb036f0b33 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -782,7 +782,7 @@ 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 @@ -791,9 +791,6 @@ tagDiag (w@(Reason warning), (nfp, sh, fd)) | wflag `elem` unnecessaryDeprecationWarningFlags = Just DiagnosticTag_Unnecessary requiresTag _ = Nothing - addTag :: DiagnosticTag -> Maybe [DiagnosticTag] -> Maybe [DiagnosticTag] - addTag t Nothing = Just [t] - addTag t (Just ts) = Just (t : ts) -- other diagnostics are left unaffected tagDiag t = t @@ -950,20 +947,20 @@ indexHieFile se mod_summary srcPath !hash hf = do case style of Percentage -> LSP.WorkDoneProgressReport { _kind = LSP.AString @"report" - , _cancellable = Nothing + , _cancellable = Nothing , _message = Nothing , _percentage = Just progressPct } Explicit -> LSP.WorkDoneProgressReport { _kind = LSP.AString @"report" - , _cancellable = Nothing + , _cancellable = Nothing , _message = Just $ T.pack " (" <> T.pack (show done) <> "/" <> T.pack (show $ done + remaining) <> ")..." , _percentage = Nothing } NoProgress -> LSP.WorkDoneProgressReport { _kind = LSP.AString @"report" - , _cancellable = Nothing + , _cancellable = Nothing , _message = Nothing , _percentage = Nothing } diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index b2a7b5b5c9..fdd51a9014 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -45,7 +45,7 @@ references ide (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = liftIO logDebug (ideLogger ide) $ "References request at position " <> T.pack (showPosition pos) <> " in file: " <> T.pack path - Right <$> (runAction "references" ide $ refsAtPoint filePath pos) + 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 [SymbolInformation]) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 3593b2aa0b..5e3a8800b7 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -27,7 +27,7 @@ import Development.IDE.LSP.Server import Development.IDE.Session (runWithDb) import Ide.Types (traceWithSpan) import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding (retry) +import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP import System.IO import UnliftIO.Async diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index ecc632355d..d419710d51 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -53,7 +53,7 @@ descriptor plId = (defaultPluginDescriptor plId) <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> documentHighlight ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentReferences (\ide _ params -> references ide params) - <> mkPluginHandler SMethod_WorkspaceSymbol (\ide _ params -> (fmap InL) <$> wsSymbols ide params), + <> mkPluginHandler SMethod_WorkspaceSymbol (\ide _ params -> fmap InL <$> wsSymbols ide params), pluginConfigDescriptor = defaultConfigDescriptor } diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index c047ff4f33..37b0fbcc17 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -116,7 +116,7 @@ referencesAtPoint -> NormalizedFilePath -- ^ The file the cursor is in -> Position -- ^ position in the file -> FOIReferences -- ^ references data for FOIs - -> m ([Location] |? Null) + -> m [Location] referencesAtPoint withHieDb nfp pos refs = do -- The database doesn't have up2date references data for the FOIs so we must collect those -- from the Shake graph. @@ -135,7 +135,7 @@ referencesAtPoint withHieDb nfp pos refs = do refs <- liftIO $ withHieDb (\hieDb -> findTypeRefs hieDb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude) pure $ mapMaybe typeRowToLoc refs _ -> pure [] - pure $ InL $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs + pure $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs rowToLoc :: Res RefRow -> Maybe Location rowToLoc (row:.info) = flip Location range <$> mfile diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 24805202fb..86645c2807 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -47,6 +47,7 @@ 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) @@ -170,14 +171,14 @@ instance Pretty Log where -- | Wait for the next progress begin step waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ Lens.isn't _workDoneProgressBegin v-> 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 SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ Lens.isn't _workDoneProgressEnd v -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | Lens.is _workDoneProgressEnd v -> Just () _ -> Nothing -- | Wait for all progress to be done @@ -188,7 +189,7 @@ waitForAllProgressDone = loop where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ Lens.isn't _workDoneProgressEnd v-> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) |Lens.is _workDoneProgressEnd v-> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop @@ -282,7 +283,8 @@ 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 $ #workspaceFolders .== Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )} .+ #fileOperations .== Nothing) + , chk " workspace" (^. L.workspace) (Just $ #workspaceFolders .== Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )} + .+ #fileOperations .== Nothing) , chk "NO experimental" (^. L.experimental) Nothing ] where @@ -323,7 +325,9 @@ diagnosticTests = testGroup "diagnostics" let content = T.unlines [ "module Testing wher" ] doc <- createDoc "Testing.hs" "haskell" content 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" + 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 @@ -331,14 +335,18 @@ diagnosticTests = testGroup "diagnostics" doc <- createDoc "Testing.hs" "haskell" content void $ skipManyTill anyMessage (message SMethod_WindowWorkDoneProgressCreate) waitForProgressBegin - let change = TextDocumentContentChangeEvent$ InL $ #range .== (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", [(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", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'missing'")])] - let change = TextDocumentContentChangeEvent $ InL $ #range .== (Range (Position 0 15) (Position 0 16)) .+ #rangeLength .== Nothing .+ #text .== "l" + let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 0 15) (Position 0 16) + .+ #rangeLength .== Nothing + .+ #text .== "l" changeDoc doc [change] expectDiagnostics [("Testing.hs", [(DiagnosticSeverity_Error, (0, 15), "Not in scope: 'lissing'")])] , testSessionWait "variable not in scope" $ do @@ -414,7 +422,9 @@ diagnosticTests = testGroup "diagnostics" , "import ModuleA" ] _ <- createDoc "ModuleB.hs" "haskell" contentB - let change = TextDocumentContentChangeEvent $ InL $ #range .== (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", [(DiagnosticSeverity_Error, (1, 0), "Could not find module")])] , testSessionWait "add missing module" $ do @@ -761,8 +771,12 @@ diagnosticTests = testGroup "diagnostics" ] where editPair x y = let p = Position x y ; p' = Position x (y+2) in - (TextDocumentContentChangeEvent $ InL $ #range .== Range p p .+ #rangeLength .== Nothing .+ #text .== "fd" - ,TextDocumentContentChangeEvent $ InL $ #range .== 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 @@ -2574,7 +2588,9 @@ dependentFileTest = testGroup "addDependentFile" [FileEvent (filePathToUri "dep-file.txt") FileChangeType_Changed ] -- Modifying Baz will now trigger Foo to be rebuilt as well - let change = TextDocumentContentChangeEvent $ InL $ #range .== 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", [])] @@ -2864,7 +2880,9 @@ sessionDepsArePickedUp = testSession' [FileEvent (filePathToUri $ dir "hie.yaml") FileChangeType_Changed ] -- Send change event. let change = - TextDocumentContentChangeEvent $ InL $ #range .== 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", [])] @@ -3519,7 +3537,9 @@ positionMappingTests recorder = range <- genRange rope PrintableText replacement <- arbitrary let newRope = runIdentity $ applyChange mempty rope - (TextDocumentContentChangeEvent $ InL $ #range .== range .+ #rangeLength .== Nothing .+ #text .== replacement) + (TextDocumentContentChangeEvent $ InL $ #range .== range + .+ #rangeLength .== Nothing + .+ #text .== replacement) newPos <- genPosition newRope pure (range, replacement, newPos) forAll diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 428129ffec..021de95bd3 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -964,10 +964,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 = args' mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text mkLspCmdId pid (PluginId plid) (CommandId cid) diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 336c013e03..1864fdab49 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -60,7 +60,7 @@ import Control.Applicative.Combinators import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Extra import Control.Exception.Base -import Control.Lens (isn't) +import Control.Lens.Extras (is) import Control.Monad (guard, unless, void) import Control.Monad.Extra (forM) import Control.Monad.IO.Class @@ -420,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 SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ isn't _workDoneProgressEnd v-> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | is _workDoneProgressEnd v-> Just () _ -> Nothing -- | Wait for all progress to be done @@ -430,7 +430,7 @@ waitForAllProgressDone = loop where loop = do ~() <- skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | not $ isn't _workDoneProgressEnd v -> Just () + FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams _ v)) | is _workDoneProgressEnd v -> Just () _ -> Nothing done <- null <$> getIncompleteProgressSessions unless done loop diff --git a/plugins/hls-cabal-plugin/test/Main.hs b/plugins/hls-cabal-plugin/test/Main.hs index a29f35f11f..d67cb3b724 100644 --- a/plugins/hls-cabal-plugin/test/Main.hs +++ b/plugins/hls-cabal-plugin/test/Main.hs @@ -107,7 +107,9 @@ pluginTests = testGroup "Plugin Tests" expectNoMoreDiagnostics 1 cabalDoc "parsing" let theRange = Range (Position 3 20) (Position 3 23) -- Invalid license - changeDoc cabalDoc [TextDocumentContentChangeEvent $ InL $ #range .== theRange .+ #rangeLength .== Nothing .+ #text .== "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" 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 59736f139a..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 @@ -116,9 +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 - -- There is no longer an unknown symbol, thus using SymbolKind_TypeParameter - -- which is 26 - skUnknown = SymbolKind_TypeParameter + -- There is no longer an unknown symbol, thus using SymbolKind_Function + -- as this is the call-hierarchy plugin + skUnknown = SymbolKind_Function mkCallHierarchyItem' = mkCallHierarchyItem nfp diff --git a/plugins/hls-hlint-plugin/test/Main.hs b/plugins/hls-hlint-plugin/test/Main.hs index 6a739e7e8b..a0790c89bf 100644 --- a/plugins/hls-hlint-plugin/test/Main.hs +++ b/plugins/hls-hlint-plugin/test/Main.hs @@ -125,11 +125,15 @@ suggestionsTests = doc <- openDoc "Base.hs" "haskell" testHlintDiagnostics doc - let change = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 1 8) (Position 1 12) .+ #rangeLength .== Nothing .+ #text .== "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 $ InL $ #range .== Range (Position 1 8) (Position 1 12) .+ #rangeLength .== Nothing .+ #text .== "id x" + let change' = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 1 8) (Position 1 12) + .+ #rangeLength .== Nothing + .+ #text .== "id x" changeDoc doc [change'] testHlintDiagnostics doc diff --git a/plugins/hls-splice-plugin/test/Main.hs b/plugins/hls-splice-plugin/test/Main.hs index c1d91986ec..8a2800305e 100644 --- a/plugins/hls-splice-plugin/test/Main.hs +++ b/plugins/hls-splice-plugin/test/Main.hs @@ -95,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 $ InL $ #range .== theRange .+ #rangeLength .== Nothing .+ #text .== alt] + changeDoc doc [TextDocumentContentChangeEvent $ InL $ #range .== theRange + .+ #rangeLength .== Nothing + .+ #text .== alt] void waitForDiagnostics -- wait for the entire build to finish void waitForBuildQueue diff --git a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs index 2f954571dd..7b82b05d13 100644 --- a/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs +++ b/plugins/hls-stan-plugin/src/Ide/Plugin/Stan.hs @@ -99,4 +99,23 @@ rules recorder plId = do message :: T.Text message = T.unlines $ - [ " \ No newline at end of file + [ " ✲ Name: " <> inspectionName inspection, + " ✲ Description: " <> inspectionDescription inspection, + " ✲ Severity: " <> (T.pack $ show $ inspectionSeverity inspection), + " ✲ Category: " <> T.intercalate " " + (map (("#" <>) . unCategory) $ toList $ inspectionCategory inspection), + "Possible solutions:" + ] + ++ map (" - " <>) (inspectionSolution inspection) + return ( file, + ShowDiag, + LSP.Diagnostic + { _range = realSrcSpanToRange observationSrcSpan, + _severity = Just LSP.DsHint, + _code = Just (LSP.InR $ unId (inspectionId inspection)), + _source = Just "stan", + _message = message, + _relatedInformation = Nothing, + _tags = Nothing + } + ) diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index f8d13e704a..62d90e3314 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -80,9 +80,9 @@ progressCaps = fullCaps{_window = Just (WindowClientCapabilities (Just True) Not data ProgressMessage = ProgressCreate WorkDoneProgressCreateParams - | ProgressBegin ProgressParams - | ProgressReport ProgressParams - | ProgressEnd ProgressParams + | ProgressBegin ProgressToken WorkDoneProgressBegin + | ProgressReport ProgressToken WorkDoneProgressReport + | ProgressEnd ProgressToken WorkDoneProgressEnd data InterestingMessage a = InterestingMessage a @@ -93,17 +93,20 @@ progressMessage = progressCreate <|> progressBegin <|> progressReport <|> progressEnd where progressCreate = ProgressCreate . view L.params <$> message SMethod_WindowWorkDoneProgressCreate - progressBegin = ProgressBegin <$> satisfyMaybe (\case - FromServerMess SMethod_Progress (TNotificationMessage _ _ (ProgressParams t x)) - | not $ isn't _workDoneProgressBegin x-> Just (ProgressParams t x) + 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 SMethod_Progress (TNotificationMessage _ _ (ProgressParams t x)) - | not $ isn't _workDoneProgressReport 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 SMethod_Progress (TNotificationMessage _ _ (ProgressParams t x)) - | not $ isn't _workDoneProgressEnd 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) @@ -145,13 +148,13 @@ updateExpectProgressStateAndRecurseWith f progressMessage expectedTitles activeP case progressMessage of ProgressCreate params -> do f expectedTitles ((params ^. L.token): activeProgressTokens) - ProgressBegin (ProgressParams token (preview _workDoneProgressBegin -> Just params)) -> do + ProgressBegin token params -> do liftIO $ token `expectedIn` activeProgressTokens f (delete (params ^. L.title) expectedTitles) activeProgressTokens - ProgressReport (ProgressParams token (preview _workDoneProgressBegin -> Just params)) -> do + ProgressReport token _ -> do liftIO $ token `expectedIn` activeProgressTokens f expectedTitles activeProgressTokens - ProgressEnd (ProgressParams token (preview _workDoneProgressBegin -> Just params)) -> do + ProgressEnd token _ -> do liftIO $ token `expectedIn` activeProgressTokens f expectedTitles (delete token activeProgressTokens) From 1aa5324a6be9ea226ff2e4d0fad8b51c014b6caf Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 12 Jun 2023 10:06:48 +0300 Subject: [PATCH 52/70] Update lsp* we track --- cabal.project | 2 +- .../hls-overloaded-record-dot-plugin.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index bf6f251eff..7685bf8675 100644 --- a/cabal.project +++ b/cabal.project @@ -96,7 +96,7 @@ source-repository-package source-repository-package type:git location: https://github.com/joyfulmantis/lsp - tag: 75826fbf344d62b59532008c190e72927158ea7a + tag: 19b7425034ad4a7901a80b8b08df99491cb902e2 subdir: lsp lsp-types lsp-test 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 From 4e8d51702493ad60c172ed3ebed02e4a21204896 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 12 Jun 2023 14:42:11 +0300 Subject: [PATCH 53/70] Fix bug with hover and follow upstream lsp --- cabal.project | 2 +- haskell-language-server.cabal | 2 +- hls-plugin-api/src/Ide/Types.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/cabal.project b/cabal.project index 7685bf8675..94c7656afa 100644 --- a/cabal.project +++ b/cabal.project @@ -96,7 +96,7 @@ source-repository-package source-repository-package type:git location: https://github.com/joyfulmantis/lsp - tag: 19b7425034ad4a7901a80b8b08df99491cb902e2 + tag: 98ba7cc91436e93578e9882c7ef18660b5fd4dd4 subdir: lsp lsp-types lsp-test diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 34e6aa84d5..d26734f785 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -333,7 +333,7 @@ common explicitFields 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 diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 021de95bd3..0f98bbe15e 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -563,7 +563,7 @@ instance PluginRequestMethod Method_TextDocumentRename where instance PluginRequestMethod Method_TextDocumentHover where combineResponses _ _ _ _ (mapMaybe nullToMaybe . toList -> hs :: [Hover]) = - if mcontent ^. L.value == "" + if null hs then InR Null else InL $ Hover (InL mcontent) r where From 4b9cbdc25028f3b0f441c744a3a548b8c8220d3a Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 12 Jun 2023 14:53:37 +0300 Subject: [PATCH 54/70] stack fixes --- cabal.project | 2 +- stack-lts19.yaml | 9 ++++++--- stack.yaml | 9 ++++++--- 3 files changed, 13 insertions(+), 7 deletions(-) diff --git a/cabal.project b/cabal.project index 94c7656afa..8b606f349a 100644 --- a/cabal.project +++ b/cabal.project @@ -95,7 +95,7 @@ source-repository-package -- This is needed till lsp makes a release source-repository-package type:git - location: https://github.com/joyfulmantis/lsp + location: https://github.com/haskell/lsp tag: 98ba7cc91436e93578e9882c7ef18660b5fd4dd4 subdir: lsp lsp-types lsp-test diff --git a/stack-lts19.yaml b/stack-lts19.yaml index ec0b29b52a..4d86fa62d6 100644 --- a/stack-lts19.yaml +++ b/stack-lts19.yaml @@ -59,9 +59,12 @@ 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 +- git: https://github.com/haskell/lsp.git + commit: 98ba7cc91436e93578e9882c7ef18660b5fd4dd4 + subdirs: + - lsp + - lsp-types + - lsp-test - hie-bios-0.12.0 configure-options: diff --git a/stack.yaml b/stack.yaml index 8ec367da08..b2fd85a2c6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -48,9 +48,12 @@ 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 +- git: https://github.com/haskell/lsp.git + commit: 98ba7cc91436e93578e9882c7ef18660b5fd4dd4 + subdirs: + - lsp + - lsp-types + - lsp-test - hie-bios-0.12.0 # currently needed for ghcide>extra, etc. From abd0bf8378c8fb4c206080220df651b54801ee48 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 12 Jun 2023 15:01:58 +0300 Subject: [PATCH 55/70] fix stack try 2 --- stack-lts19.yaml | 10 +++++----- stack.yaml | 10 +++++----- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/stack-lts19.yaml b/stack-lts19.yaml index 4d86fa62d6..8b96d41515 100644 --- a/stack-lts19.yaml +++ b/stack-lts19.yaml @@ -59,12 +59,12 @@ extra-deps: - retrie-1.1.0.0 - stylish-haskell-0.14.2.0@sha256:fffe1c13ad4c2678cf28a7470cac5d3bf20c71c36f09969e3e5f186787cceb7c,4321 - co-log-core-0.3.1.0 -- git: https://github.com/haskell/lsp.git +- git: git@github.com:haskell/lsp.git commit: 98ba7cc91436e93578e9882c7ef18660b5fd4dd4 - subdirs: - - lsp - - lsp-types - - lsp-test + subdirs: + - lsp + - lsp-types + - lsp-test - hie-bios-0.12.0 configure-options: diff --git a/stack.yaml b/stack.yaml index b2fd85a2c6..fc6c078b64 100644 --- a/stack.yaml +++ b/stack.yaml @@ -48,12 +48,12 @@ extra-deps: - monad-dijkstra-0.1.1.3@sha256:d2fc098d7c122555e726830a12ae0423ac187f89de9228f32e56e2f6fc2238e1,1900 - retrie-1.2.0.1 - co-log-core-0.3.1.0 -- git: https://github.com/haskell/lsp.git +- git: git@github.com:haskell/lsp.git commit: 98ba7cc91436e93578e9882c7ef18660b5fd4dd4 - subdirs: - - lsp - - lsp-types - - lsp-test + subdirs: + - lsp + - lsp-types + - lsp-test - hie-bios-0.12.0 # currently needed for ghcide>extra, etc. From d201bdcba3a3aca8e2f9ee284b0c978ca506e501 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 12 Jun 2023 15:10:58 +0300 Subject: [PATCH 56/70] add row-types to stack extra-deps --- stack-lts19.yaml | 1 + stack.yaml | 1 + 2 files changed, 2 insertions(+) diff --git a/stack-lts19.yaml b/stack-lts19.yaml index 8b96d41515..a4969c9331 100644 --- a/stack-lts19.yaml +++ b/stack-lts19.yaml @@ -66,6 +66,7 @@ extra-deps: - lsp-types - lsp-test - hie-bios-0.12.0 +- row-types-1.0.1.2 configure-options: ghcide: diff --git a/stack.yaml b/stack.yaml index fc6c078b64..e6bef89739 100644 --- a/stack.yaml +++ b/stack.yaml @@ -55,6 +55,7 @@ extra-deps: - lsp-types - lsp-test - hie-bios-0.12.0 +- row-types-1.0.1.2 # currently needed for ghcide>extra, etc. allow-newer: true From 1a0692e844b58bf4646b8c6fbacaad677b15dd8a Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 12 Jun 2023 15:53:59 +0300 Subject: [PATCH 57/70] fix func test and satisfy stack build-depends --- .../hls-explicit-imports-plugin.cabal | 1 + test/functional/Deferred.hs | 7 ++++--- 2 files changed, 5 insertions(+), 3 deletions(-) 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 44a7eb3ac4..94e6e807e4 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -53,4 +53,5 @@ test-suite tests , filepath , hls-explicit-imports-plugin , hls-test-utils + , lsp-types , text diff --git a/test/functional/Deferred.hs b/test/functional/Deferred.hs index 2df1948d08..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.Protocol.Lens hiding (id, length, 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 (InL []) + liftIO $ defs @?= InR (InR Null) -- TODO: the benefits of caching parsed modules is doubted. -- TODO: add issue link From a3e2736fa565d9c557e947ccd3c21f589191a5d1 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 12 Jun 2023 16:28:13 +0300 Subject: [PATCH 58/70] More making stack happy --- test/functional/Symbol.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/functional/Symbol.hs b/test/functional/Symbol.hs index 4b17dcdec7..776296e3ff 100644 --- a/test/functional/Symbol.hs +++ b/test/functional/Symbol.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Symbol (tests) where -import Control.Lens (_Just, ix, to, (^?)) +import Control.Lens (_Just, ix, (^?)) import Data.List import Language.LSP.Protocol.Capabilities import qualified Language.LSP.Protocol.Lens as L From 26b623aa7fab8f0c549fc8cbf76f7e9a13f2aba8 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 12 Jun 2023 17:12:08 +0300 Subject: [PATCH 59/70] fix hls-code-range test --- plugins/hls-code-range-plugin/test/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index 31e9fc9ffa..a1948ce51a 100644 --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -85,7 +85,7 @@ foldingRangeGoldenTest testName = goldenGitDiff testName (testDataDir testN testDataDir = "test" "testdata" "folding-range" showFoldingRangesForTest :: [FoldingRange] -> ByteString - showFoldingRangesForTest foldingRanges = LBSChar8.intercalate "\n" $ fmap showFoldingRangeForTest foldingRanges + 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 From 88b36402fd466b4cc71125cad8e4f132cd60f78a Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 12 Jun 2023 18:39:02 +0300 Subject: [PATCH 60/70] tactics-plugin test compiles --- plugins/hls-tactics-plugin/old/test/Utils.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/plugins/hls-tactics-plugin/old/test/Utils.hs b/plugins/hls-tactics-plugin/old/test/Utils.hs index 8dda54f43d..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 @@ -258,7 +258,7 @@ 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 From a483607a8c726b4fc1732292001fb0b2610a7289 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 13 Jun 2023 10:06:02 +0300 Subject: [PATCH 61/70] fix hls-class-plugin test --- plugins/hls-class-plugin/hls-class-plugin.cabal | 1 + plugins/hls-class-plugin/test/Main.hs | 12 ++++++------ 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/plugins/hls-class-plugin/hls-class-plugin.cabal b/plugins/hls-class-plugin/hls-class-plugin.cabal index 7a07046087..bf1b48d9e8 100644 --- a/plugins/hls-class-plugin/hls-class-plugin.cabal +++ b/plugins/hls-class-plugin/hls-class-plugin.cabal @@ -77,4 +77,5 @@ test-suite tests , hls-test-utils == 2.1.0.0 , lens , lsp-types + , row-types , text diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index d1f9e4ba8b..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 #-} @@ -13,6 +14,7 @@ import Control.Lens (Prism', prism', (^.), (^..), (^?)) import Control.Monad (void) import Data.Maybe +import Data.Row ((.==)) import qualified Data.Text as T import qualified Ide.Plugin.Class as Class import qualified Language.LSP.Protocol.Lens as L @@ -81,18 +83,16 @@ codeActionTests = testGroup , testCase "Update text document version" $ runSessionWithServer classPlugin testDataDir $ do doc <- createDoc "Version.hs" "haskell" "module Version where" ver1 <- (^. L.version) <$> getVersionedDoc doc - liftIO $ ver1 @?= Just 0 + 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 <- (^. 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 From dc2ea23cb8fcf9032d8860876aeacf883e401591 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 13 Jun 2023 19:55:04 +0300 Subject: [PATCH 62/70] fix merge mistake --- exe/Main.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index d74ed2c31a..d0597e02ee 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -30,11 +30,7 @@ import Ide.Types (PluginDescriptor (pluginNotifica mkPluginNotificationHandler) import Language.LSP.Protocol.Message as LSP import Language.LSP.Server as LSP -#if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter (Pretty (pretty), vsep) -#else -import Data.Text.Prettyprint.Doc (Pretty (pretty), vsep) -#endif data Log = LogIdeMain IdeMain.Log From 7e53aae3a6e9f536d859585747b3e302524949b8 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 14 Jun 2023 23:43:35 +0300 Subject: [PATCH 63/70] Use official version, and flag and bench fixes --- cabal.project | 10 +--------- ghcide-bench/src/Experiments.hs | 2 +- haskell-language-server.cabal | 2 +- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 3 --- stack-lts19.yaml | 9 +++------ stack.yaml | 9 +++------ 6 files changed, 9 insertions(+), 26 deletions(-) diff --git a/cabal.project b/cabal.project index 8b606f349a..6494ed2699 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-15T12:00:00Z constraints: -- For GHC 9.4, older versions of entropy fail to build on Windows @@ -92,14 +92,6 @@ source-repository-package tag: 7a0af7a8fd38045fd15fb13445bdcc7085325460 -- END DELETE --- This is needed till lsp makes a release -source-repository-package - type:git - location: https://github.com/haskell/lsp - tag: 98ba7cc91436e93578e9882c7ef18660b5fd4dd4 - subdir: lsp lsp-types lsp-test - - allow-newer: -- ghc-9.4 ekg-json:base, diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index 422004141e..9a508f993f 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -59,8 +59,8 @@ 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 qualified Lanuguage.LSP.Protocol.Types as LSP import Numeric.Natural import Options.Applicative import System.Directory diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index b99cd404e9..aec1e399d6 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -418,7 +418,7 @@ library , ghc , ghcide == 2.1.0.0 , githash >=0.1.6.1 - , lsp + , lsp >= 2.0.0.0 , hie-bios , hiedb , hls-plugin-api == 2.1.0.0 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 3e0b3f8ed5..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,9 +33,6 @@ 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 qualified Language.LSP.Protocol.Lens as L diff --git a/stack-lts19.yaml b/stack-lts19.yaml index a4969c9331..5dd02936c1 100644 --- a/stack-lts19.yaml +++ b/stack-lts19.yaml @@ -59,12 +59,9 @@ extra-deps: - retrie-1.1.0.0 - stylish-haskell-0.14.2.0@sha256:fffe1c13ad4c2678cf28a7470cac5d3bf20c71c36f09969e3e5f186787cceb7c,4321 - co-log-core-0.3.1.0 -- git: git@github.com:haskell/lsp.git - commit: 98ba7cc91436e93578e9882c7ef18660b5fd4dd4 - subdirs: - - lsp - - lsp-types - - lsp-test +- lsp-2.0.0.0 +- lsp-types-2.0.0.0 +- lsp-test-2.0.0.0 - hie-bios-0.12.0 - row-types-1.0.1.2 diff --git a/stack.yaml b/stack.yaml index e6bef89739..b2ab132d22 100644 --- a/stack.yaml +++ b/stack.yaml @@ -48,12 +48,9 @@ extra-deps: - monad-dijkstra-0.1.1.3@sha256:d2fc098d7c122555e726830a12ae0423ac187f89de9228f32e56e2f6fc2238e1,1900 - retrie-1.2.0.1 - co-log-core-0.3.1.0 -- git: git@github.com:haskell/lsp.git - commit: 98ba7cc91436e93578e9882c7ef18660b5fd4dd4 - subdirs: - - lsp - - lsp-types - - lsp-test +- lsp-2.0.0.0 +- lsp-types-2.0.0.0 +- lsp-test-2.0.0.0 - hie-bios-0.12.0 - row-types-1.0.1.2 From 46daa19ae2676e320d3f0c161903e7bd7b46c386 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 15 Jun 2023 00:41:15 +0300 Subject: [PATCH 64/70] Fix stack, testing, and flags --- plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal | 2 +- plugins/hls-refactor-plugin/test/Main.hs | 2 +- stack-lts19.yaml | 2 +- stack.yaml | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal b/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal index cbe5534173..e220eaa9aa 100644 --- a/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal +++ b/plugins/hls-fourmolu-plugin/hls-fourmolu-plugin.cabal @@ -32,7 +32,7 @@ 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.1.0.0 diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index 588996f276..d304c5c62f 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -89,7 +89,7 @@ initializeTests = withResource acquire release tests where 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 diff --git a/stack-lts19.yaml b/stack-lts19.yaml index 5dd02936c1..4a639659b5 100644 --- a/stack-lts19.yaml +++ b/stack-lts19.yaml @@ -61,7 +61,7 @@ extra-deps: - co-log-core-0.3.1.0 - lsp-2.0.0.0 - lsp-types-2.0.0.0 -- lsp-test-2.0.0.0 +- lsp-test-0.15.0.0 - hie-bios-0.12.0 - row-types-1.0.1.2 diff --git a/stack.yaml b/stack.yaml index b2ab132d22..e8a5427daf 100644 --- a/stack.yaml +++ b/stack.yaml @@ -50,7 +50,7 @@ extra-deps: - co-log-core-0.3.1.0 - lsp-2.0.0.0 - lsp-types-2.0.0.0 -- lsp-test-2.0.0.0 +- lsp-test-0.15.0.0 - hie-bios-0.12.0 - row-types-1.0.1.2 From 1a364312f41216a56eec80f27d7bc02d6bf3b19c Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 15 Jun 2023 19:22:17 +0300 Subject: [PATCH 65/70] add bytestring constrains to gchide-bench --- ghcide-bench/ghcide-bench.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide-bench/ghcide-bench.cabal b/ghcide-bench/ghcide-bench.cabal index d4e89061f8..45190b0a4d 100644 --- a/ghcide-bench/ghcide-bench.cabal +++ b/ghcide-bench/ghcide-bench.cabal @@ -23,7 +23,7 @@ executable ghcide-bench build-depends: aeson, base, - bytestring, + bytestring ^>= 0.11, containers, data-default, directory, From d8a28ee5c238d7afc4bedf99bb654a29f82d3b51 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 15 Jun 2023 19:40:21 +0300 Subject: [PATCH 66/70] ghcide-bench fix constraint --- ghcide-bench/ghcide-bench.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide-bench/ghcide-bench.cabal b/ghcide-bench/ghcide-bench.cabal index 45190b0a4d..22d413174f 100644 --- a/ghcide-bench/ghcide-bench.cabal +++ b/ghcide-bench/ghcide-bench.cabal @@ -23,7 +23,7 @@ executable ghcide-bench build-depends: aeson, base, - bytestring ^>= 0.11, + bytestring >= 0.11, containers, data-default, directory, From 017dc6b4f4429a382f273355c876d6d114cd41e3 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Thu, 15 Jun 2023 19:54:49 +0300 Subject: [PATCH 67/70] remove constraint, instead use older exported api --- ghcide-bench/ghcide-bench.cabal | 2 +- ghcide-bench/src/Experiments.hs | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/ghcide-bench/ghcide-bench.cabal b/ghcide-bench/ghcide-bench.cabal index 22d413174f..d4e89061f8 100644 --- a/ghcide-bench/ghcide-bench.cabal +++ b/ghcide-bench/ghcide-bench.cabal @@ -23,7 +23,7 @@ executable ghcide-bench build-depends: aeson, base, - bytestring >= 0.11, + bytestring, containers, data-default, directory, diff --git a/ghcide-bench/src/Experiments.hs b/ghcide-bench/src/Experiments.hs index 9a508f993f..33e420962a 100644 --- a/ghcide-bench/src/Experiments.hs +++ b/ghcide-bench/src/Experiments.hs @@ -41,6 +41,7 @@ import Data.Aeson (Value (Null), 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 @@ -687,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 $ A.decode . BS.fromStrict <$> BS.readFile cachedPath + cachedRes <- liftIO $ try @_ @IOException $ A.decode . BSL.fromStrict <$> BS.readFile cachedPath case cachedRes of Left _ -> do result <- loop pos - liftIO $ BS.writeFile cachedPath $ BS.toStrict $ A.encode result + liftIO $ BS.writeFile cachedPath $ BSL.toStrict $ A.encode result return result Right res -> return res From 456524e357ac79e366a627310e923d081683b8fa Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 16 Jun 2023 15:46:43 +0300 Subject: [PATCH 68/70] Update to lsp-types 2.0.0.1 --- cabal.project | 2 +- ghcide/ghcide.cabal | 2 +- hls-test-utils/hls-test-utils.cabal | 2 +- plugins/hls-cabal-plugin/hls-cabal-plugin.cabal | 2 +- plugins/hls-floskell-plugin/hls-floskell-plugin.cabal | 2 +- stack-lts19.yaml | 2 +- stack.yaml | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/cabal.project b/cabal.project index 6494ed2699..c8d824062e 100644 --- a/cabal.project +++ b/cabal.project @@ -56,7 +56,7 @@ package * write-ghc-environment-files: never -index-state: 2023-06-15T12: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/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index c35433d3c9..9ba17e756a 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -69,7 +69,7 @@ library lens, list-t, hiedb == 0.4.3.*, - lsp-types ^>= 2.0.0.0, + lsp-types ^>= 2.0.0.1, lsp ^>= 2.0.0.0 , mtl, optparse-applicative, diff --git a/hls-test-utils/hls-test-utils.cabal b/hls-test-utils/hls-test-utils.cabal index e06122aa45..7955abed48 100644 --- a/hls-test-utils/hls-test-utils.cabal +++ b/hls-test-utils/hls-test-utils.cabal @@ -47,7 +47,7 @@ library , lens , lsp ^>=2.0.0.0 , lsp-test ^>=0.15 - , lsp-types ^>=2.0.0.0 + , lsp-types ^>=2.0.0.1 , tasty , tasty-expected-failure , tasty-golden diff --git a/plugins/hls-cabal-plugin/hls-cabal-plugin.cabal b/plugins/hls-cabal-plugin/hls-cabal-plugin.cabal index c2a7f94489..e2ef02f8ec 100644 --- a/plugins/hls-cabal-plugin/hls-cabal-plugin.cabal +++ b/plugins/hls-cabal-plugin/hls-cabal-plugin.cabal @@ -53,7 +53,7 @@ library , hls-plugin-api == 2.1.0.0 , hls-graph == 2.1.0.0 , lsp ^>=2.0.0.0 - , lsp-types ^>=2.0.0.0 + , lsp-types ^>=2.0.0.1 , regex-tdfa ^>=1.3.1 , stm , text diff --git a/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal b/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal index 0f75b5ac11..5c5e8ceecb 100644 --- a/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal +++ b/plugins/hls-floskell-plugin/hls-floskell-plugin.cabal @@ -30,7 +30,7 @@ library , floskell ^>=0.10 , ghcide == 2.1.0.0 , hls-plugin-api == 2.1.0.0 - , lsp-types ^>=2.0.0.0 + , lsp-types ^>=2.0.0.1 , text , transformers diff --git a/stack-lts19.yaml b/stack-lts19.yaml index 4a639659b5..0ece22d38a 100644 --- a/stack-lts19.yaml +++ b/stack-lts19.yaml @@ -60,7 +60,7 @@ extra-deps: - stylish-haskell-0.14.2.0@sha256:fffe1c13ad4c2678cf28a7470cac5d3bf20c71c36f09969e3e5f186787cceb7c,4321 - co-log-core-0.3.1.0 - lsp-2.0.0.0 -- lsp-types-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 diff --git a/stack.yaml b/stack.yaml index e8a5427daf..c28042b4c0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -49,7 +49,7 @@ extra-deps: - retrie-1.2.0.1 - co-log-core-0.3.1.0 - lsp-2.0.0.0 -- lsp-types-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 From 55a8c75809b0dbb7b6086c8114592b82db0d93cb Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 16 Jun 2023 14:00:38 +0000 Subject: [PATCH 69/70] implement suggestions from michaelpj --- .../IDE/Plugin/Completions/Logic.hs | 28 +++++++++++-------- ghcide/test/exe/Main.hs | 3 +- ghcide/test/src/Development/IDE/Test.hs | 9 +++--- hls-plugin-api/src/Ide/Types.hs | 7 ----- 4 files changed, 23 insertions(+), 24 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 54df3b791c..d370b5142a 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedLabels #-} @@ -16,6 +17,7 @@ module Development.IDE.Plugin.Completions.Logic ( 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) @@ -283,30 +285,32 @@ showForSnippet x = printOutputable x mkModCompl :: T.Text -> CompletionItem mkModCompl label = - CompletionItem label Nothing (Just CompletionItemKind_Module) Nothing 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 Nothing (Just CompletionItemKind_Function) Nothing (Just moduleName) - Nothing 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 Nothing (Just CompletionItemKind_Module) Nothing (Just label) - Nothing 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 Nothing (Just CompletionItemKind_Keyword) Nothing 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 diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 86645c2807..1b825e9d0d 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -142,6 +142,7 @@ 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 @@ -2597,7 +2598,7 @@ dependentFileTest = testGroup "addDependentFile" cradleLoadedMessage :: Session FromServerMessage cradleLoadedMessage = satisfy $ \case - FromServerMess m@(SMethod_CustomMethod _) (NotMess _) -> someMethodToMethodString (SomeMethod m) == cradleLoadedMethod + FromServerMess (SMethod_CustomMethod p) (NotMess _) -> symbolVal p == cradleLoadedMethod _ -> False cradleLoadedMethod :: String diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 714d562530..29a47fe49c 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -50,6 +50,7 @@ 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 @@ -229,8 +230,8 @@ getFilesOfInterest = callTestPlugin GetFilesOfInterest waitForCustomMessage :: T.Text -> (A.Value -> Maybe res) -> Session res waitForCustomMessage msg pred = skipManyTill anyMessage $ satisfyMaybe $ \case - FromServerMess cm@(SMethod_CustomMethod _) (NotMess TNotificationMessage{_params = value}) - | someMethodToMethodString (SomeMethod cm) == T.unpack msg -> pred value + FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params = value}) + | symbolVal p == T.unpack msg -> pred value _ -> Nothing waitForGC :: Session [T.Text] @@ -251,10 +252,10 @@ isReferenceReady p = void $ referenceReady (equalFilePath p) referenceReady :: (FilePath -> Bool) -> Session FilePath referenceReady pred = satisfyMaybe $ \case - FromServerMess cm@(SMethod_CustomMethod _) (NotMess TNotificationMessage{_params}) + FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params}) | A.Success fp <- A.fromJSON _params , pred fp - , someMethodToMethodString (SomeMethod cm) == "ghcide/reference/ready" + , symbolVal p == "ghcide/reference/ready" -> Just fp _ -> Nothing diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index 0f98bbe15e..c32b7173d0 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -430,13 +430,6 @@ instance PluginRequestMethod Method_TextDocumentCodeAction where , Just caKind <- ca ^. L.kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed | otherwise = False - -- Copied form lsp-types 1.6 to get compilation working. May make more - -- sense to add it back to lsp-types 2.0 - -- | Does the first 'CodeActionKind' subsume the other one, hierarchically. Reflexive. - codeActionKindSubsumes :: CodeActionKind -> CodeActionKind -> Bool - -- Simple but ugly implementation: prefix on the string representation - codeActionKindSubsumes parent child = toEnumBaseType parent `T.isPrefixOf` toEnumBaseType child - instance PluginMethod Request Method_TextDocumentDefinition where pluginEnabled _ msgParams pluginDesc _ = pluginResponsible uri pluginDesc From 8cb740fc32f8c07e03e1f0806b85b8304b13751f Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Sun, 18 Jun 2023 17:22:02 +0000 Subject: [PATCH 70/70] get nix builds working --- configuration-ghc-90.nix | 4 ++++ configuration-ghc-92.nix | 4 ++++ configuration-ghc-94.nix | 4 ++++ configuration-ghc-96.nix | 4 ++++ flake.lock | 51 +++++++++++++++++++++++++++++++++++----- flake.nix | 14 +++++++++++ 6 files changed, 75 insertions(+), 6 deletions(-) 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/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;