diff --git a/.circleci/config.yml b/.circleci/config.yml index 22aa3f06394..e57008bcd31 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -75,9 +75,9 @@ defaults: &defaults version: 2 jobs: - stackage-lts19: + stackage-lts21: environment: - - STACK_FILE: "stack-lts19.yaml" + - STACK_FILE: "stack-lts21.yaml" <<: *defaults stackage-nightly: @@ -90,5 +90,5 @@ workflows: version: 2 multiple-ghcs: jobs: - - stackage-lts19 + - stackage-lts21 - stackage-nightly diff --git a/.github/actions/setup-build/action.yml b/.github/actions/setup-build/action.yml index fc150ac749b..246ec9794c7 100644 --- a/.github/actions/setup-build/action.yml +++ b/.github/actions/setup-build/action.yml @@ -31,7 +31,7 @@ runs: sudo chown -R $USER /usr/local/.ghcup shell: bash - - uses: haskell/actions/setup@v2.4.3 + - uses: haskell/actions/setup@v2.4.4 id: HaskEnvSetup with: ghc-version : ${{ inputs.ghc }} diff --git a/.github/workflows/bench.yml b/.github/workflows/bench.yml index 0e73fa72f9d..9e1500296a4 100644 --- a/.github/workflows/bench.yml +++ b/.github/workflows/bench.yml @@ -121,7 +121,7 @@ jobs: example: ['cabal', 'lsp-types'] steps: - - uses: haskell/actions/setup@v2.4.3 + - uses: haskell/actions/setup@v2.4.4 with: ghc-version : ${{ matrix.ghc }} cabal-version: ${{ matrix.cabal }} diff --git a/.github/workflows/nix.yml b/.github/workflows/nix.yml index 0e6d2fe84ae..55edf99dc7a 100644 --- a/.github/workflows/nix.yml +++ b/.github/workflows/nix.yml @@ -103,6 +103,10 @@ jobs: # We only build nix dev shell for current GHC version because some are # failing with different GHC version on darwin. - name: Build development shell with nix dependencies for current GHC version + if: matrix.os == 'macOS-latest' + run: nix develop --print-build-logs .#haskell-language-server-dev-nix --profile dev + - name: Build development shells with nix dependencies + if: matrix.os == 'ubuntu-latest' run: nix develop --print-build-logs .#all-nix-dev-shells --profile dev - name: Push development shell if: ${{ env.HAS_TOKEN == 'true' }} diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 4f9e3b6d994..1b0eb530e06 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -41,6 +41,7 @@ jobs: , "**/stack*.yaml" , ".gitlab-ci.yaml" , ".gitlab/**" + , "CODEOWNERS" ]' # If we only change ghcide downstream packages we have not test ghcide itself - id: skip_ghcide_check diff --git a/CODEOWNERS b/CODEOWNERS index a56a15c6146..9599cba7553 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -30,7 +30,7 @@ /plugins/hls-code-range-plugin @kokobd /plugins/hls-splice-plugin @konn /plugins/hls-stylish-haskell-plugin @Ailrun -/plugins/hls-tactics-plugin @isovector +/plugins/hls-tactics-plugin /plugins/hls-stan-plugin @uhbif19 /plugins/hls-explicit-record-fields-plugin @ozkutuk /plugins/hls-overloaded-record-dot-plugin @joyfulmantis diff --git a/configuration-ghc-90.nix b/configuration-ghc-90.nix index e14705093c6..8152f110fa6 100644 --- a/configuration-ghc-90.nix +++ b/configuration-ghc-90.nix @@ -14,15 +14,11 @@ let doCheck = false; }); } // (builtins.mapAttrs (_: drv: disableLibraryProfiling drv) { - # ptr-poker breaks on MacOS without SSE2 optimizations - # https://github.com/nikita-volkov/ptr-poker/issues/11 - ptr-poker = hself.callCabal2nix "ptr-poker" inputs.ptr-poker { }; - Cabal = hself.Cabal_3_6_3_0; Cabal-syntax = hself.Cabal-syntax_3_8_1_0; - ghc-lib-parser = hself.callCabal2nix "ghc-lib-parser" inputs.ghc-lib-parser-94 {}; + ghc-lib-parser = hsuper.ghc-lib-parser_9_4_5_20230430; lsp = hself.callCabal2nix "lsp" inputs.lsp {}; lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {}; @@ -42,7 +38,7 @@ let ormolu = hself.callCabal2nix "ormolu" inputs.ormolu-052 {}; - fourmolu = hself.callHackage "fourmolu" "0.10.1.0" {}; + fourmolu = hsuper.fourmolu_0_10_1_0; # Re-generate HLS drv excluding some plugins haskell-language-server = diff --git a/configuration-ghc-92.nix b/configuration-ghc-92.nix index e7dd2e384e5..01402a6497b 100644 --- a/configuration-ghc-92.nix +++ b/configuration-ghc-92.nix @@ -21,21 +21,17 @@ let } // (builtins.mapAttrs (_: drv: disableLibraryProfiling drv) { apply-refact = hsuper.apply-refact_0_13_0_0; - # ptr-poker breaks on MacOS without SSE2 optimizations - # https://github.com/nikita-volkov/ptr-poker/issues/11 - ptr-poker = hself.callCabal2nix "ptr-poker" inputs.ptr-poker { }; - Cabal-syntax = hself.Cabal-syntax_3_8_1_0; - ghc-lib-parser = hself.callCabal2nix "ghc-lib-parser" inputs.ghc-lib-parser-94 {}; + ghc-lib-parser = hsuper.ghc-lib-parser_9_4_5_20230430; hlint = appendConfigureFlag (hself.callCabal2nix "hlint" inputs.hlint-35 {}) "-fghc-lib"; ormolu = hself.callCabal2nix "ormolu" inputs.ormolu-052 {}; - fourmolu = hself.callHackage "fourmolu" "0.10.1.0" {}; + fourmolu = hsuper.fourmolu_0_10_1_0; - stylish-haskell = appendConfigureFlag hsuper.stylish-haskell "-fghc-lib"; + stylish-haskell = hsuper.stylish-haskell_0_14_4_0; hie-bios = hself.callCabal2nix "hie-bios" inputs.haskell-hie-bios { }; @@ -43,7 +39,7 @@ let lsp = hself.callCabal2nix "lsp" inputs.lsp {}; lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {}; - lsp-test = hself.callCabal2nix "lsp-test" inputs.lsp-test {}; + lsp-test = dontCheck (hself.callCabal2nix "lsp-test" inputs.lsp-test {}); # Re-generate HLS drv excluding some plugins haskell-language-server = diff --git a/configuration-ghc-94.nix b/configuration-ghc-94.nix index c53cc16ce72..e561496955f 100644 --- a/configuration-ghc-94.nix +++ b/configuration-ghc-94.nix @@ -15,11 +15,13 @@ let } // (builtins.mapAttrs (_: drv: disableLibraryProfiling drv) { apply-refact = hsuper.apply-refact_0_13_0_0; + fourmolu = dontCheck (hself.callCabal2nix "fourmolu" inputs.fourmolu-011 {}); + 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 {}; + lsp-test = dontCheck (hself.callCabal2nix "lsp-test" inputs.lsp-test {}); # Re-generate HLS drv excluding some plugins haskell-language-server = diff --git a/configuration-ghc-96.nix b/configuration-ghc-96.nix index 7dad1a944c0..744e7047d17 100644 --- a/configuration-ghc-96.nix +++ b/configuration-ghc-96.nix @@ -29,34 +29,24 @@ let doCheck = false; }); apply-refact = hsuper.apply-refact_0_13_0_0; - tagged = hself.callHackage "tagged" "0.8.7" { }; - primitive = hself.callHackage "primitive" "0.8.0.0" { }; - unix-compat = hself.callCabal2nix "unix-compat" inputs.haskell-unix-compat { }; - MonadRandom = hself.callHackage "MonadRandom" "0.6" { }; - hiedb = hself.callCabal2nix "hiedb" inputs.haskell-hiedb { }; + tagged = hsuper.tagged_0_8_7; + primitive = hsuper.primitive_0_8_0_0; + MonadRandom = hsuper.MonadRandom_0_6; hie-bios = hself.callCabal2nix "hie-bios" inputs.haskell-hie-bios { }; + hlint = hself.callCabal2nix "hlint" inputs.hlint-36 {}; implicit-hie-cradle = hself.callCabal2nix "implicit-hie-cradle" inputs.haskell-implicit-hie-cradle { }; - ghc-exactprint = hself.callCabal2nix "ghc-exactprint" inputs.haskell-ghc-exactprint { }; - # ptr-poker breaks on MacOS without SSE2 optimizations - # https://github.com/nikita-volkov/ptr-poker/issues/11 - ptr-poker = hself.callCabal2nix "ptr-poker" inputs.ptr-poker { }; + fourmolu = hself.callCabal2nix "fourmolu" inputs.fourmolu-012 {}; - ormolu = hself.ormolu_0_5_3_0; + ghc-lib-parser-ex = hsuper.ghc-lib-parser-ex_9_6_0_0; - # TODO: smunix: nix fails to build fourmolu-0.13 from Hackage with these errors: - # tar: */fourmolu/0.13.0.0/fourmolu.json: Not found in archive - # tar: */fourmolu/0.13.0.0/fourmolu.cabal: Not found in archive - # tar: Exiting with failure status due to previous errors - # As an alternative, we could build directly from github:fourmolu. How do people - # feel about this? - fourmolu = hself.callHackage "fourmolu" "0.12.0.0" {}; + ormolu = hself.callCabal2nix "ormolu" inputs.ormolu-07 {}; - stylish-haskell = appendConfigureFlag hsuper.stylish-haskell "-fghc-lib"; + stylish-haskell = hself.callCabal2nix "stylish-haskell" inputs.stylish-haskell-0145 {}; lsp = hself.callCabal2nix "lsp" inputs.lsp {}; lsp-types = hself.callCabal2nix "lsp-types" inputs.lsp-types {}; - lsp-test = hself.callCabal2nix "lsp-test" inputs.lsp-test {}; + lsp-test = dontCheck (hself.callCabal2nix "lsp-test" inputs.lsp-test {}); # Re-generate HLS drv excluding some plugins haskell-language-server = diff --git a/docs/support/plugin-support.md b/docs/support/plugin-support.md index 5ef465dcfb3..9c14577afc9 100644 --- a/docs/support/plugin-support.md +++ b/docs/support/plugin-support.md @@ -52,7 +52,6 @@ For example, a plugin to provide a formatter which has itself been abandoned has | `hls-eval-plugin` | 2 | | | `hls-explicit-fixity-plugin` | 2 | | | `hls-explicit-record-fields-plugin` | 2 | | -| `hls-floskell-plugin` | 2 | 9.6 | | `hls-fourmolu-plugin` | 2 | | | `hls-gadt-plugin` | 2 | | | `hls-hlint-plugin` | 2 | | @@ -64,6 +63,7 @@ For example, a plugin to provide a formatter which has itself been abandoned has | `hls-stylish-haskell-plugin` | 2 | | | `hls-tactics-plugin` | 2 | 9.2, 9.4, 9.6 | | `hls-overloaded-record-dot-plugin` | 2 | 8.10, 9.0 | +| `hls-floskell-plugin` | 3 | 9.6 | | `hls-haddock-comments-plugin` | 3 | 9.2, 9.4, 9.6 | | `hls-stan-plugin` | 3 | 8.6, 9.0, 9.2, 9.4, 9.6 | | `hls-retrie-plugin` | 3 | | diff --git a/exe/Main.hs b/exe/Main.hs index ee46a7cbcfa..16f99a44e02 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -13,7 +13,7 @@ import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Maybe (catMaybes) import Data.Text (Text) -import Development.IDE.Types.Logger (Doc, Priority (Error, Info), +import Ide.Logger (Doc, Priority (Error, Info), Recorder, WithPriority (WithPriority, priority), cfilter, cmapWithPrio, @@ -21,7 +21,7 @@ import Development.IDE.Types.Logger (Doc, Priority (Error, Info), layoutPretty, logWith, makeDefaultStderrRecorder, renderStrict, withFileRecorder) -import qualified Development.IDE.Types.Logger as Logger +import qualified Ide.Logger as Logger import qualified HlsPlugins as Plugins import Ide.Arguments (Arguments (..), GhcideArguments (..), diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 6bebc98923e..32f7327e56e 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -45,14 +45,14 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Development.IDE.LSP.LanguageServer (runLanguageServer) import qualified Development.IDE.Main as Main -import Development.IDE.Types.Logger (Doc, Logger (Logger), +import GHC.Stack.Types (emptyCallStack) +import Ide.Logger (Doc, Logger (Logger), Pretty (pretty), Recorder (logger_), WithPriority (WithPriority), cmapWithPrio, makeDefaultStderrRecorder, toCologActionWithPrio) -import GHC.Stack.Types (emptyCallStack) import Ide.Plugin.Config (Config) import Ide.Types (IdePlugins (IdePlugins)) import Language.LSP.Protocol.Message (Method (Method_Initialize), diff --git a/flake.lock b/flake.lock index 8b15b2f87dd..04f2e6a04aa 100644 --- a/flake.lock +++ b/flake.lock @@ -34,16 +34,28 @@ "type": "github" } }, - "ghc-lib-parser-94": { + "fourmolu-011": { "flake": false, "locked": { - "narHash": "sha256-WElfrJexd0VciSYe0T23s/5pxpOQzKhMn0z5zxa0Ax0=", + "narHash": "sha256-g/yDZXeLCHq/iXoZTaTYSb8l9CMny3AKsRQgWElagZI=", "type": "tarball", - "url": "https://hackage.haskell.org/package/ghc-lib-parser-9.4.4.20221225/ghc-lib-parser-9.4.4.20221225.tar.gz" + "url": "https://hackage.haskell.org/package/fourmolu-0.11.0.0/fourmolu-0.11.0.0.tar.gz" }, "original": { "type": "tarball", - "url": "https://hackage.haskell.org/package/ghc-lib-parser-9.4.4.20221225/ghc-lib-parser-9.4.4.20221225.tar.gz" + "url": "https://hackage.haskell.org/package/fourmolu-0.11.0.0/fourmolu-0.11.0.0.tar.gz" + } + }, + "fourmolu-012": { + "flake": false, + "locked": { + "narHash": "sha256-yru8ls67DMM6WSeVU6xDmmwa48I8S9CUv9NBaxSQ29M=", + "type": "tarball", + "url": "https://hackage.haskell.org/package/fourmolu-0.12.0.0/fourmolu-0.12.0.0.tar.gz" + }, + "original": { + "type": "tarball", + "url": "https://hackage.haskell.org/package/fourmolu-0.12.0.0/fourmolu-0.12.0.0.tar.gz" } }, "gitignore": { @@ -62,23 +74,6 @@ "type": "github" } }, - "haskell-ghc-exactprint": { - "flake": false, - "locked": { - "lastModified": 1678824759, - "narHash": "sha256-2I+GyVrfevo/vWZqIdXZ+Cg0+cU/755M0GhaSHiiZCQ=", - "owner": "alanz", - "repo": "ghc-exactprint", - "rev": "db5e8ab3817c9ee34e37359d5839e9526e05e448", - "type": "github" - }, - "original": { - "owner": "alanz", - "ref": "ghc-9.6", - "repo": "ghc-exactprint", - "type": "github" - } - }, "haskell-hie-bios": { "flake": false, "locked": { @@ -95,22 +90,6 @@ "type": "github" } }, - "haskell-hiedb": { - "flake": false, - "locked": { - "lastModified": 1680249133, - "narHash": "sha256-v6PnDMlrdC56QJ9HwDvVFzHkhVbvivUj1LXMVJ0ZLec=", - "owner": "wz1000", - "repo": "HieDb", - "rev": "dac3ebb37ad33f9c042f59091ee87a4b9a2d63d1", - "type": "github" - }, - "original": { - "owner": "wz1000", - "repo": "HieDb", - "type": "github" - } - }, "haskell-implicit-hie-cradle": { "flake": false, "locked": { @@ -128,33 +107,28 @@ "type": "github" } }, - "haskell-unix-compat": { + "hlint-35": { "flake": false, "locked": { - "lastModified": 1664758053, - "narHash": "sha256-JD/EPdPYEOfS6WqGXOZrdcRUiVkHInSwZT8hn/iQmLs=", - "owner": "jacobstanley", - "repo": "unix-compat", - "rev": "3f6bd688cb56224955e77245a2649ba99ea32fff", - "type": "github" + "narHash": "sha256-qQNUlQQnahUGEO92Lm0RwjTGBGr2Yaw0KRuFRMoc5No=", + "type": "tarball", + "url": "https://hackage.haskell.org/package/hlint-3.5/hlint-3.5.tar.gz" }, "original": { - "owner": "jacobstanley", - "repo": "unix-compat", - "rev": "3f6bd688cb56224955e77245a2649ba99ea32fff", - "type": "github" + "type": "tarball", + "url": "https://hackage.haskell.org/package/hlint-3.5/hlint-3.5.tar.gz" } }, - "hlint-35": { + "hlint-36": { "flake": false, "locked": { - "narHash": "sha256-qQNUlQQnahUGEO92Lm0RwjTGBGr2Yaw0KRuFRMoc5No=", + "narHash": "sha256-fH4RYnWeuBqJI5d3Ba+Xs0BxYr0IYFH1OWO3k2iHGlU=", "type": "tarball", - "url": "https://hackage.haskell.org/package/hlint-3.5/hlint-3.5.tar.gz" + "url": "https://hackage.haskell.org/package/hlint-3.6.1/hlint-3.6.1.tar.gz" }, "original": { "type": "tarball", - "url": "https://hackage.haskell.org/package/hlint-3.5/hlint-3.5.tar.gz" + "url": "https://hackage.haskell.org/package/hlint-3.6.1/hlint-3.6.1.tar.gz" } }, "lsp": { @@ -221,49 +195,48 @@ "url": "https://hackage.haskell.org/package/ormolu-0.5.2.0/ormolu-0.5.2.0.tar.gz" } }, - "ptr-poker": { + "ormolu-07": { "flake": false, "locked": { - "narHash": "sha256-ll3wuUjkhTE8Grcs8LfGpdiuyobrSBmwgjqPOTlrPac=", + "narHash": "sha256-5M5gNzSvsiQH1+0oexRByzf5EIET+0BFwR4fLIr2P7g=", "type": "tarball", - "url": "https://hackage.haskell.org/package/ptr-poker-0.1.2.8/ptr-poker-0.1.2.8.tar.gz" + "url": "https://hackage.haskell.org/package/ormolu-0.7.1.0/ormolu-0.7.1.0.tar.gz" }, "original": { "type": "tarball", - "url": "https://hackage.haskell.org/package/ptr-poker-0.1.2.8/ptr-poker-0.1.2.8.tar.gz" + "url": "https://hackage.haskell.org/package/ormolu-0.7.1.0/ormolu-0.7.1.0.tar.gz" } }, "root": { "inputs": { "flake-compat": "flake-compat", "flake-utils": "flake-utils", - "ghc-lib-parser-94": "ghc-lib-parser-94", + "fourmolu-011": "fourmolu-011", + "fourmolu-012": "fourmolu-012", "gitignore": "gitignore", - "haskell-ghc-exactprint": "haskell-ghc-exactprint", "haskell-hie-bios": "haskell-hie-bios", - "haskell-hiedb": "haskell-hiedb", "haskell-implicit-hie-cradle": "haskell-implicit-hie-cradle", - "haskell-unix-compat": "haskell-unix-compat", "hlint-35": "hlint-35", + "hlint-36": "hlint-36", "lsp": "lsp", "lsp-test": "lsp-test", "lsp-types": "lsp-types", "nixpkgs": "nixpkgs", "ormolu-052": "ormolu-052", - "ptr-poker": "ptr-poker", - "stylish-haskell": "stylish-haskell" + "ormolu-07": "ormolu-07", + "stylish-haskell-0145": "stylish-haskell-0145" } }, - "stylish-haskell": { + "stylish-haskell-0145": { "flake": false, "locked": { - "narHash": "sha256-493M/S38dad82mA04l98xK50WPfue618TIln+7hE7VM=", + "narHash": "sha256-EE7RFQ6q4Ek8daRgOpNMGepYLa9o8cM4OLjTNUSHQf0=", "type": "tarball", - "url": "https://hackage.haskell.org/package/stylish-haskell-0.14.4.0/stylish-haskell-0.14.4.0.tar.gz" + "url": "https://hackage.haskell.org/package/stylish-haskell-0.14.5.0/stylish-haskell-0.14.5.0.tar.gz" }, "original": { "type": "tarball", - "url": "https://hackage.haskell.org/package/stylish-haskell-0.14.4.0/stylish-haskell-0.14.4.0.tar.gz" + "url": "https://hackage.haskell.org/package/stylish-haskell-0.14.5.0/stylish-haskell-0.14.5.0.tar.gz" } }, "systems": { diff --git a/flake.nix b/flake.nix index 1ba231f939b..12f9b212590 100644 --- a/flake.nix +++ b/flake.nix @@ -20,24 +20,32 @@ }; # List of hackage dependencies - ghc-lib-parser-94 = { - url = "https://hackage.haskell.org/package/ghc-lib-parser-9.4.4.20221225/ghc-lib-parser-9.4.4.20221225.tar.gz"; - flake = false; - }; hlint-35 = { url = "https://hackage.haskell.org/package/hlint-3.5/hlint-3.5.tar.gz"; flake = false; }; - ptr-poker = { - url = "https://hackage.haskell.org/package/ptr-poker-0.1.2.8/ptr-poker-0.1.2.8.tar.gz"; + hlint-36 = { + url = "https://hackage.haskell.org/package/hlint-3.6.1/hlint-3.6.1.tar.gz"; + flake = false; + }; + fourmolu-011 = { + url = "https://hackage.haskell.org/package/fourmolu-0.11.0.0/fourmolu-0.11.0.0.tar.gz"; + flake = false; + }; + fourmolu-012 = { + url = "https://hackage.haskell.org/package/fourmolu-0.12.0.0/fourmolu-0.12.0.0.tar.gz"; flake = false; }; ormolu-052 = { url = "https://hackage.haskell.org/package/ormolu-0.5.2.0/ormolu-0.5.2.0.tar.gz"; flake = false; }; - stylish-haskell = { - url = "https://hackage.haskell.org/package/stylish-haskell-0.14.4.0/stylish-haskell-0.14.4.0.tar.gz"; + ormolu-07 = { + url = "https://hackage.haskell.org/package/ormolu-0.7.1.0/ormolu-0.7.1.0.tar.gz"; + flake = false; + }; + stylish-haskell-0145 = { + url = "https://hackage.haskell.org/package/stylish-haskell-0.14.5.0/stylish-haskell-0.14.5.0.tar.gz"; flake = false; }; @@ -55,25 +63,10 @@ flake = false; }; - haskell-unix-compat = { - url = "github:jacobstanley/unix-compat/3f6bd688cb56224955e77245a2649ba99ea32fff"; - flake = false; - }; - haskell-hiedb = { - url = "github:wz1000/HieDb"; - flake = false; - }; - haskell-hie-bios = { url = "github:haskell/hie-bios"; flake = false; }; - - haskell-ghc-exactprint = { - url = "github:alanz/ghc-exactprint/ghc-9.6"; - flake = false; - }; - # smunix: github:haskell/hie-bios defines # 'CabalType :: Maybe String -> Maybe FilePath -> CabalType' # while the original githcom:Avi-D-coder/hie-bios still has this: @@ -149,8 +142,6 @@ if final.system == "aarch64-darwin" then overrideCabal hsuper.ormolu (_: { enableSeparateBinOutput = false; }) else hsuper.ormolu; - - stylish-haskell = hself.callCabal2nix "stylish-haskell" inputs.stylish-haskell {}; }; hlsSources = @@ -400,10 +391,8 @@ # distributed using nix. all-haskell-language-server = linkFarmFromDrvs "all-haskell-language-server" (lib.unique (builtins.attrValues allPackages)); - # Same for all shells - # We try to build as much as possible, but not much shells are - # working (especially on darwing), so this list is limited. - all-nix-dev-shells = linkFarmFromDrvs "all-dev-shells" (builtins.map (shell: shell.inputDerivation) (lib.unique [nixDevShells.haskell-language-server-dev-nix])); + all-nix-dev-shells = linkFarmFromDrvs "all-dev-shells" + (builtins.map (shell: shell.inputDerivation) (lib.unique (builtins.attrValues nixDevShells))); all-simple-dev-shells = linkFarmFromDrvs "all-simple-dev-shells" (builtins.map (shell: shell.inputDerivation) (lib.unique (builtins.attrValues simpleDevShells))); diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs index ec72d277b60..0c6b1dd0f95 100644 --- a/ghcide/exe/Main.hs +++ b/ghcide/exe/Main.hs @@ -22,7 +22,9 @@ import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Monitoring.EKG as EKG import qualified Development.IDE.Monitoring.OpenTelemetry as OpenTelemetry import qualified Development.IDE.Plugin.HLS.GhcIde as GhcIde -import Development.IDE.Types.Logger (Logger (Logger), +import Development.IDE.Types.Options +import GHC.Stack (emptyCallStack) +import Ide.Logger (Logger (Logger), LoggingColumn (DataColumn, PriorityColumn), Pretty (pretty), Priority (Debug, Error, Info), @@ -33,9 +35,7 @@ import Development.IDE.Types.Logger (Logger (Logger), layoutPretty, makeDefaultStderrRecorder, renderStrict) -import qualified Development.IDE.Types.Logger as Logger -import Development.IDE.Types.Options -import GHC.Stack (emptyCallStack) +import qualified Ide.Logger as Logger import Ide.Plugin.Config (Config (checkParents, checkProject)) import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types (PluginDescriptor (pluginNotificationHandlers), diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 9ba17e756a1..8fbd855be24 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -197,7 +197,6 @@ library Development.IDE.Types.HscEnvEq Development.IDE.Types.KnownTargets Development.IDE.Types.Location - Development.IDE.Types.Logger Development.IDE.Types.Monitoring Development.IDE.Monitoring.OpenTelemetry Development.IDE.Types.Options diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index cfc9796c33a..625d1b9b1db 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -65,13 +65,6 @@ import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq (HscEnvEq, newHscEnvEq, newHscEnvEqPreserveImportPaths) import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), - Priority (Debug, Error, Info, Warning), - Recorder, WithPriority, - cmapWithPrio, logWith, - nest, - toCologActionWithPrio, - vcat, viaShow, (<+>)) import Development.IDE.Types.Options import GHC.Check import qualified HIE.Bios as HieBios @@ -79,6 +72,13 @@ 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 Ide.Logger (Pretty (pretty), + Priority (Debug, Error, Info, Warning), + Recorder, WithPriority, + cmapWithPrio, logWith, + nest, + toCologActionWithPrio, + vcat, viaShow, (<+>)) import Language.LSP.Protocol.Message import Language.LSP.Server import System.Directory @@ -484,7 +484,25 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do packageSetup (hieYaml, cfp, opts, libDir) = do -- Parse DynFlags for the newly discovered component hscEnv <- emptyHscEnv ideNc libDir - (df, targets) <- evalGhcEnv hscEnv $ setOptions opts (hsc_dflags hscEnv) + (df', targets) <- evalGhcEnv hscEnv $ setOptions opts (hsc_dflags hscEnv) + let df = +#if MIN_VERSION_ghc(9,3,0) + case unitIdString (homeUnitId_ df') of + -- cabal uses main for the unit id of all executable packages + -- This makes multi-component sessions confused about what + -- options to use for that component. + -- Solution: hash the options and use that as part of the unit id + -- This works because there won't be any dependencies on the + -- executable unit. + "main" -> + let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack $ componentOptions opts) + hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash)) + in setHomeUnitId_ hashed_uid df' + _ -> df' +#else + df' +#endif + let deps = componentDependencies opts ++ maybeToList hieYaml dep_info <- getDependencyInfo deps -- Now lookup to see whether we are combining with an existing HscEnv @@ -499,6 +517,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do -- We will modify the unitId and DynFlags used for -- compilation but these are the true source of -- information. + new_deps = RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info : maybe [] snd oldDeps -- Get all the unit-ids for things in this component diff --git a/ghcide/src/Development/IDE.hs b/ghcide/src/Development/IDE.hs index 503f0104f8e..8aa3b8c8155 100644 --- a/ghcide/src/Development/IDE.hs +++ b/ghcide/src/Development/IDE.hs @@ -55,4 +55,4 @@ import Development.IDE.Types.HscEnvEq as X (HscEnvEq (..), hscEnv, hscEnvWithImportPaths) import Development.IDE.Types.Location as X -import Development.IDE.Types.Logger as X +import Ide.Logger as X diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 0b4f6c6a1a7..b7422e6d74b 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -13,6 +13,7 @@ module Development.IDE.Core.Actions , lookupMod ) where +import Control.Monad.Extra (mapMaybeM) import Control.Monad.Reader import Control.Monad.Trans.Maybe import qualified Data.HashMap.Strict as HM @@ -31,7 +32,9 @@ import Development.IDE.Types.HscEnvEq (hscEnv) import Development.IDE.Types.Location import qualified HieDb import Language.LSP.Protocol.Types (DocumentHighlight (..), - SymbolInformation (..)) + SymbolInformation (..), + normalizedFilePathToUri, + uriToNormalizedFilePath) -- | Eventually this will lookup/generate URIs for files in dependencies, but not in the @@ -66,10 +69,36 @@ getAtPoint file pos = runMaybeT $ do !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) MaybeT $ liftIO $ fmap (first (toCurrentRange mapping =<<)) <$> AtPoint.atPoint opts hf dkMap env pos' -toCurrentLocations :: PositionMapping -> [Location] -> [Location] -toCurrentLocations mapping = mapMaybe go +-- | For each Loacation, determine if we have the PositionMapping +-- for the correct file. If not, get the correct position mapping +-- and then apply the position mapping to the location. +toCurrentLocations + :: PositionMapping + -> NormalizedFilePath + -> [Location] + -> IdeAction [Location] +toCurrentLocations mapping file = mapMaybeM go where - go (Location uri range) = Location uri <$> toCurrentRange mapping range + go :: Location -> IdeAction (Maybe Location) + go (Location uri range) = + -- The Location we are going to might be in a different + -- file than the one we are calling gotoDefinition from. + -- So we check that the location file matches the file + -- we are in. + if nUri == normalizedFilePathToUri file + -- The Location matches the file, so use the PositionMapping + -- we have. + then pure $ Location uri <$> toCurrentRange mapping range + -- The Location does not match the file, so get the correct + -- PositionMapping and use that instead. + else do + otherLocationMapping <- fmap (fmap snd) $ runMaybeT $ do + otherLocationFile <- MaybeT $ pure $ uriToNormalizedFilePath nUri + useE GetHieAst otherLocationFile + pure $ Location uri <$> (flip toCurrentRange range =<< otherLocationMapping) + where + nUri :: NormalizedUri + nUri = toNormalizedUri uri -- | useE is useful to implement functions that aren’t rules but need shortcircuiting -- e.g. getDefinition. @@ -90,7 +119,8 @@ getDefinition file pos = runMaybeT $ do (HAR _ hf _ _ _, mapping) <- useE GetHieAst file (ImportMap imports, _) <- useE GetImportMap file !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) - toCurrentLocations mapping <$> AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' + locations <- AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' + MaybeT $ Just <$> toCurrentLocations mapping file locations getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) getTypeDefinition file pos = runMaybeT $ do @@ -98,7 +128,8 @@ getTypeDefinition file pos = runMaybeT $ do opts <- liftIO $ getIdeOptionsIO ide (hf, mapping) <- useE GetHieAst file !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - toCurrentLocations mapping <$> AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' + locations <- AtPoint.gotoTypeDefinition withHieDb (lookupMod hiedbWriter) opts hf pos' + MaybeT $ Just <$> toCurrentLocations mapping file locations highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) highlightAtPoint file pos = runMaybeT $ do diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 3b8ee793a1f..e34c5323f9c 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -36,6 +36,7 @@ module Development.IDE.Core.Compile , TypecheckHelpers(..) , sourceTypecheck , sourceParser + , shareUsages ) where import Control.Monad.IO.Class @@ -361,6 +362,10 @@ captureSplicesAndDeps TypecheckHelpers{..} env k = do #if MIN_VERSION_ghc(9,3,0) -- TODO: support backpack nodeKeyToInstalledModule :: NodeKey -> Maybe InstalledModule + -- We shouldn't get boot files here, but to be safe, never map them to an installed module + -- because boot files don't have linkables we can load, and we will fail if we try to look + -- for them + nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB mod IsBoot) uid)) = Nothing nodeKeyToInstalledModule (NodeKey_Module (ModNodeKeyWithUid (GWIB mod _) uid)) = Just $ mkModule uid mod nodeKeyToInstalledModule _ = Nothing moduleToNodeKey :: Module -> NodeKey @@ -468,6 +473,8 @@ filterUsages = id #endif -- | Mitigation for https://gitlab.haskell.org/ghc/ghc/-/issues/22744 +-- Important to do this immediately after reading the unit before +-- anything else has a chance to read `mi_usages` shareUsages :: ModIface -> ModIface shareUsages iface = iface {mi_usages = usages} where usages = map go (mi_usages iface) @@ -1073,11 +1080,18 @@ mergeEnvs env (ms, deps) extraMods envs = do combineModules a b | HsSrcFile <- mi_hsc_src (hm_iface a) = a | otherwise = b + + -- Prefer non-boot files over non-boot files + -- otherwise we can get errors like https://gitlab.haskell.org/ghc/ghc/-/issues/19816 + -- if a boot file shadows over a non-boot file + combineModuleLocations a@(InstalledFound ml m) b | Just fp <- ml_hs_file ml, not ("boot" `isSuffixOf` fp) = a + combineModuleLocations _ b = b + concatFC :: FinderCacheState -> [FinderCache] -> IO FinderCache concatFC cur xs = do fcModules <- mapM (readIORef . fcModuleCache) xs fcFiles <- mapM (readIORef . fcFileCache) xs - fcModules' <- newIORef $! foldl' (plusInstalledModuleEnv const) cur fcModules + fcModules' <- newIORef $! foldl' (plusInstalledModuleEnv combineModuleLocations) cur fcModules fcFiles' <- newIORef $! Map.unions fcFiles pure $ FinderCache fcModules' fcFiles' @@ -1479,11 +1493,28 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do | source_version <= dest_version -> SourceUnmodified | otherwise -> SourceModified + old_iface <- case mb_old_iface of + Just iface -> pure (Just iface) + Nothing -> do + let ncu = hsc_NC sessionWithMsDynFlags + read_dflags = hsc_dflags sessionWithMsDynFlags +#if MIN_VERSION_ghc(9,3,0) + read_result <- liftIO $ readIface read_dflags ncu mod iface_file +#else + read_result <- liftIO $ initIfaceCheck (text "readIface") sessionWithMsDynFlags + $ readIface mod iface_file +#endif + case read_result of + Util.Failed{} -> return Nothing + -- important to call `shareUsages` here before checkOldIface + -- consults `mi_usages` + Util.Succeeded iface -> return $ Just (shareUsages iface) + -- If mb_old_iface is nothing then checkOldIface will load it for us -- given that the source is unmodified (recomp_iface_reqd, mb_checked_iface) #if MIN_VERSION_ghc(9,3,0) - <- liftIO $ checkOldIface sessionWithMsDynFlags ms mb_old_iface >>= \case + <- liftIO $ checkOldIface sessionWithMsDynFlags ms old_iface >>= \case UpToDateItem x -> pure (UpToDate, Just x) OutOfDateItem reason x -> pure (NeedsRecompile reason, x) #else @@ -1497,8 +1528,7 @@ loadInterface session ms linkableNeeded RecompilationInfo{..} = do regenerate linkableNeeded case (mb_checked_iface, recomp_iface_reqd) of - (Just iface', UpToDate) -> do - let iface = shareUsages iface' + (Just iface, UpToDate) -> do details <- liftIO $ mkDetailsFromIface sessionWithMsDynFlags iface -- parse the runtime dependencies from the annotations let runtime_deps diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 9a1caecd888..b7e568d0d6b 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -27,11 +27,11 @@ import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), - Recorder, WithPriority, - cmapWithPrio) import Development.IDE.Types.Options import qualified Focus +import Ide.Logger (Pretty (pretty), + Recorder, WithPriority, + cmapWithPrio) import Ide.Plugin.Config (Config) import Language.LSP.Protocol.Types import Language.LSP.Server hiding (getVirtualFile) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 89d50432cfa..229aaecb96a 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -54,7 +54,7 @@ import qualified System.Directory as Dir #else #endif -import qualified Development.IDE.Types.Logger as L +import qualified Ide.Logger as L import Data.Aeson (ToJSON (toJSON)) import qualified Data.Binary as B @@ -63,7 +63,7 @@ import Data.List (foldl') import qualified Data.Text as Text import Development.IDE.Core.IdeConfiguration (isWorkspaceFile) import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Types.Logger (Pretty (pretty), +import Ide.Logger (Pretty (pretty), Priority (Info), Recorder, WithPriority, diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index ddb919a4245..17858544c27 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -40,13 +40,13 @@ import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.Exports import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), +import Development.IDE.Types.Options (IdeTesting (..)) +import GHC.TypeLits (KnownSymbol) +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio, logDebug) -import Development.IDE.Types.Options (IdeTesting (..)) -import GHC.TypeLits (KnownSymbol) import qualified Language.LSP.Protocol.Message as LSP import qualified Language.LSP.Server as LSP diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 109259df7b4..10a7b9c3620 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -153,9 +153,9 @@ import Control.Concurrent.STM.Stats (atomically) import Language.LSP.Server (LspT) import System.Info.Extra (isWindows) import HIE.Bios.Ghc.Gap (hostIsDynamic) -import Development.IDE.Types.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat) +import Ide.Logger (Recorder, logWith, cmapWithPrio, WithPriority, Pretty (pretty), (<+>), nest, vcat) import qualified Development.IDE.Core.Shake as Shake -import qualified Development.IDE.Types.Logger as Logger +import qualified Ide.Logger as Logger import qualified Development.IDE.Types.Shake as Shake import Development.IDE.GHC.CoreFile import Data.Time.Clock.POSIX (posixSecondsToUTCTime) diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index 3e61ee582ef..e88dd341ab0 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -23,13 +23,13 @@ import Development.IDE.Core.Debouncer import Development.IDE.Core.FileExists (fileExistsRules) import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Graph -import Development.IDE.Types.Logger as Logger (Logger, +import Development.IDE.Types.Options (IdeOptions (..)) +import Ide.Logger as Logger (Logger, Pretty (pretty), Priority (Debug), Recorder, WithPriority, 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 diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 4ba10900876..b66d4995620 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -152,8 +152,8 @@ import Development.IDE.Types.Exports import qualified Development.IDE.Types.Exports as ExportsMap import Development.IDE.Types.KnownTargets import Development.IDE.Types.Location -import Development.IDE.Types.Logger hiding (Priority) -import qualified Development.IDE.Types.Logger as Logger +import Ide.Logger hiding (Priority) +import qualified Ide.Logger as Logger import Development.IDE.Types.Monitoring (Monitoring (..)) import Development.IDE.Types.Options import Development.IDE.Types.Shake diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index ce4e3b6bc3a..ee87c187274 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -29,7 +29,7 @@ import Development.IDE.Graph.Rule import Development.IDE.Types.Diagnostics (FileDiagnostic, showDiagnostics) import Development.IDE.Types.Location (Uri (..)) -import Development.IDE.Types.Logger (Logger (Logger)) +import Ide.Logger (Logger (Logger)) import Ide.Types (PluginId (..)) import Language.LSP.Protocol.Types (NormalizedFilePath, fromNormalizedFilePath) diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index be4d72beb3c..3b516c6f40c 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -39,6 +39,7 @@ module Development.IDE.GHC.Compat.Core ( lookupType, needWiredInHomeIface, loadWiredInHomeIface, + readIface, loadSysInterface, importDecl, #if MIN_VERSION_ghc(8,8,0) diff --git a/ghcide/src/Development/IDE/Import/FindImports.hs b/ghcide/src/Development/IDE/Import/FindImports.hs index ba98e4f84f2..a8e63bf4a16 100644 --- a/ghcide/src/Development/IDE/Import/FindImports.hs +++ b/ghcide/src/Development/IDE/Import/FindImports.hs @@ -29,6 +29,7 @@ import Data.Maybe import System.FilePath #if MIN_VERSION_ghc(9,3,0) import GHC.Types.PkgQual +import GHC.Unit.State #endif data Import @@ -135,25 +136,45 @@ locateModule env comp_info exts targetFor modName mbPkgName isSource = do #else Nothing -> do #endif + + mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : other_imports) exts targetFor isSource $ unLoc modName + case mbFile of + Nothing -> lookupInPackageDB env + Just (uid, file) -> toModLocation uid file + where + dflags = hsc_dflags env + import_paths = mapMaybe (mkImportDirs env) comp_info + other_imports = +#if MIN_VERSION_ghc(9,4,0) + -- On 9.4+ instead of bringing all the units into scope, only bring into scope the units + -- this one depends on + -- This way if you have multiple units with the same module names, we won't get confused + -- For example if unit a imports module M from unit B, when there is also a module M in unit C, + -- and unit a only depends on unit b, without this logic there is the potential to get confused + -- about which module unit a imports. + -- Without multi-component support it is hard to recontruct the dependency environment so + -- unit a will have both unit b and unit c in scope. + map (\uid -> (uid, importPaths (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps + ue = hsc_unit_env env + units = homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId_ dflags) ue + hpt_deps :: [UnitId] + hpt_deps = homeUnitDepends units +#else + import_paths' +#endif + -- first try to find the module as a file. If we can't find it try to find it in the package -- database. -- Here the importPaths for the current modules are added to the front of the import paths from the other components. -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in -- each component will end up being found in the wrong place and cause a multi-cradle match failure. - let import_paths' = + import_paths' = #if MIN_VERSION_ghc(9,3,0) import_paths #else map snd import_paths #endif - mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : import_paths') exts targetFor isSource $ unLoc modName - case mbFile of - Nothing -> lookupInPackageDB env - Just (uid, file) -> toModLocation uid file - where - dflags = hsc_dflags env - import_paths = mapMaybe (mkImportDirs env) comp_info toModLocation uid file = liftIO $ do loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) #if MIN_VERSION_ghc(9,0,0) diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index fdd51a90144..7ad2021dc23 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -21,7 +21,7 @@ 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 Ide.Logger import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 5e3a8800b77..80d7d1b7bf8 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -41,9 +41,9 @@ import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Shake hiding (Log, Priority) import Development.IDE.Core.Tracing 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.Logger +import qualified Ide.Logger as Logger import Language.LSP.Server (LanguageContextEnv, LspServerLog, type (<~>)) diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 80b956904dc..6674bd4b863 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -37,8 +37,8 @@ import Development.IDE.Core.Service hiding (Log, LogShake) import Development.IDE.Core.Shake hiding (Log, Priority) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Location -import Development.IDE.Types.Logger import Development.IDE.Types.Shake (toKey) +import Ide.Logger import Ide.Types import Numeric.Natural diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index a7b124a96af..b440b4c2ff8 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -77,7 +77,7 @@ import Development.IDE.Session (SessionLoadingOptions import qualified Development.IDE.Session as Session import Development.IDE.Types.Location (NormalizedUri, toNormalizedFilePath') -import Development.IDE.Types.Logger (Logger, +import Ide.Logger (Logger, Pretty (pretty), Priority (Info, Warning), Recorder, diff --git a/ghcide/src/Development/IDE/Main/HeapStats.hs b/ghcide/src/Development/IDE/Main/HeapStats.hs index a1c0b9f3d7c..ac1af8f28eb 100644 --- a/ghcide/src/Development/IDE/Main/HeapStats.hs +++ b/ghcide/src/Development/IDE/Main/HeapStats.hs @@ -6,11 +6,11 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Monad import Data.Word -import Development.IDE.Types.Logger (Pretty (pretty), Priority (Info), - Recorder, WithPriority, hsep, - logWith, (<+>)) import GHC.Stats -import Text.Printf (printf) +import Ide.Logger (Pretty (pretty), Priority (Info), + Recorder, WithPriority, hsep, + logWith, (<+>)) +import Text.Printf (printf) data Log = LogHeapStatsPeriod !Int diff --git a/ghcide/src/Development/IDE/Monitoring/EKG.hs b/ghcide/src/Development/IDE/Monitoring/EKG.hs index 2999285442d..e4d9f6d0aea 100644 --- a/ghcide/src/Development/IDE/Monitoring/EKG.hs +++ b/ghcide/src/Development/IDE/Monitoring/EKG.hs @@ -1,14 +1,14 @@ {-# LANGUAGE CPP #-} module Development.IDE.Monitoring.EKG(monitoring) where -import Development.IDE.Types.Logger (Logger) import Development.IDE.Types.Monitoring (Monitoring (..)) +import Ide.Logger (Logger) #ifdef MONITORING_EKG import Control.Concurrent (killThread) import Control.Concurrent.Async (async, waitCatch) import Control.Monad (forM_) import Data.Text (pack) -import Development.IDE.Types.Logger (logInfo) +import Ide.Logger (logInfo) import qualified System.Metrics as Monitoring import qualified System.Remote.Monitoring.Wai as Monitoring diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 2a1841131c8..e1ed48806b3 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -36,7 +36,7 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackageE hscEnv) import qualified Development.IDE.Types.KnownTargets as KT import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) @@ -66,7 +66,7 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeSta descriptor recorder plId = (defaultPluginDescriptor plId) { pluginRules = produceCompletions recorder , pluginHandlers = mkPluginHandler SMethod_TextDocumentCompletion getCompletionsLSP - <> mkPluginHandler SMethod_CompletionItemResolve resolveCompletion + <> mkResolveHandler SMethod_CompletionItemResolve resolveCompletion , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} , pluginPriority = ghcideCompletionsPluginPriority } @@ -119,11 +119,9 @@ dropListFromImportDecl iDecl = let f x = x in f <$> iDecl -resolveCompletion :: IdeState -> PluginId -> CompletionItem -> LSP.LspM Config (Either ResponseError CompletionItem) -resolveCompletion ide _ comp@CompletionItem{_detail,_documentation,_data_} - | Just resolveData <- _data_ - , Success (CompletionResolveData uri needType (NameDetails mod occ)) <- fromJSON resolveData - , Just file <- uriToNormalizedFilePath $ toNormalizedUri uri +resolveCompletion :: ResolveFunction IdeState CompletionResolveData 'Method_CompletionItemResolve +resolveCompletion ide _pid comp@CompletionItem{_detail,_documentation,_data_} uri (CompletionResolveData _ needType (NameDetails mod occ)) + | Just file <- uriToNormalizedFilePath $ toNormalizedUri uri = liftIO $ runIdeAction "Completion resolve" (shakeExtras ide) $ do msess <- useWithStaleFast GhcSessionDeps file case msess of @@ -160,7 +158,7 @@ resolveCompletion ide _ comp@CompletionItem{_detail,_documentation,_data_} where stripForall ty = case splitForAllTyCoVars ty of (_,res) -> res -resolveCompletion _ _ comp = pure (Right comp) +resolveCompletion _ _ _ _ _ = pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unable to get normalized file path for url" Nothing -- | Generate code actions. getCompletionsLSP diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index c134a26045e..755517375cc 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -32,7 +32,7 @@ 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 hiding (Error) +import Ide.Logger hiding (Error) import Ide.Plugin.Config import Ide.PluginUtils (getClientConfig) import Ide.Types as HLS @@ -51,15 +51,19 @@ import UnliftIO.Exception (catchAny) -- data Log - = LogPluginError PluginId ResponseError + = LogPluginError PluginId ResponseError | LogNoPluginForMethod (Some SMethod) | LogInvalidCommandIdentifier + | ExceptionInPlugin PluginId (Some SMethod) SomeException + instance Pretty Log where pretty = \case LogPluginError (PluginId pId) err -> pretty pId <> ":" <+> prettyResponseError err LogNoPluginForMethod (Some method) -> "No plugin enabled for " <> pretty (show method) LogInvalidCommandIdentifier-> "Invalid command identifier" + ExceptionInPlugin plId (Some method) exception -> + "Exception in plugin " <> viaShow plId <> " while processing "<> viaShow method <> ": " <> viaShow exception instance Show Log where show = renderString . layoutCompact . pretty @@ -92,6 +96,10 @@ failedToParseArgs (CommandId com) (PluginId pid) err arg = "Error while parsing args for " <> com <> " in plugin " <> pid <> ": " <> T.pack err <> ", arg = " <> T.pack (show arg) +exceptionInPlugin :: PluginId -> SMethod m -> SomeException -> Text +exceptionInPlugin plId method exception = + "Exception in plugin " <> T.pack (show plId) <> " while processing "<> T.pack (show method) <> ": " <> T.pack (show exception) + -- | Build a ResponseError and log it before returning to the caller logAndReturnError :: Recorder (WithPriority Log) -> PluginId -> (LSPErrorCodes |? ErrorCodes) -> Text -> LSP.LspT Config IO (Either ResponseError a) logAndReturnError recorder p errCode msg = do @@ -99,6 +107,13 @@ logAndReturnError recorder p errCode msg = do logWith recorder Warning $ LogPluginError p err pure $ Left err +-- | Logs the provider error before returning it to the caller +logAndReturnError' :: Recorder (WithPriority Log) -> (LSPErrorCodes |? ErrorCodes) -> Log -> LSP.LspT Config IO (Either ResponseError a) +logAndReturnError' recorder errCode msg = do + let err = ResponseError errCode (fromString $ show msg) Nothing + logWith recorder Warning $ msg + pure $ Left err + -- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config asGhcIdePlugin recorder (IdePlugins ls) = @@ -177,9 +192,9 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom -- If we have a command, continue to execute it Just (Command _ innerCmdId innerArgs) -> execCmd ide (ExecuteCommandParams Nothing innerCmdId innerArgs) - Nothing -> return $ Right $ InL A.Null + Nothing -> return $ Right $ InR Null - A.Error _str -> return $ Right $ InL A.Null + A.Error _str -> return $ Right $ InR Null -- Just an ordinary HIE command Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams @@ -197,7 +212,9 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom Nothing -> logAndReturnError recorder p (InR ErrorCodes_InvalidRequest) (commandDoesntExist com p xs) Just (PluginCommand _ _ f) -> case A.fromJSON arg of A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg) - A.Success a -> fmap InL <$> f ide a + A.Success a -> + f ide a `catchAny` -- See Note [Exception handling in plugins] + (\e -> logAndReturnError' recorder (InR ErrorCodes_InternalError) (ExceptionInPlugin p (Some SMethod_WorkspaceApplyEdit) e)) -- --------------------------------------------------------------------- @@ -225,9 +242,8 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } msg = pluginNotEnabled m fs' return $ Left err Just fs -> do - let msg e pid = "Exception in plugin " <> T.pack (show pid) <> " while processing " <> T.pack (show m) <> ": " <> T.pack (show e) - handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs - es <- runConcurrently msg (show m) handlers ide params + let handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs + es <- runConcurrently exceptionInPlugin m handlers ide params let (errs,succs) = partitionEithers $ toList $ join $ NE.zipWith (\(pId,_) -> fmap (first (pId,))) handlers es unless (null errs) $ forM_ errs $ \(pId, err) -> @@ -261,22 +277,25 @@ extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers Just fs -> do -- We run the notifications in order, so the core ghcide provider -- (which restarts the shake process) hopefully comes last - mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params) fs + mapM_ (\(pid,_,f) -> otTracedProvider pid (fromString $ show m) $ f ide vfs params + `catchAny` -- See Note [Exception handling in plugins] + (\e -> logWith recorder Warning (ExceptionInPlugin pid (Some m) e))) fs + -- --------------------------------------------------------------------- runConcurrently :: MonadUnliftIO m - => (SomeException -> PluginId -> T.Text) - -> String -- ^ label + => (PluginId -> SMethod method -> SomeException -> T.Text) + -> SMethod method -- ^ Method (used for errors and tracing) -> NonEmpty (PluginId, a -> b -> m (NonEmpty (Either ResponseError d))) -- ^ Enabled plugin actions that we are allowed to run -> a -> b -> 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 (InR ErrorCodes_InternalError) (msg e pid) Nothing) +runConcurrently msg method fs a b = forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString (show method)) $ do + f a b -- See Note [Exception handling in plugins] + `catchAny` (\e -> pure $ pure $ Left $ ResponseError (InR ErrorCodes_InternalError) (msg pid method e) Nothing) combineErrors :: [ResponseError] -> ResponseError combineErrors [x] = x @@ -308,3 +327,16 @@ instance Semigroup IdeNotificationHandlers where go _ (IdeNotificationHandler a) (IdeNotificationHandler b) = IdeNotificationHandler (a <> b) instance Monoid IdeNotificationHandlers where mempty = IdeNotificationHandlers mempty + +{- Note [Exception handling in plugins] +Plugins run in LspM, and so have access to IO. This means they are likely to +throw exceptions, even if only by accident or through calling libraries that +throw exceptions. Ultimately, we're running a bunch of less-trusted IO code, +so we should be robust to it throwing. + +We don't want these to bring down HLS. So we catch and log exceptions wherever +we run a handler defined in a plugin. + +The flip side of this is that it's okay for plugins to throw exceptions as a +way of signalling failure! +-} diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 8d403ce8ab6..6028d29132b 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -16,8 +16,9 @@ import Control.Concurrent (threadDelay) import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM -import Data.Aeson -import Data.Aeson.Types +import Data.Aeson (FromJSON (parseJSON), + ToJSON (toJSON), Value) +import qualified Data.Aeson.Types as A import Data.Bifunctor import Data.CaseInsensitive (CI, original) import qualified Data.HashMap.Strict as HM @@ -46,7 +47,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) +import Language.LSP.Protocol.Types import qualified Language.LSP.Server as LSP import qualified "list-t" ListT import qualified StmContainers.Map as STM @@ -80,7 +81,7 @@ plugin = (defaultPluginDescriptor "test") { } where testRequestHandler' ide req - | Just customReq <- parseMaybe parseJSON req + | Just customReq <- A.parseMaybe parseJSON req = testRequestHandler ide customReq | otherwise = return $ Left @@ -94,7 +95,7 @@ testRequestHandler _ (BlockSeconds secs) = do LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/request")) $ toJSON secs liftIO $ sleep secs - return (Right Null) + return (Right A.Null) testRequestHandler s (GetInterfaceFilesDir file) = liftIO $ do let nfp = fromUri $ toNormalizedUri file sess <- runAction "Test - GhcSession" s $ use_ GhcSession nfp @@ -107,7 +108,7 @@ testRequestHandler s WaitForShakeQueue = liftIO $ do atomically $ do n <- countQueue $ actionQueue $ shakeExtras s when (n>0) retry - return $ Right Null + return $ Right A.Null testRequestHandler s (WaitForIdeRule k file) = liftIO $ do let nfp = fromUri $ toNormalizedUri file success <- runAction ("WaitForIdeRule " <> k <> " " <> show file) s $ parseAction (fromString k) nfp @@ -172,6 +173,6 @@ blockCommandDescriptor plId = (defaultPluginDescriptor plId) { blockCommandHandler :: CommandFunction state ExecuteCommandParams blockCommandHandler _ideState _params = do - LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) Null + LSP.sendNotification (SMethod_CustomMethod (Proxy @"ghcide/blocking/command")) A.Null liftIO $ threadDelay maxBound - return (Right Null) + return (Right $ InR Null) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 791d29c5c56..c5fa7e0893f 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -18,7 +18,7 @@ import Control.DeepSeq (rwhnf) import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Aeson.Types (Value (..), toJSON) +import Data.Aeson.Types (Value, toJSON) import qualified Data.Aeson.Types as A import Data.List (find) import qualified Data.Map as Map @@ -46,10 +46,10 @@ import Development.IDE.Graph.Classes import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope) import Development.IDE.Types.Location (Position (Position, _character, _line), Range (Range, _end, _start)) -import Development.IDE.Types.Logger (Pretty (pretty), +import GHC.Generics (Generic) +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) -import GHC.Generics (Generic) import Ide.Plugin.Properties import Ide.PluginUtils import Ide.Types (CommandFunction, @@ -69,10 +69,11 @@ import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams CodeLens (CodeLens), CodeLensParams (CodeLensParams, _textDocument), Diagnostic (..), + Null (Null), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit), - type (|?) (InL)) + type (|?) (..)) import qualified Language.LSP.Server as LSP import Text.Regex.TDFA ((=~), (=~~)) @@ -161,7 +162,7 @@ generateLens pId _range title edit = commandHandler :: CommandFunction IdeState WorkspaceEdit commandHandler _ideState wedit = do _ <- LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return $ Right Null + return $ Right $ InR Null -------------------------------------------------------------------------------- diff --git a/ghcide/src/Development/IDE/Types/Action.hs b/ghcide/src/Development/IDE/Types/Action.hs index 462bdc901b3..0aedd1d0da5 100644 --- a/ghcide/src/Development/IDE/Types/Action.hs +++ b/ghcide/src/Development/IDE/Types/Action.hs @@ -11,12 +11,12 @@ module Development.IDE.Types.Action where import Control.Concurrent.STM -import Data.Hashable (Hashable (..)) -import Data.HashSet (HashSet) -import qualified Data.HashSet as Set -import Data.Unique (Unique) -import Development.IDE.Graph (Action) -import Development.IDE.Types.Logger +import Data.Hashable (Hashable (..)) +import Data.HashSet (HashSet) +import qualified Data.HashSet as Set +import Data.Unique (Unique) +import Development.IDE.Graph (Action) +import Ide.Logger import Numeric.Natural data DelayedAction a = DelayedAction diff --git a/ghcide/test/exe/HieDbRetry.hs b/ghcide/test/exe/HieDbRetry.hs index c51c8bbebca..b84715c1b87 100644 --- a/ghcide/test/exe/HieDbRetry.hs +++ b/ghcide/test/exe/HieDbRetry.hs @@ -1,22 +1,21 @@ {-# LANGUAGE MultiWayIf #-} module HieDbRetry (tests) where -import Control.Concurrent.Extra (Var, modifyVar, newVar, readVar, - withVar) -import Control.Exception (ErrorCall (ErrorCall), evaluate, - throwIO, tryJust) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Tuple.Extra (dupe) -import qualified Database.SQLite.Simple as SQLite -import Development.IDE.Session (retryOnException, - retryOnSqliteBusy) -import qualified Development.IDE.Session as Session -import Development.IDE.Types.Logger (Recorder (Recorder, logger_), - WithPriority (WithPriority, payload), - cmapWithPrio) -import qualified System.Random as Random -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) +import Control.Concurrent.Extra (Var, modifyVar, newVar, readVar, + withVar) +import Control.Exception (ErrorCall (ErrorCall), evaluate, + throwIO, tryJust) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Tuple.Extra (dupe) +import qualified Database.SQLite.Simple as SQLite +import Development.IDE.Session (retryOnException, retryOnSqliteBusy) +import qualified Development.IDE.Session as Session +import Ide.Logger (Recorder (Recorder, logger_), + WithPriority (WithPriority, payload), + cmapWithPrio) +import qualified System.Random as Random +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) data Log = LogSession Session.Log diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index a81071f4ab9..c052cc8745b 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -130,7 +130,7 @@ import qualified Development.IDE.Plugin.HLS.GhcIde as Ghcide import Development.IDE.Plugin.Test (TestRequest (BlockSeconds), WaitForIdeRuleResult (..), blockCommandId) -import Development.IDE.Types.Logger (Logger (Logger), +import Ide.Logger (Logger (Logger), LoggingColumn (DataColumn, PriorityColumn), Pretty (pretty), Priority (Debug), @@ -1573,7 +1573,7 @@ completionTest name src pos expected = testSessionWait name $ do [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] forM_ (zip compls expected) $ \(item, (_,_,_,expectedSig, expectedDocs, _)) -> do CompletionItem{..} <- - if expectedSig || expectedDocs + if (expectedSig || expectedDocs) && isJust (item ^. L.data_) then do rsp <- request SMethod_CompletionItemResolve item case rsp ^. L.result of @@ -2083,10 +2083,13 @@ completionDocTests = _ <- waitForDiagnostics compls <- getCompletions doc pos rcompls <- forM compls $ \item -> do - rsp <- request SMethod_CompletionItemResolve item - case rsp ^. L.result of - Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) - Right x -> pure x + if isJust (item ^. L.data_) + then do + rsp <- request SMethod_CompletionItemResolve item + case rsp ^. L.result of + Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) + Right x -> pure x + else pure item let compls' = [ -- We ignore doc uris since it points to the local path which determined by specific machines case mn of diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 64d1aa82630..e5250eee272 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -38,13 +38,16 @@ library Ide.Plugin.ConfigUtils Ide.Plugin.Properties Ide.Plugin.RangeMap + Ide.Plugin.Resolve Ide.PluginUtils Ide.Types + Ide.Logger hs-source-dirs: src build-depends: , aeson , base >=4.12 && <5 + , co-log-core , containers , data-default , dependent-map @@ -61,10 +64,14 @@ library , lsp ^>=2.0.0.0 , opentelemetry >=0.4 , optparse-applicative + , prettyprinter , regex-tdfa >=1.3.1.0 , row-types + , stm , text + , time , transformers + , unliftio , unordered-containers , megaparsec > 9 diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/hls-plugin-api/src/Ide/Logger.hs similarity index 97% rename from ghcide/src/Development/IDE/Types/Logger.hs rename to hls-plugin-api/src/Ide/Logger.hs index aec4fa3c0ad..aab41f4e73c 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/hls-plugin-api/src/Ide/Logger.hs @@ -1,11 +1,18 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + -- | This is a compatibility module that abstracts over the -- concrete choice of logging framework so users can plug in whatever -- framework they want to. -module Development.IDE.Types.Logger +module Ide.Logger ( Priority(..) , Logger(..) , Recorder(..) @@ -65,8 +72,7 @@ import Prettyprinter.Render.Text (renderStrict) import System.IO (Handle, IOMode (AppendMode), hClose, hFlush, openFile, stderr) -import UnliftIO (MonadUnliftIO, displayException, - finally, try) +import UnliftIO (MonadUnliftIO, finally, try) data Priority -- Don't change the ordering of this type or you will mess up the Ord diff --git a/hls-plugin-api/src/Ide/Plugin/Resolve.hs b/hls-plugin-api/src/Ide/Plugin/Resolve.hs new file mode 100644 index 00000000000..73e79a3c148 --- /dev/null +++ b/hls-plugin-api/src/Ide/Plugin/Resolve.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Ide.Plugin.Resolve +(mkCodeActionHandlerWithResolve, +mkCodeActionWithResolveAndCommand) where + +import Control.Lens (_Just, (&), (.~), (?~), (^.), + (^?)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT, + throwE) +import qualified Data.Aeson as A +import Data.Maybe (catMaybes) +import Data.Row ((.!)) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Ide.Logger +import Ide.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server (LspM, LspT, + ProgressCancellable (Cancellable), + getClientCapabilities, + sendRequest, + withIndefiniteProgress) + +data Log + = DoesNotSupportResolve T.Text + | ApplyWorkspaceEditFailed ResponseError +instance Pretty Log where + pretty = \case + DoesNotSupportResolve fallback-> + "Client does not support resolve," <+> pretty fallback + ApplyWorkspaceEditFailed err -> + "ApplyWorkspaceEditFailed:" <+> viaShow err + +-- |When provided with both a codeAction provider and an affiliated codeAction +-- resolve provider, this function creates a handler that automatically uses +-- your resolve provider to fill out you original codeAction if the client doesn't +-- have codeAction resolve support. This means you don't have to check whether +-- the client supports resolve and act accordingly in your own providers. +mkCodeActionHandlerWithResolve + :: forall ideState a. (A.FromJSON a) => + Recorder (WithPriority Log) + -> (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) + -> (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either ResponseError CodeAction)) + -> PluginHandlers ideState +mkCodeActionHandlerWithResolve recorder codeActionMethod codeResolveMethod = + let newCodeActionMethod ideState pid params = runExceptT $ + do codeActionReturn <- ExceptT $ codeActionMethod ideState pid params + caps <- lift getClientCapabilities + case codeActionReturn of + r@(InR Null) -> pure r + (InL ls) | -- We don't need to do anything if the client supports + -- resolve + supportsCodeActionResolve caps -> pure $ InL ls + --This is the actual part where we call resolveCodeAction which fills in the edit data for the client + | otherwise -> do + logWith recorder Debug (DoesNotSupportResolve "filling in the code action") + InL <$> traverse (resolveCodeAction (params ^. L.textDocument . L.uri) ideState pid) ls + in (mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod + <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod) + where dropData :: CodeAction -> CodeAction + dropData ca = ca & L.data_ .~ Nothing + resolveCodeAction :: Uri -> ideState -> PluginId -> (Command |? CodeAction) -> ExceptT ResponseError (LspT Config IO) (Command |? CodeAction) + resolveCodeAction _uri _ideState _plId c@(InL _) = pure c + resolveCodeAction uri ideState pid (InR codeAction@CodeAction{_data_=Just value}) = do + case A.fromJSON value of + A.Error err -> throwE $ parseError (Just value) (T.pack err) + A.Success innerValueDecoded -> do + resolveResult <- ExceptT $ codeResolveMethod ideState pid codeAction uri innerValueDecoded + case resolveResult of + CodeAction {_edit = Just _ } -> do + pure $ InR $ dropData resolveResult + _ -> throwE $ invalidParamsError "Returned CodeAction has no data field" + resolveCodeAction _ _ _ (InR CodeAction{_data_=Nothing}) = throwE $ invalidParamsError "CodeAction has no data field" + + +-- |When provided with both a codeAction provider with a data field and a resolve +-- provider, this function creates a handler that creates a command that uses +-- your resolve if the client doesn't have code action resolve support. This means +-- you don't have to check whether the client supports resolve and act +-- accordingly in your own providers. see Note [Code action resolve fallback to commands] +-- Also: This helper only works with workspace edits, not commands. Any command set +-- either in the original code action or in the resolve will be ignored. +mkCodeActionWithResolveAndCommand + :: forall ideState a. (A.FromJSON a) => + Recorder (WithPriority Log) + -> PluginId + -> (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) + -> (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either ResponseError CodeAction)) + -> ([PluginCommand ideState], PluginHandlers ideState) +mkCodeActionWithResolveAndCommand recorder plId codeActionMethod codeResolveMethod = + let newCodeActionMethod ideState pid params = runExceptT $ + do codeActionReturn <- ExceptT $ codeActionMethod ideState pid params + caps <- lift getClientCapabilities + case codeActionReturn of + r@(InR Null) -> pure r + (InL ls) | -- We don't need to do anything if the client supports + -- resolve + supportsCodeActionResolve caps -> pure $ InL ls + -- If they do not we will drop the data field, in addition we will populate the command + -- field with our command to execute the resolve, with the whole code action as it's argument. + | otherwise -> do + logWith recorder Debug (DoesNotSupportResolve "rewriting the code action to use commands") + pure $ InL $ moveDataToCommand (params ^. L.textDocument . L.uri) <$> ls + in ([PluginCommand "codeActionResolve" "Executes resolve for code action" (executeResolveCmd codeResolveMethod)], + mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod + <> mkResolveHandler SMethod_CodeActionResolve codeResolveMethod) + where moveDataToCommand :: Uri -> Command |? CodeAction -> Command |? CodeAction + moveDataToCommand uri ca = + let dat = A.toJSON . wrapWithURI uri <$> ca ^? _R -- We need to take the whole codeAction + -- And put it in the argument for the Command, that way we can later + -- pass it to the resolve handler (which expects a whole code action) + -- It should be noted that mkLspCommand already specifies the command + -- to the plugin, so we don't need to do that here. + cmd = mkLspCommand plId (CommandId "codeActionResolve") "Execute Code Action" (pure <$> dat) + in ca + & _R . L.data_ .~ Nothing -- Set the data field to nothing + & _R . L.command ?~ cmd -- And set the command to our previously created command + wrapWithURI :: Uri -> CodeAction -> CodeAction + wrapWithURI uri codeAction = + codeAction & L.data_ .~ (A.toJSON .WithURI uri <$> data_) + where data_ = codeAction ^? L.data_ . _Just + executeResolveCmd :: (ideState -> PluginId -> CodeAction -> Uri -> a -> LspM Config (Either ResponseError CodeAction))-> CommandFunction ideState CodeAction + executeResolveCmd resolveProvider ideState ca@CodeAction{_data_=Just value} = do + withIndefiniteProgress "Applying edits for code action..." Cancellable $ runExceptT $ do + case A.fromJSON value of + A.Error err -> throwE $ parseError (Just value) (T.pack err) + A.Success (WithURI uri innerValue) -> do + case A.fromJSON innerValue of + A.Error err -> throwE $ parseError (Just value) (T.pack err) + A.Success innerValueDecoded -> do + resolveResult <- ExceptT $ resolveProvider ideState plId ca uri innerValueDecoded + case resolveResult of + ca2@CodeAction {_edit = Just wedits } | diffCodeActions ca ca2 == ["edit"] -> do + _ <- ExceptT $ Right <$> sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) handleWEditCallback + pure $ InR Null + ca2@CodeAction {_edit = Just _ } -> + throwE $ internalError $ + "The resolve provider unexpectedly returned a code action with the following differing fields: " + <> (T.pack $ show $ diffCodeActions ca ca2) + _ -> throwE $ internalError "The resolve provider unexpectedly returned a result with no data field" + executeResolveCmd _ _ CodeAction{_data_= value} = runExceptT $ throwE $ invalidParamsError ("The code action to resolve has an illegal data field: " <> (T.pack $ show value)) + handleWEditCallback (Left err ) = do + logWith recorder Warning (ApplyWorkspaceEditFailed err) + pure () + handleWEditCallback _ = pure () + +-- TODO: Remove once provided by lsp-types +-- |Compares two CodeActions and returns a list of fields that are not equal +diffCodeActions :: CodeAction -> CodeAction -> [T.Text] +diffCodeActions ca ca2 = + let titleDiff = if ca ^. L.title == ca2 ^. L.title then Nothing else Just "title" + kindDiff = if ca ^. L.kind == ca2 ^. L.kind then Nothing else Just "kind" + diagnosticsDiff = if ca ^. L.diagnostics == ca2 ^. L.diagnostics then Nothing else Just "diagnostics" + commandDiff = if ca ^. L.command == ca2 ^. L.command then Nothing else Just "diagnostics" + isPreferredDiff = if ca ^. L.isPreferred == ca2 ^. L.isPreferred then Nothing else Just "isPreferred" + dataDiff = if ca ^. L.data_ == ca2 ^. L.data_ then Nothing else Just "data" + disabledDiff = if ca ^. L.disabled == ca2 ^. L.disabled then Nothing else Just "disabled" + editDiff = if ca ^. L.edit == ca2 ^. L.edit then Nothing else Just "edit" + in catMaybes [titleDiff, kindDiff, diagnosticsDiff, commandDiff, isPreferredDiff, dataDiff, disabledDiff, editDiff] + +-- |To execute the resolve provider as a command, we need to additionally store +-- the URI that was provided to the original code action. +data WithURI = WithURI { + _uri :: Uri +, _value :: A.Value +} deriving (Generic, Show) +instance A.ToJSON WithURI +instance A.FromJSON WithURI + +-- |Checks if the the client supports resolve for code action. We currently only check +-- whether resolve for the edit field is supported, because that's the only one we care +-- about at the moment. +supportsCodeActionResolve :: ClientCapabilities -> Bool +supportsCodeActionResolve caps = + caps ^? L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just == Just True + && case caps ^? L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just of + Just row -> "edit" `elem` row .! #properties + _ -> False + +internalError :: T.Text -> ResponseError +internalError msg = ResponseError (InR ErrorCodes_InternalError) ("Ide.Plugin.Resolve: Internal Error : " <> msg) Nothing + +invalidParamsError :: T.Text -> ResponseError +invalidParamsError msg = ResponseError (InR ErrorCodes_InvalidParams) ("Ide.Plugin.Resolve: : " <> msg) Nothing + +parseError :: Maybe A.Value -> T.Text -> ResponseError +parseError value errMsg = ResponseError (InR ErrorCodes_ParseError) ("Ide.Plugin.Resolve: Error parsing value:"<> (T.pack $ show value) <> " Error: "<> errMsg) Nothing + +{- Note [Code action resolve fallback to commands] + To make supporting code action resolve easy for plugins, we want to let them + provide one implementation that can be used both when clients support + resolve, and when they don't. + The way we do this is to have them always implement a resolve handler. + Then, if the client doesn't support resolve, we instead install the resolve + handler as a _command_ handler, passing the code action literal itself + as the command argument. This allows the command handler to have + the same interface as the resolve handler! + -} diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 1c43c9c13ce..d64a26fd4f4 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -1,11 +1,13 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} + module Ide.PluginUtils ( -- * LSP Range manipulation functions normalize, extendNextLine, extendLineStart, + extendToFullLines, WithDeletions(..), getProcessID, makeDiffTextEdit, @@ -19,7 +21,7 @@ module Ide.PluginUtils getPluginConfig, configForPlugin, pluginEnabled, - extractRange, + extractTextInRange, fullRange, mkLspCommand, mkLspCmdId, @@ -36,12 +38,11 @@ module Ide.PluginUtils handleMaybeM, throwPluginError, unescape, - ) + ) where - import Control.Arrow ((&&&)) -import Control.Lens (re, (^.)) +import Control.Lens (_head, _last, re, (%~), (^.)) import Control.Monad.Extra (maybeM) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) @@ -90,17 +91,33 @@ extendLineStart :: Range -> Range extendLineStart (Range (Position sl _) e) = Range (Position sl 0) e +-- | Extend 'Range' to include the start of the first line and start of the next line of the last line. +-- +-- Caveat: It always extend the last line to the beginning of next line, even when the last position is at column 0. +-- This is to keep the compatibility with the implementation of old function @extractRange@. +-- +-- >>> extendToFullLines (Range (Position 5 5) (Position 5 10)) +-- Range (Position 5 0) (Position 6 0) +-- +-- >>> extendToFullLines (Range (Position 5 5) (Position 7 2)) +-- Range (Position 5 0) (Position 8 0) +-- +-- >>> extendToFullLines (Range (Position 5 5) (Position 7 0)) +-- Range (Position 5 0) (Position 8 0) +extendToFullLines :: Range -> Range +extendToFullLines = extendLineStart . extendNextLine + + -- --------------------------------------------------------------------- data WithDeletions = IncludeDeletions | SkipDeletions - deriving Eq + deriving (Eq) -- | Generate a 'WorkspaceEdit' value from a pair of source Text -diffText :: ClientCapabilities -> (VersionedTextDocumentIdentifier,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit +diffText :: ClientCapabilities -> (VersionedTextDocumentIdentifier, T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit diffText clientCaps old new withDeletions = - let - supports = clientSupportsDocumentChanges clientCaps - in diffText' supports old new withDeletions + let supports = clientSupportsDocumentChanges clientCaps + in diffText' supports old new withDeletions makeDiffTextEdit :: T.Text -> T.Text -> [TextEdit] makeDiffTextEdit f1 f2 = diffTextEdit f1 f2 IncludeDeletions @@ -114,13 +131,14 @@ diffTextEdit fText f2Text withDeletions = r r = map diffOperationToTextEdit diffOps d = getGroupedDiff (lines $ T.unpack fText) (lines $ T.unpack f2Text) - diffOps = filter (\x -> (withDeletions == IncludeDeletions) || not (isDeletion x)) - (diffToLineRanges d) + diffOps = + filter + (\x -> (withDeletions == IncludeDeletions) || not (isDeletion x)) + (diffToLineRanges d) isDeletion (Deletion _ _) = True isDeletion _ = False - diffOperationToTextEdit :: DiffOperation LineRange -> TextEdit diffOperationToTextEdit (Change fm to) = TextEdit range nt where @@ -136,17 +154,20 @@ diffTextEdit fText f2Text withDeletions = r -} diffOperationToTextEdit (Deletion (LineRange (sl, el) _) _) = TextEdit range "" where - range = Range (Position (fromIntegral $ sl - 1) 0) - (Position (fromIntegral el) 0) - + range = + Range + (Position (fromIntegral $ sl - 1) 0) + (Position (fromIntegral el) 0) 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 = Range (Position (fromIntegral l) 0) - (Position (fromIntegral l) 0) - nt = T.pack $ unlines $ lrContents fm + -- 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 + range = + Range + (Position (fromIntegral l) 0) + (Position (fromIntegral l) 0) + nt = T.pack $ unlines $ lrContents fm calcRange fm = Range s e where @@ -155,12 +176,11 @@ diffTextEdit fText f2Text withDeletions = r s = Position (fromIntegral $ sl - 1) sc -- Note: zero-based lines el = snd $ lrNumbers fm ec = fromIntegral $ length $ last $ lrContents fm - e = 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 -diffText' :: Bool -> (VersionedTextDocumentIdentifier,T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit -diffText' supports (verTxtDocId,fText) f2Text withDeletions = +diffText' :: Bool -> (VersionedTextDocumentIdentifier, T.Text) -> T.Text -> WithDeletions -> WorkspaceEdit +diffText' supports (verTxtDocId, fText) f2Text withDeletions = if supports then WorkspaceEdit Nothing (Just docChanges) Nothing else WorkspaceEdit (Just h) Nothing Nothing @@ -168,7 +188,7 @@ diffText' supports (verTxtDocId,fText) f2Text withDeletions = diff = diffTextEdit fText f2Text withDeletions h = M.singleton (verTxtDocId ^. L.uri) diff docChanges = [InL docEdit] - docEdit = TextDocumentEdit (verTxtDocId ^.re _versionedTextDocumentIdentifier) $ fmap InL diff + docEdit = TextDocumentEdit (verTxtDocId ^. re _versionedTextDocumentIdentifier) $ fmap InL diff -- --------------------------------------------------------------------- @@ -179,8 +199,7 @@ clientSupportsDocumentChanges caps = wCaps <- mwCaps WorkspaceEditClientCapabilities mDc _ _ _ _ <- _workspaceEdit wCaps mDc - in - Just True == supports + in Just True == supports -- --------------------------------------------------------------------- @@ -191,11 +210,11 @@ idePluginsToPluginDesc :: IdePlugins ideState -> [PluginDescriptor ideState] idePluginsToPluginDesc (IdePlugins pp) = pp -- --------------------------------------------------------------------- + -- | Returns the current client configuration. It is not wise to permanently -- cache the returned value of this function, as clients can at runtime change -- their configuration. --- -getClientConfig :: MonadLsp Config m => m Config +getClientConfig :: (MonadLsp Config m) => m Config getClientConfig = getConfig -- --------------------------------------------------------------------- @@ -203,10 +222,10 @@ getClientConfig = getConfig -- | Returns the current plugin configuration. It is not wise to permanently -- cache the returned value of this function, as clients can change their -- configuration at runtime. -getPluginConfig :: MonadLsp Config m => PluginDescriptor c -> m PluginConfig +getPluginConfig :: (MonadLsp Config m) => PluginDescriptor c -> m PluginConfig getPluginConfig plugin = do - config <- getClientConfig - return $ configForPlugin config plugin + config <- getClientConfig + return $ configForPlugin config plugin -- --------------------------------------------------------------------- @@ -223,24 +242,33 @@ usePropertyLsp kn pId p = do -- --------------------------------------------------------------------- -extractRange :: Range -> T.Text -> T.Text -extractRange (Range (Position sl _) (Position el _)) s = newS - where focusLines = take (fromIntegral $ el-sl+1) $ drop (fromIntegral sl) $ T.lines s - newS = T.unlines focusLines +-- | Extracts exact matching text in the range. +extractTextInRange :: Range -> T.Text -> T.Text +extractTextInRange (Range (Position sl sc) (Position el ec)) s = newS + where + focusLines = take (fromIntegral $ el - sl + 1) $ drop (fromIntegral sl) $ T.lines s + -- NOTE: We have to trim the last line first to handle the single-line case + newS = + focusLines + & _last %~ T.take (fromIntegral ec) + & _head %~ T.drop (fromIntegral sc) + -- NOTE: We cannot use unlines here, because we don't want to add trailing newline! + & T.intercalate "\n" -- | Gets the range that covers the entire text fullRange :: T.Text -> Range fullRange s = Range startPos endPos - where startPos = Position 0 0 - endPos = Position lastLine 0 - {- - In order to replace everything including newline characters, - the end range should extend below the last line. From the specification: - "If you want to specify a range that contains a line including - the line ending character(s) then use an end position denoting - the start of the next line" - -} - lastLine = fromIntegral $ length $ T.lines s + where + startPos = Position 0 0 + endPos = Position lastLine 0 + {- + In order to replace everything including newline characters, + the end range should extend below the last line. From the specification: + "If you want to specify a range that contains a line including + the line ending character(s) then use an end position denoting + the start of the next line" + -} + lastLine = fromIntegral $ length $ T.lines s subRange :: Range -> Range -> Bool subRange = isSubrangeOf @@ -249,34 +277,34 @@ subRange = isSubrangeOf allLspCmdIds' :: T.Text -> IdePlugins ideState -> [T.Text] allLspCmdIds' pid (IdePlugins ls) = - allLspCmdIds pid $ map (pluginId &&& pluginCommands) ls + allLspCmdIds pid $ map (pluginId &&& pluginCommands) ls allLspCmdIds :: T.Text -> [(PluginId, [PluginCommand ideState])] -> [T.Text] allLspCmdIds pid commands = concatMap go commands where go (plid, cmds) = map (mkLspCmdId pid plid . commandId) cmds - -- --------------------------------------------------------------------- -getNormalizedFilePath :: Monad m => Uri -> ExceptT String m NormalizedFilePath -getNormalizedFilePath uri = handleMaybe errMsg - $ uriToNormalizedFilePath - $ toNormalizedUri uri - where - errMsg = T.unpack $ "Failed converting " <> getUri uri <> " to NormalizedFilePath" +getNormalizedFilePath :: (Monad m) => Uri -> ExceptT String m NormalizedFilePath +getNormalizedFilePath uri = + handleMaybe errMsg $ + uriToNormalizedFilePath $ + toNormalizedUri uri + where + errMsg = T.unpack $ "Failed converting " <> getUri uri <> " to NormalizedFilePath" -- --------------------------------------------------------------------- -throwPluginError :: Monad m => String -> ExceptT String m b +throwPluginError :: (Monad m) => String -> ExceptT String m b throwPluginError = throwE -handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b +handleMaybe :: (Monad m) => e -> Maybe b -> ExceptT e m b handleMaybe msg = maybe (throwE msg) return -handleMaybeM :: Monad m => e -> m (Maybe b) -> ExceptT e m b +handleMaybeM :: (Monad m) => e -> m (Maybe b) -> ExceptT e m b handleMaybeM msg act = maybeM (throwE msg) return $ lift act -pluginResponse :: Monad m => ExceptT String m a -> m (Either ResponseError a) +pluginResponse :: (Monad m) => ExceptT String m a -> m (Either ResponseError a) pluginResponse = fmap (first (\msg -> ResponseError (InR ErrorCodes_InternalError) (fromString msg) Nothing)) . runExceptT @@ -290,9 +318,9 @@ type TextParser = P.Parsec Void T.Text -- display as is. unescape :: T.Text -> T.Text unescape input = - case P.runParser escapedTextParser "inline" input of - Left _ -> input - Right strs -> T.pack strs + case P.runParser escapedTextParser "inline" input of + Left _ -> input + Right strs -> T.pack strs -- | Parser for a string that contains double quotes. Returns unescaped string. escapedTextParser :: TextParser String @@ -303,11 +331,11 @@ escapedTextParser = concat <$> P.many (outsideStringLiteral P.<|> stringLiteral) stringLiteral :: TextParser String stringLiteral = do - inside <- P.char '"' >> P.manyTill P.charLiteral (P.char '"') - let f '"' = "\\\"" -- double quote should still be escaped - -- Despite the docs, 'showLitChar' and 'showLitString' from 'Data.Char' DOES ESCAPE unicode printable - -- characters. So we need to call 'isPrint' from 'Data.Char' manually. - f ch = if isPrint ch then [ch] else showLitChar ch "" - inside' = concatMap f inside - - pure $ "\"" <> inside' <> "\"" + inside <- P.char '"' >> P.manyTill P.charLiteral (P.char '"') + let f '"' = "\\\"" -- double quote should still be escaped + -- Despite the docs, 'showLitChar' and 'showLitString' from 'Data.Char' DOES ESCAPE unicode printable + -- characters. So we need to call 'isPrint' from 'Data.Char' manually. + f ch = if isPrint ch then [ch] else showLitChar ch "" + inside' = concatMap f inside + + pure $ "\"" <> inside' <> "\"" diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index b7aaa6e231e..bd35a3312d6 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} @@ -48,9 +49,8 @@ module Ide.Types , installSigUsr1Handler , responseError , lookupCommandProvider -, OwnedResolveData(..) -, mkCodeActionHandlerWithResolve -, mkCodeActionWithResolveAndCommand +, ResolveFunction +, mkResolveHandler ) where @@ -64,10 +64,7 @@ import System.Posix.Signals import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) import Control.Lens (_Just, (.~), (?~), (^.), (^?)) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import Data.Aeson hiding (Null, defaultOptions) -import qualified Data.Aeson import Data.Default import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap @@ -81,7 +78,6 @@ import Data.List.NonEmpty (NonEmpty (..), toList) import qualified Data.Map as Map import Data.Maybe import Data.Ord -import Data.Row ((.!)) import Data.Semigroup import Data.String import qualified Data.Text as T @@ -93,11 +89,7 @@ import Ide.Plugin.Properties import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types -import Language.LSP.Server (LspM, LspT, - ProgressCancellable (Cancellable), - getClientCapabilities, - getVirtualFile, sendRequest, - withIndefiniteProgress) +import Language.LSP.Server (LspM, LspT, getVirtualFile) import Language.LSP.VFS import Numeric.Natural import OpenTelemetry.Eventlog @@ -416,6 +408,7 @@ instance PluginMethod Request Method_TextDocumentCodeAction where uri = msgParams ^. L.textDocument . L.uri instance PluginMethod Request Method_CodeActionResolve where + -- See Note [Resolve in PluginHandlers] pluginEnabled _ msgParams pluginDesc config = pluginResolverResponsible (msgParams ^. L.data_) pluginDesc && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc) @@ -455,6 +448,7 @@ instance PluginMethod Request Method_TextDocumentCodeLens where uri = msgParams ^. L.textDocument . L.uri instance PluginMethod Request Method_CodeLensResolve where + -- See Note [Resolve in PluginHandlers] pluginEnabled _ msgParams pluginDesc config = pluginResolverResponsible (msgParams ^. L.data_) pluginDesc && pluginEnabledConfig plcCodeActionsOn (configForPlugin config pluginDesc) @@ -477,7 +471,9 @@ instance PluginMethod Request Method_TextDocumentDocumentSymbol where uri = msgParams ^. L.textDocument . L.uri instance PluginMethod Request Method_CompletionItemResolve where - pluginEnabled _ msgParams pluginDesc config = pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) + -- See Note [Resolve in PluginHandlers] + pluginEnabled _ msgParams pluginDesc config = pluginResolverResponsible (msgParams ^. L.data_) pluginDesc + && pluginEnabledConfig plcCompletionOn (configForPlugin config pluginDesc) instance PluginMethod Request Method_TextDocumentCompletion where pluginEnabled _ msgParams pluginDesc config = pluginResponsible uri pluginDesc @@ -558,9 +554,9 @@ instance PluginRequestMethod Method_TextDocumentCodeAction where | otherwise = False instance PluginRequestMethod Method_CodeActionResolve where - -- CodeAction resolve is currently only used to changed the edit field, thus - -- that's the only field we are combining. - combineResponses _ _ _ codeAction (toList -> codeActions) = codeAction & L.edit .~ mconcat ((^. L.edit) <$> codeActions) + -- A resolve request should only have one response. + -- See Note [Resolve in PluginHandlers]. + combineResponses _ _ _ _ (x :| _) = x instance PluginRequestMethod Method_TextDocumentDefinition where combineResponses _ _ _ _ (x :| _) = x @@ -580,7 +576,8 @@ instance PluginRequestMethod Method_WorkspaceSymbol where instance PluginRequestMethod Method_TextDocumentCodeLens where instance PluginRequestMethod Method_CodeLensResolve where - -- A resolve request should only ever get one response + -- A resolve request should only ever get one response. + -- See note Note [Resolve in PluginHandlers] combineResponses _ _ _ _ (x :| _) = x instance PluginRequestMethod Method_TextDocumentRename where @@ -624,16 +621,9 @@ instance PluginRequestMethod Method_TextDocumentDocumentSymbol where in [si] <> children' instance PluginRequestMethod Method_CompletionItemResolve where - -- resolving completions can only change the detail, additionalTextEdit or documentation fields - combineResponses _ _ _ _ (x :| xs) = go x xs - where go :: CompletionItem -> [CompletionItem] -> CompletionItem - go !comp [] = comp - go !comp1 (comp2:xs) - = go (comp1 - & 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 + -- A resolve request should only have one response. + -- See Note [Resolve in PluginHandlers] + combineResponses _ _ _ _ (x :| _) = x instance PluginRequestMethod Method_TextDocumentCompletion where combineResponses _ conf _ _ (toList -> xs) = snd $ consumeCompletionResponse limit $ combine xs @@ -790,15 +780,42 @@ type PluginMethodHandler a m = a -> PluginId -> MessageParams m -> LspM Config ( type PluginNotificationMethodHandler a m = a -> VFS -> PluginId -> MessageParams m -> LspM Config () --- | Make a handler for plugins with no extra data +-- | Make a handler for plugins. For how resolve works with this see +-- Note [Resolve in PluginHandlers] mkPluginHandler - :: PluginRequestMethod m + :: forall ideState m. PluginRequestMethod m => SClientMethod m -> PluginMethodHandler ideState m -> PluginHandlers ideState -mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler f') +mkPluginHandler m f = PluginHandlers $ DMap.singleton (IdeMethod m) (PluginHandler (f' m)) where - f' pid ide params = pure <$> f ide pid params + f' :: SMethod m -> PluginId -> ideState -> MessageParams m -> LspT Config IO (NonEmpty (Either ResponseError (MessageResult m))) + -- We need to have separate functions for each method that supports resolve, so far we only support CodeActions + -- CodeLens, and Completion methods. + f' SMethod_TextDocumentCodeAction pid ide params@CodeActionParams{_textDocument=TextDocumentIdentifier {_uri}} = + pure . fmap (wrapCodeActions pid _uri) <$> f ide pid params + f' SMethod_TextDocumentCodeLens pid ide params@CodeLensParams{_textDocument=TextDocumentIdentifier {_uri}} = + pure . fmap (wrapCodeLenses pid _uri) <$> f ide pid params + f' SMethod_TextDocumentCompletion pid ide params@CompletionParams{_textDocument=TextDocumentIdentifier {_uri}} = + pure . fmap (wrapCompletions pid _uri) <$> f ide pid params + + -- This is the default case for all other methods + f' _ pid ide params = pure <$> f ide pid params + + -- Todo: use fancy pancy lenses to make this a few lines + wrapCodeActions pid uri (InL ls) = + let wrapCodeActionItem pid uri (InR c) = InR $ wrapResolveData pid uri c + wrapCodeActionItem _ _ command@(InL _) = command + in InL $ wrapCodeActionItem pid uri <$> ls + wrapCodeActions _ _ (InR r) = InR r + + wrapCodeLenses pid uri (InL ls) = InL $ wrapResolveData pid uri <$> ls + wrapCodeLenses _ _ (InR r) = InR r + + wrapCompletions pid uri (InL ls) = InL $ wrapResolveData pid uri <$> ls + wrapCompletions pid uri (InR (InL cl@(CompletionList{_items}))) = + InR $ InL $ cl & L.items .~ (wrapResolveData pid uri <$> _items) + wrapCompletions _ _ (InR (InR r)) = InR $ InR r -- | Make a handler for plugins with no extra data mkPluginNotificationHandler @@ -873,10 +890,63 @@ data PluginCommand ideState = forall a. (FromJSON a) => type CommandFunction ideState a = ideState -> a - -> LspM Config (Either ResponseError Value) + -> LspM Config (Either ResponseError (Value |? Null)) -- --------------------------------------------------------------------- +type ResolveFunction ideState a (m :: Method ClientToServer Request) = + ideState + -> PluginId + -> MessageParams m + -> Uri + -> a + -> LspM Config (Either ResponseError (MessageResult m)) + +-- | Make a handler for resolve methods. In here we take your provided ResolveFunction +-- and turn it into a PluginHandlers. See Note [Resolve in PluginHandlers] +mkResolveHandler + :: forall ideState a m. (FromJSON a, PluginRequestMethod m, L.HasData_ (MessageParams m) (Maybe Value)) + => SClientMethod m + -> (ideState + ->PluginId + -> MessageParams m + -> Uri + -> a + -> LspM Config (Either ResponseError (MessageResult m))) + -> PluginHandlers ideState +mkResolveHandler m f = mkPluginHandler m $ \ideState plId params -> do + case fromJSON <$> (params ^. L.data_) of + (Just (Success (PluginResolveData owner uri value) )) -> do + if owner == plId + then + case fromJSON value of + Success decodedValue -> + let newParams = params & L.data_ ?~ value + in f ideState plId newParams uri decodedValue + Error err -> + pure $ Left $ ResponseError (InR ErrorCodes_ParseError) (parseError value err) Nothing + else pure $ Left $ ResponseError (InR ErrorCodes_InternalError) invalidRequest Nothing + (Just (Error err)) -> pure $ Left $ ResponseError (InR ErrorCodes_ParseError) (parseError (params ^. L.data_) err) Nothing + _ -> pure $ Left $ ResponseError (InR ErrorCodes_InternalError) invalidRequest Nothing + where invalidRequest = "The resolve request incorrectly got routed to the wrong resolve handler!" + parseError value err = "Unable to decode: " <> (T.pack $ show value) <> ". Error: " <> (T.pack $ show err) + +wrapResolveData :: L.HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a +wrapResolveData pid uri hasData = + hasData & L.data_ .~ (toJSON . PluginResolveData pid uri <$> data_) + where data_ = hasData ^? L.data_ . _Just + +-- |Allow plugins to "own" resolve data, allowing only them to be queried for +-- the resolve action. This design has added flexibility at the cost of nested +-- Value types +data PluginResolveData = PluginResolveData { + resolvePlugin :: PluginId +, resolveURI :: Uri +, resolveValue :: Value +} + deriving (Generic, Show) + deriving anyclass (ToJSON, FromJSON) + newtype PluginId = PluginId T.Text deriving (Show, Read, Eq, Ord) deriving newtype (ToJSON, FromJSON, Hashable) @@ -979,11 +1049,16 @@ instance HasTracing WorkspaceSymbolParams where traceWithSpan sp (WorkspaceSymbolParams _ _ query) = setTag sp "query" (encodeUtf8 query) instance HasTracing CallHierarchyIncomingCallsParams instance HasTracing CallHierarchyOutgoingCallsParams -instance HasTracing CompletionItem + +-- Instances for resolve types instance HasTracing CodeAction instance HasTracing CodeLens +instance HasTracing CompletionItem +instance HasTracing DocumentLink +instance HasTracing InlayHint +instance HasTracing WorkspaceSymbol -- --------------------------------------------------------------------- - +--Experimental resolve refactoring {-# NOINLINE pROCESS_ID #-} pROCESS_ID :: T.Text pROCESS_ID = unsafePerformIO getPid @@ -1016,124 +1091,39 @@ getProcessID = fromIntegral <$> P.getProcessID installSigUsr1Handler h = void $ installHandler sigUSR1 (Catch h) Nothing #endif --- |When provided with both a codeAction provider and an affiliated codeAction --- resolve provider, this function creates a handler that automatically uses --- your resolve provider to fill out you original codeAction if the client doesn't --- have codeAction resolve support. This means you don't have to check whether --- the client supports resolve and act accordingly in your own providers. -mkCodeActionHandlerWithResolve - :: forall ideState. (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) - -> (ideState -> PluginId -> CodeAction -> LspM Config (Either ResponseError CodeAction)) - -> PluginHandlers ideState -mkCodeActionHandlerWithResolve codeActionMethod codeResolveMethod = - let newCodeActionMethod ideState pid params = runExceptT $ - do codeActionReturn <- ExceptT $ codeActionMethod ideState pid params - caps <- lift getClientCapabilities - case codeActionReturn of - r@(InR Null) -> pure r - (InL ls) | -- If the client supports resolve, we will wrap the resolve data in a owned - -- resolve data type to allow the server to know who to send the resolve request to - supportsCodeActionResolve caps -> pure $ InL (wrapCodeActionResolveData pid <$> ls) - --This is the actual part where we call resolveCodeAction which fills in the edit data for the client - | otherwise -> InL <$> traverse (resolveCodeAction ideState pid) ls - newCodeResolveMethod ideState pid params = - codeResolveMethod ideState pid (unwrapCodeActionResolveData params) - in mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod - <> mkPluginHandler SMethod_CodeActionResolve newCodeResolveMethod - where - dropData :: CodeAction -> CodeAction - dropData ca = ca & L.data_ .~ Nothing - resolveCodeAction :: ideState -> PluginId -> (Command |? CodeAction) -> ExceptT ResponseError (LspT Config IO) (Command |? CodeAction) - resolveCodeAction _ideState _pid c@(InL _) = pure c - resolveCodeAction ideState pid (InR codeAction) = - fmap (InR . dropData) $ ExceptT $ codeResolveMethod ideState pid codeAction - --- |When provided with both a codeAction provider that includes both a command --- and a data field and a resolve provider, this function creates a handler that --- defaults to using your command if the client doesn't have code action resolve --- support. This means you don't have to check whether the client supports resolve --- and act accordingly in your own providers. -mkCodeActionWithResolveAndCommand - :: forall ideState. - PluginId - -> (ideState -> PluginId -> CodeActionParams -> LspM Config (Either ResponseError ([Command |? CodeAction] |? Null))) - -> (ideState -> PluginId -> CodeAction -> LspM Config (Either ResponseError CodeAction)) - -> ([PluginCommand ideState], PluginHandlers ideState) -mkCodeActionWithResolveAndCommand plId codeActionMethod codeResolveMethod = - let newCodeActionMethod ideState pid params = runExceptT $ - do codeActionReturn <- ExceptT $ codeActionMethod ideState pid params - caps <- lift getClientCapabilities - case codeActionReturn of - r@(InR Null) -> pure r - (InL ls) | -- If the client supports resolve, we will wrap the resolve data in a owned - -- resolve data type to allow the server to know who to send the resolve request to - supportsCodeActionResolve caps -> - pure $ InL (wrapCodeActionResolveData pid <$> ls) - -- If they do not we will drop the data field, in addition we will populate the command - -- field with our command to execute the resolve, with the whole code action as it's argument. - | otherwise -> pure $ InL $ moveDataToCommand <$> ls - newCodeResolveMethod ideState pid params = - codeResolveMethod ideState pid (unwrapCodeActionResolveData params) - in ([PluginCommand "codeActionResolve" "Executes resolve for code action" (executeResolveCmd plId codeResolveMethod)], - mkPluginHandler SMethod_TextDocumentCodeAction newCodeActionMethod - <> mkPluginHandler SMethod_CodeActionResolve newCodeResolveMethod) - where moveDataToCommand :: Command |? CodeAction -> Command |? CodeAction - moveDataToCommand ca = - let dat = toJSON <$> ca ^? _R -- We need to take the whole codeAction - -- And put it in the argument for the Command, that way we can later - -- pas it to the resolve handler (which expects a whole code action) - cmd = mkLspCommand plId (CommandId "codeActionResolve") "Execute Code Action" (pure <$> dat) - in ca - & _R . L.data_ .~ Nothing -- Set the data field to nothing - & _R . L.command ?~ cmd -- And set the command to our previously created command - executeResolveCmd :: PluginId -> PluginMethodHandler ideState Method_CodeActionResolve -> CommandFunction ideState CodeAction - executeResolveCmd pluginId resolveProvider ideState ca = do - withIndefiniteProgress "Executing code action..." Cancellable $ do - resolveResult <- resolveProvider ideState pluginId ca - case resolveResult of - Right CodeAction {_edit = Just wedits } -> do - _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedits) (\_ -> pure ()) - pure $ Right Data.Aeson.Null - Right _ -> pure $ Left $ responseError "No edit in CodeAction" - Left err -> pure $ Left err - -supportsCodeActionResolve :: ClientCapabilities -> Bool -supportsCodeActionResolve caps = - caps ^? L.textDocument . _Just . L.codeAction . _Just . L.dataSupport . _Just == Just True - && case caps ^? L.textDocument . _Just . L.codeAction . _Just . L.resolveSupport . _Just of - Just row -> "edit" `elem` row .! #properties - _ -> False - --- We don't wrap commands -wrapCodeActionResolveData :: PluginId -> (a |? CodeAction) -> a |? CodeAction -wrapCodeActionResolveData _pid c@(InL _) = c -wrapCodeActionResolveData pid (InR c@(CodeAction{_data_=Just x})) = - InR $ c & L.data_ ?~ toJSON (ORD pid x) --- Neither do we wrap code actions's without data fields, -wrapCodeActionResolveData _pid c@(InR (CodeAction{_data_=Nothing})) = c - -unwrapCodeActionResolveData :: CodeAction -> CodeAction -unwrapCodeActionResolveData c@CodeAction{_data_ = Just x} - | Success ORD {value = v} <- fromJSON x = c & L.data_ ?~ v --- If we can't successfully decode the value as a ORD type than --- we just return the codeAction untouched. -unwrapCodeActionResolveData c = c - --- |Allow plugins to "own" resolve data, allowing only them to be queried for --- the resolve action. This design has added flexibility at the cost of nested --- Value types -data OwnedResolveData = ORD { - owner :: PluginId -, value :: Value -} deriving (Generic, Show) -instance ToJSON OwnedResolveData -instance FromJSON OwnedResolveData - +-- |Determine whether this request should be routed to the plugin. Fails closed +-- if we can't determine which plugin it should be routed to. pluginResolverResponsible :: Maybe Value -> PluginDescriptor c -> Bool -pluginResolverResponsible (Just val) pluginDesc = - case fromJSON val of - (Success (ORD o _)) -> pluginId pluginDesc == o - _ -> True -- We want to fail open in case our resolver is not using the ORD type --- This is a wierd case, because anything that gets resolved should have a data --- field, but in any case, failing open is safe enough. -pluginResolverResponsible Nothing _ = True +pluginResolverResponsible (Just (fromJSON -> (Success (PluginResolveData o _ _)))) pluginDesc = + pluginId pluginDesc == o +-- We want to fail closed +pluginResolverResponsible _ _ = False + +{- Note [Resolve in PluginHandlers] + Resolve methods have a few guarantees that need to be made by HLS, + specifically they need to only be called once, as neither their errors nor + their responses can be easily combined. Whereas commands, which similarly have + the same requirements have their own codepaths for execution, for resolve + methods we are relying on the standard PluginHandlers codepath. + That isn't a problem, but it does mean we need to do some things extra for + these methods. + - First of all, whenever a handler that can be resolved sets the data_ field + in their response, we need to intercept it, and wrap it in a data type + PluginResolveData that allows us to route the future resolve request to the + specific plugin which is responsible for it. (We also throw in the URI for + convenience, because everyone needs that). We do that in mkPluginHandler. + - When we get any resolve requests we check their data field for our + PluginResolveData that will allow us to route the request to the right + plugin. If we can't find out which plugin to route the request to, then we + just don't route it at all. This is done in pluginEnabled, and + pluginResolverResponsible. + - Finally we have mkResolveHandler, which takes the resolve request and + unwraps the plugins data from our PluginResolveData, parses it and passes it + it on to the registered handler. + It should be noted that there are some restrictions with this approach: First, + if a plugin does not set the data_ field, than the request will not be able + to be resolved. This is because we only wrap data_ fields that have been set + with our PluginResolvableData tag. Second, if a plugin were to register two + resolve handlers for the same method, than our assumptions that we never have + two responses break, and behavior is undefined. + -} diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 97c0e03fe19..1805a61d826 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -84,17 +84,17 @@ 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), +import Development.IDE.Types.Options +import GHC.IO.Handle +import GHC.Stack (emptyCallStack) +import GHC.TypeLits +import Ide.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.TypeLits import Ide.Types import Language.LSP.Protocol.Capabilities import Language.LSP.Protocol.Message 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 e64c6262279..cd1dddbb0c9 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 @@ -20,8 +20,8 @@ import Development.IDE.GHC.Util (getExtensions) import Development.IDE.Graph.Classes (Hashable, NFData, rnf) import Development.IDE.Spans.Pragmas (NextPragmaInfo, getFirstPragma, insertNewPragma) -import Development.IDE.Types.Logger as Logger import GHC.Generics (Generic) +import Ide.Logger as Logger import Ide.Plugin.Conversion (AlternateFormat, ExtensionNeeded (NeedsExtension, NoExtension), alternateFormat) diff --git a/plugins/hls-call-hierarchy-plugin/test/Main.hs b/plugins/hls-call-hierarchy-plugin/test/Main.hs index 678b970e573..a340ae8c829 100644 --- a/plugins/hls-call-hierarchy-plugin/test/Main.hs +++ b/plugins/hls-call-hierarchy-plugin/test/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} @@ -504,25 +505,40 @@ outgoingCallMultiFileTestCase filepath queryX queryY mp = _ -> liftIO $ assertFailure "Not one element" closeDoc doc -oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem) -> Assertion +oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem -> Assertion) -> Assertion oneCaseWithCreate contents queryX queryY expected = withCanonicalTempDir $ \dir -> runSessionWithServer plugin dir $ do doc <- createDoc "A.hs" "haskell" contents waitForIndex (dir "A.hs") Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>= \case - [item] -> liftIO $ item @?= expected (doc ^. L.uri) + [item] -> liftIO $ expected (doc ^. L.uri) item res -> liftIO $ assertFailure "Not one element" closeDoc doc -mkCallHierarchyItem' :: String -> T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem -mkCallHierarchyItem' prefix name kind range selRange uri = - CallHierarchyItem name kind Nothing (Just "Main") uri range selRange (Just v) +mkCallHierarchyItem' :: String -> T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem -> Assertion +mkCallHierarchyItem' prefix name kind range selRange uri c@(CallHierarchyItem name' kind' tags' detail' uri' range' selRange' xdata') = do + assertHierarchyItem name name' + assertHierarchyItem kind kind' + assertHierarchyItem tags tags' + assertHierarchyItem detail detail' + assertHierarchyItem uri uri' + assertHierarchyItem range range' + assertHierarchyItem selRange selRange' + case xdata' of + Nothing -> assertFailure ("In " ++ show c ++ ", got Nothing for data but wanted " ++ show xdata) + Just v -> case fromJSON v of + Success v -> assertBool ("In " ++ show c ++ " wanted data prefix: " ++ show xdata) (xdata `T.isPrefixOf` v) + Error err -> assertFailure ("In " ++ show c ++ " wanted data prefix: " ++ show xdata ++ " but json parsing failed with " ++ show err) where - v = toJSON $ prefix <> ":" <> T.unpack name <> ":Main:main" + tags = Nothing + detail = Just "Main" + assertHierarchyItem :: forall a. (Eq a, Show a) => a -> a -> Assertion + assertHierarchyItem = assertEqual ("In " ++ show c ++ ", got unexpected value for field") + xdata = T.pack prefix <> ":" <> name <> ":Main:main" mkCallHierarchyItemC, mkCallHierarchyItemT, mkCallHierarchyItemV :: - T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem + T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem -> Assertion mkCallHierarchyItemC = mkCallHierarchyItem' "c" mkCallHierarchyItemT = mkCallHierarchyItem' "t" mkCallHierarchyItemV = mkCallHierarchyItem' "v" 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 3f125ab7468..05134c88a6d 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -12,7 +12,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT, throwE) import Control.Monad.Trans.Maybe -import Data.Aeson +import Data.Aeson hiding (Null) import Data.Bifunctor (second) import Data.Either.Extra (rights) import Data.List @@ -37,7 +37,7 @@ 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.Protocol.Types import Language.LSP.Server addMethodPlaceholders :: PluginId -> CommandFunction IdeState AddMinimalMethodsParams @@ -64,7 +64,7 @@ addMethodPlaceholders _ state param@AddMinimalMethodsParams{..} = do void $ lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - pure Null + pure $ InR Null where toTextDocumentEdit edit = TextDocumentEdit (verTxtDocId ^.re _versionedTextDocumentIdentifier) [InL edit] 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 fe8af4b8123..462a3af2348 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -7,7 +7,7 @@ module Ide.Plugin.Class.CodeLens where import Control.Lens ((^.)) import Control.Monad.IO.Class (liftIO) -import Data.Aeson +import Data.Aeson hiding (Null) import Data.Maybe (mapMaybe, maybeToList) import qualified Data.Text as T import Development.IDE @@ -21,7 +21,7 @@ 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.Protocol.Types import Language.LSP.Server (sendRequest) codeLens :: PluginMethodHandler IdeState Method_TextDocumentCodeLens @@ -143,4 +143,4 @@ codeLens state plId CodeLensParams{..} = pluginResponse $ do codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit codeLensCommandHandler _ wedit = do _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return $ Right Null + return $ Right $ InR Null 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 1e2dfeccadf..5a9a8580533 100644 --- a/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal +++ b/plugins/hls-code-range-plugin/hls-code-range-plugin.cabal @@ -64,6 +64,7 @@ test-suite tests , filepath , ghcide == 2.1.0.0 , hls-code-range-plugin + , hls-plugin-api , hls-test-utils == 2.1.0.0 , lens , lsp 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 57a40f8411d..c7413e1e9a6 100644 --- a/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs +++ b/plugins/hls-code-range-plugin/src/Ide/Plugin/CodeRange.hs @@ -35,7 +35,7 @@ import Development.IDE (Action, IdeAction, import Development.IDE.Core.PositionMapping (PositionMapping, fromCurrentPosition, toCurrentRange) -import Development.IDE.Types.Logger (Pretty (..), +import Ide.Logger (Pretty (..), Priority (Warning), logWith) import Ide.Plugin.CodeRange.Rules (CodeRange (..), diff --git a/plugins/hls-code-range-plugin/test/Main.hs b/plugins/hls-code-range-plugin/test/Main.hs index a1948ce51a4..1b78ba74e87 100644 --- a/plugins/hls-code-range-plugin/test/Main.hs +++ b/plugins/hls-code-range-plugin/test/Main.hs @@ -6,7 +6,7 @@ import Control.Lens hiding (List, (<.>)) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Char8 as LBSChar8 import Data.String (fromString) -import Development.IDE.Types.Logger (Priority (Debug), +import Ide.Logger (Priority (Debug), Recorder (Recorder), WithPriority (WithPriority), makeDefaultStderrRecorder, diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs index f5e9ec6b1d6..5084e9750fb 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs @@ -12,7 +12,7 @@ module Ide.Plugin.Eval ( ) where import Development.IDE (IdeState) -import Development.IDE.Types.Logger (Pretty (pretty), Recorder, +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) import qualified Ide.Plugin.Eval.CodeLens as CL import Ide.Plugin.Eval.Config diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs index 44138503981..323e3384ec1 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Rules.hs @@ -38,7 +38,7 @@ import Development.IDE.GHC.Compat import qualified Development.IDE.GHC.Compat as SrcLoc import qualified Development.IDE.GHC.Compat.Util as FastString import Development.IDE.Graph (alwaysRerun) -import Development.IDE.Types.Logger (Pretty (pretty), +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) #if MIN_VERSION_ghc(9,2,0) 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 f8e44fa19ec..c4f0847f5b4 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -18,7 +18,7 @@ import Control.Exception (SomeException, evaluate, import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) -import Data.Aeson (Value (Null)) +import Data.Aeson (Value) import Data.String (IsString (fromString)) import qualified Data.Text as T import Development.IDE (IdeState, Priority (..), @@ -32,7 +32,7 @@ import GHC.Stack (HasCallStack, callStack, srcLocStartCol, srcLocStartLine) import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding (Null) +import Language.LSP.Protocol.Types import Language.LSP.Server import System.FilePath (takeExtension) import System.Time.Extra (duration, showDuration) @@ -66,7 +66,7 @@ logLevel = Debug -- Info isLiterate :: FilePath -> Bool isLiterate x = takeExtension x `elem` [".lhs", ".lhs-boot"] -response' :: ExceptT String (LspM c) WorkspaceEdit -> LspM c (Either ResponseError Value) +response' :: ExceptT String (LspM c) WorkspaceEdit -> LspM c (Either ResponseError (Value |? Null)) response' act = do res <- runExceptT act `catchAny` showErr @@ -75,7 +75,7 @@ response' act = do return $ Left (ResponseError (InR ErrorCodes_InternalError) (fromString e) Nothing) Right a -> do _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ()) - return $ Right Null + return $ Right $ InR Null gStrictTry :: (MonadIO m, MonadCatch m) => m b -> m (Either String b) gStrictTry op = 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 94e6e807e4e..0b0f8189220 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -19,7 +19,16 @@ source-repository head type: git location: https://github.com/haskell/haskell-language-server.git +flag pedantic + description: Enable -Werror + default: False + manual: True + +common warnings + ghc-options: -Wall + library + import: warnings buildable: True exposed-modules: Ide.Plugin.ExplicitImports hs-source-dirs: src @@ -32,8 +41,10 @@ library , ghcide == 2.1.0.0 , hls-graph , hls-plugin-api == 2.1.0.0 + , lens , lsp , text + , transformers , unordered-containers default-language: Haskell2010 @@ -41,7 +52,11 @@ library DataKinds TypeOperators + if flag(pedantic) + ghc-options: -Werror + test-suite tests + import: warnings buildable: True type: exitcode-stdio-1.0 default-language: Haskell2010 @@ -50,8 +65,11 @@ test-suite tests ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: , base + , extra , filepath , hls-explicit-imports-plugin , hls-test-utils + , lens , lsp-types - , text + , row-types + , text \ No newline at end of file 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 741d3a87c31..cc9927291e7 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Ide.Plugin.ExplicitImports ( descriptor , descriptorForModules @@ -19,41 +19,56 @@ module Ide.Plugin.ExplicitImports ) where import Control.DeepSeq +import Control.Lens ((&), (?~)) import Control.Monad.IO.Class -import Data.Aeson (ToJSON (toJSON), - Value (Null)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Maybe +import qualified Data.Aeson as A (ToJSON (toJSON)) import Data.Aeson.Types (FromJSON) -import qualified Data.HashMap.Strict as HashMap +import qualified Data.IntMap as IM (IntMap, elems, + fromList, (!?)) import Data.IORef (readIORef) import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromMaybe, - isJust) import Data.String (fromString) import qualified Data.Text as T +import Data.Traversable (for) +import qualified Data.Unique as U (hashUnique, + newUnique) import Development.IDE hiding (pluginHandlers, pluginRules) import Development.IDE.Core.PositionMapping import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding ((<+>)) import Development.IDE.Graph.Classes -import Development.IDE.Types.Logger as Logger (Pretty (pretty)) import GHC.Generics (Generic) -import Ide.PluginUtils (mkLspCommand) +import Ide.Plugin.RangeMap (filterByRange) +import qualified Ide.Plugin.RangeMap as RM (RangeMap, fromList) +import Ide.Plugin.Resolve +import Ide.PluginUtils (getNormalizedFilePath, + 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 (Null) +import Language.LSP.Protocol.Types import Language.LSP.Server importCommandId :: CommandId importCommandId = "ImportLensCommand" -newtype Log +data Log = LogShake Shake.Log - deriving Show + | LogWAEResponseError ResponseError + | forall a. (Pretty a) => LogResolve a + instance Pretty Log where pretty = \case - LogShake log -> pretty log + LogShake logMsg -> pretty logMsg + LogWAEResponseError rspErr -> "RequestWorkspaceApplyEdit Failed with " <+> viaShow rspErr + LogResolve msg -> pretty msg -- | The "main" function of a plugin descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState @@ -67,37 +82,36 @@ descriptorForModules -- ^ Predicate to select modules that will be annotated -> PluginId -> PluginDescriptor IdeState -descriptorForModules recorder pred plId = - (defaultPluginDescriptor plId) +descriptorForModules recorder modFilter plId = + let resolveRecorder = cmapWithPrio LogResolve recorder + codeActionHandlers = mkCodeActionHandlerWithResolve resolveRecorder (codeActionProvider recorder) (codeActionResolveProvider recorder) + in (defaultPluginDescriptor plId) { -- This plugin provides a command handler - pluginCommands = [importLensCommand], + pluginCommands = [PluginCommand importCommandId "Explicit import command" (runImportCommand recorder)], -- This plugin defines a new rule - pluginRules = minimalImportsRule recorder, - pluginHandlers = mconcat - [ -- This plugin provides code lenses - mkPluginHandler SMethod_TextDocumentCodeLens $ lensProvider pred + pluginRules = minimalImportsRule recorder modFilter, + pluginHandlers = + -- This plugin provides code lenses + mkPluginHandler SMethod_TextDocumentCodeLens (lensProvider recorder) + <> mkResolveHandler SMethod_CodeLensResolve (lensResolveProvider recorder) -- This plugin provides code actions - , mkPluginHandler SMethod_TextDocumentCodeAction $ codeActionProvider pred - ] - } + <> codeActionHandlers --- | The command descriptor -importLensCommand :: PluginCommand IdeState -importLensCommand = - PluginCommand importCommandId "Explicit import command" runImportCommand - --- | The type of the parameters accepted by our command -newtype ImportCommandParams = ImportCommandParams WorkspaceEdit - deriving (Generic) - deriving anyclass (FromJSON, ToJSON) + } -- | The actual command handler -runImportCommand :: CommandFunction IdeState ImportCommandParams -runImportCommand _state (ImportCommandParams edit) = do - -- This command simply triggers a workspace edit! - _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - return (Right Null) +runImportCommand :: Recorder (WithPriority Log) -> CommandFunction IdeState EIResolveData +runImportCommand recorder ideState eird@(ResolveOne _ _) = pluginResponse $ do + wedit <- resolveWTextEdit ideState eird + _ <- lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) logErrors + return $ InR Null + where logErrors (Left re@(ResponseError{})) = do + logWith recorder Error (LogWAEResponseError re) + pure () + logErrors (Right _) = pure () +runImportCommand _ _ (ResolveAll _) = do + pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexpected argument for command handler: ResolveAll" Nothing -- | For every implicit import statement, return a code lens of the corresponding explicit import -- Example - for the module below: @@ -109,75 +123,102 @@ 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 Method_TextDocumentCodeLens -lensProvider - pred - state -- ghcide state, used to retrieve typechecking artifacts - pId -- plugin Id - CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} - -- VSCode uses URIs instead of file paths - -- haskell-lsp provides conversion functions - | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = liftIO $ - do - mbMinImports <- runAction "MinimalImports" state $ useWithStale MinimalImports nfp - case mbMinImports of - -- Implement the provider logic: - -- for every import, if it's lacking a explicit list, generate a code lens - Just (MinimalImportsResult minImports, posMapping) -> do - commands <- - sequence - [ generateLens pId _uri edit - | (imp, Just minImport) <- minImports, - Just edit <- [mkExplicitEdit pred posMapping imp minImport] - ] - return $ Right $ InL $ catMaybes commands - _ -> - return $ Right $ InL [] - | otherwise = - return $ Right $ InL [] - --- | If there are any implicit imports, provide one code action to turn them all +lensProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeLens +lensProvider _ state _ CodeLensParams {_textDocument = TextDocumentIdentifier {_uri}} + = pluginResponse $ do + nfp <- getNormalizedFilePath _uri + mbMinImports <- liftIO $ runAction "MinimalImports" state $ use MinimalImports nfp + case mbMinImports of + Just (MinimalImportsResult{forLens}) -> do + let lens = [ generateLens _uri range int + | (range, int) <- forLens] + pure $ InL lens + _ -> + pure $ InL [] + where generateLens :: Uri -> Range -> Int -> CodeLens + generateLens uri range int = + CodeLens { _data_ = Just $ A.toJSON $ ResolveOne uri int + , _range = range + , _command = Nothing } + +lensResolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState EIResolveData 'Method_CodeLensResolve +lensResolveProvider _ ideState plId cl uri rd@(ResolveOne _ uid) + = pluginResponse $ do + nfp <- getNormalizedFilePath uri + (MinimalImportsResult{forResolve}) <- + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp + target <- handleMaybe "Unable to resolve lens" $ forResolve IM.!? uid + let updatedCodeLens = cl & L.command ?~ mkCommand plId target + pure updatedCodeLens + where mkCommand :: PluginId -> TextEdit -> Command + mkCommand pId TextEdit{_newText} = + let title = abbreviateImportTitle _newText + in mkLspCommand pId importCommandId title (Just $ [A.toJSON rd]) +lensResolveProvider _ _ _ _ _ (ResolveAll _) = do + pure $ Left $ ResponseError (InR ErrorCodes_InvalidParams) "Unexpected argument for lens resolve handler: ResolveAll" Nothing + +-- | If there are any implicit imports, provide both one code action per import +-- to make that specific import explicit, and one code action to turn them all -- into explicit imports. -codeActionProvider :: (ModuleName -> Bool) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction -codeActionProvider pred ideState _pId (CodeActionParams _ _ docId range _context) - | TextDocumentIdentifier {_uri} <- docId, - Just nfp <- uriToNormalizedFilePath $ toNormalizedUri _uri = liftIO $ - do - pm <- runIde ideState $ use GetParsedModule nfp - let insideImport = case pm of - Just ParsedModule {pm_parsed_source} - | locImports <- hsmodImports (unLoc pm_parsed_source), - rangesImports <- map getLoc locImports -> - any (within range) rangesImports - _ -> False - if not insideImport - then return (Right (InL [])) - else do - minImports <- runAction "MinimalImports" ideState $ use MinimalImports nfp - let edits = - [ e - | (imp, Just explicit) <- - maybe [] getMinimalImportsResult minImports, - Just e <- [mkExplicitEdit pred zeroMapping imp explicit] - ] - caExplicitImports = InR CodeAction {..} - _title = "Make all imports explicit" - _kind = Just CodeActionKind_QuickFix - _command = Nothing - _edit = Just WorkspaceEdit {_changes, _documentChanges, _changeAnnotations} - _changes = Just $ Map.singleton _uri edits - _documentChanges = Nothing - _diagnostics = Nothing - _isPreferred = Nothing - _disabled = Nothing - _data_ = Nothing - _changeAnnotations = Nothing - return $ Right $ InL [caExplicitImports | not (null edits)] - | otherwise = - return $ Right $ InL [] - +codeActionProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction +codeActionProvider _ ideState _pId (CodeActionParams _ _ TextDocumentIdentifier {_uri} range _context) + = pluginResponse $ do + nfp <- getNormalizedFilePath _uri + (MinimalImportsResult{forCodeActions}) <- + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp + let relevantCodeActions = filterByRange range forCodeActions + allExplicit = + [InR $ mkCodeAction "Make all imports explicit" (Just $ A.toJSON $ ResolveAll _uri) + | not $ null relevantCodeActions ] + toCodeAction uri (_, int) = + mkCodeAction "Make this import explicit" (Just $ A.toJSON $ ResolveOne uri int) + pure $ InL ((InR . toCodeAction _uri <$> relevantCodeActions) <> allExplicit) + where mkCodeAction title data_ = + CodeAction + { _title = title + , _kind = Just CodeActionKind_QuickFix + , _command = Nothing + , _edit = Nothing + , _diagnostics = Nothing + , _isPreferred = Nothing + , _disabled = Nothing + , _data_ = data_} + +codeActionResolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState EIResolveData 'Method_CodeActionResolve +codeActionResolveProvider _ ideState _ ca _ rd = + pluginResponse $ do + wedit <- resolveWTextEdit ideState rd + pure $ ca & L.edit ?~ wedit -------------------------------------------------------------------------------- +resolveWTextEdit :: IdeState -> EIResolveData -> ExceptT String (LspT Config IO) WorkspaceEdit +resolveWTextEdit ideState (ResolveOne uri int) = do + nfp <- getNormalizedFilePath uri + (MinimalImportsResult{forResolve}) <- + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp + tedit <- handleMaybe "Unable to resolve text edit" $ forResolve IM.!? int + pure $ mkWorkspaceEdit uri [tedit] +resolveWTextEdit ideState (ResolveAll uri) = do + nfp <- getNormalizedFilePath uri + (MinimalImportsResult{forResolve}) <- + handleMaybeM "Unable to run Minimal Imports" + $ liftIO + $ runAction "MinimalImports" ideState $ use MinimalImports nfp + let edits = IM.elems forResolve + pure $ mkWorkspaceEdit uri edits + +mkWorkspaceEdit :: Uri -> [TextEdit] -> WorkspaceEdit +mkWorkspaceEdit uri edits = + WorkspaceEdit {_changes = Just $ Map.fromList [(uri, edits)] + , _documentChanges = Nothing + , _changeAnnotations = Nothing} + data MinimalImports = MinimalImports deriving (Show, Generic, Eq, Ord) @@ -187,13 +228,31 @@ instance NFData MinimalImports type instance RuleResult MinimalImports = MinimalImportsResult -newtype MinimalImportsResult = MinimalImportsResult - {getMinimalImportsResult :: [(LImportDecl GhcRn, Maybe T.Text)]} +data MinimalImportsResult = MinimalImportsResult + { -- |For providing the code lenses we need to have a range, and a unique id + -- that is later resolved to the new text for each import. It is stored in + -- a list, because we always need to provide all the code lens in a file. + forLens :: [(Range, Int)] + -- |For the code actions we have the same data as for the code lenses, but + -- we store it in a RangeMap, because that allows us to filter on a specific + -- range with better performance, and code actions are almost always only + -- requested for a specific range + , forCodeActions :: RM.RangeMap (Range, Int) + -- |For resolve we have an intMap where for every previously provided unique id + -- we provide a textEdit to allow our code actions or code lens to be resolved + , forResolve :: IM.IntMap TextEdit } instance Show MinimalImportsResult where show _ = "" instance NFData MinimalImportsResult where rnf = rwhnf +data EIResolveData = ResolveOne + { uri :: Uri + , importId :: Int } + | ResolveAll + { uri :: Uri } + deriving (Generic, A.ToJSON, FromJSON) + exportedModuleStrings :: ParsedModule -> [String] exportedModuleStrings ParsedModule{pm_parsed_source = L _ HsModule{..}} | Just export <- hsmodExports, @@ -201,62 +260,66 @@ exportedModuleStrings ParsedModule{pm_parsed_source = L _ HsModule{..}} = map (T.unpack . printOutputable) exports exportedModuleStrings _ = [] -minimalImportsRule :: Recorder (WithPriority Log) -> Rules () -minimalImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \MinimalImports nfp -> do +minimalImportsRule :: Recorder (WithPriority Log) -> (ModuleName -> Bool) -> Rules () +minimalImportsRule recorder modFilter = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \MinimalImports nfp -> runMaybeT $ do -- Get the typechecking artifacts from the module - tmr <- use TypeCheck nfp + (tmr, tmrpm) <- MaybeT $ useWithStale TypeCheck nfp -- We also need a GHC session with all the dependencies - hsc <- use GhcSessionDeps nfp + (hsc, _) <- MaybeT $ useWithStale GhcSessionDeps nfp -- Use the GHC api to extract the "minimal" imports - (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr + (imports, mbMinImports) <- MaybeT $ liftIO $ extractMinimalImports hsc tmr let importsMap = Map.fromList [ (realSrcSpanStart l, printOutputable i) - | L (locA -> RealSrcSpan l _) i <- fromMaybe [] mbMinImports - , not (isImplicitPrelude i) + | L (locA -> RealSrcSpan l _) i <- mbMinImports ] res = - [ (i, Map.lookup (realSrcSpanStart l) importsMap) - | i <- imports - , RealSrcSpan l _ <- [getLoc i] + [ (newRange, minImport) + | imp@(L _ impDecl) <- imports + , not (isQualifiedImport impDecl) + , not (isExplicitImport impDecl) + , let L _ moduleName = ideclName impDecl + , modFilter moduleName + , RealSrcSpan location _ <- [getLoc imp] + , let range = realSrcSpanToRange location + , Just minImport <- [Map.lookup (realSrcSpanStart location) importsMap] + , Just newRange <- [toCurrentRange tmrpm range] ] - return ([], MinimalImportsResult res <$ mbMinImports) - where - isImplicitPrelude :: (Outputable a) => a -> Bool - isImplicitPrelude importDecl = - T.isPrefixOf implicitPreludeImportPrefix (printOutputable importDecl) - --- | This is the prefix of an implicit prelude import which should be ignored, --- when considering the minimal imports rule -implicitPreludeImportPrefix :: T.Text -implicitPreludeImportPrefix = "import (implicit) Prelude" + uniqueAndRangeAndText <- liftIO $ for res $ \rt -> do + u <- U.hashUnique <$> U.newUnique + pure (u, rt) + let rangeAndUnique = [ (r, u) | (u, (r, _)) <- uniqueAndRangeAndText ] + pure MinimalImportsResult + { forLens = rangeAndUnique + , forCodeActions = RM.fromList fst rangeAndUnique + , forResolve = IM.fromList ((\(i, (r, t)) -> (i, TextEdit r t)) <$> uniqueAndRangeAndText) } -------------------------------------------------------------------------------- -- | Use the ghc api to extract a minimal, explicit set of imports for this module extractMinimalImports :: - Maybe HscEnvEq -> - Maybe TcModuleResult -> - IO ([LImportDecl GhcRn], Maybe [LImportDecl GhcRn]) -extractMinimalImports (Just hsc) (Just TcModuleResult {..}) = do + HscEnvEq -> + TcModuleResult -> + IO (Maybe ([LImportDecl GhcRn], [LImportDecl GhcRn])) +extractMinimalImports hsc TcModuleResult {..} = runMaybeT $ do -- extract the original imports and the typechecking environment let tcEnv = tmrTypechecked (_, imports, _, _) = tmrRenamed ParsedModule {pm_parsed_source = L loc _} = tmrParsed emss = exportedModuleStrings tmrParsed - span = fromMaybe (error "expected real") $ realSpan loc + Just srcSpan <- pure $ realSpan loc -- Don't make suggestions for modules which are also exported, the user probably doesn't want this! -- See https://github.com/haskell/haskell-language-server/issues/2079 let notExportedImports = filter (notExported emss) imports -- GHC is secretly full of mutable state - gblElts <- readIORef (tcg_used_gres tcEnv) + gblElts <- liftIO $ readIORef (tcg_used_gres tcEnv) -- call findImportUsage does exactly what we need -- GHC is full of treats like this let usage = findImportUsage notExportedImports gblElts - (_, minimalImports) <- - initTcWithGbl (hscEnv hsc) tcEnv span $ getMinimalImports usage + (_, Just minimalImports) <- liftIO $ + initTcWithGbl (hscEnv hsc) tcEnv srcSpan $ getMinimalImports usage -- return both the original imports and the computed minimal ones return (imports, minimalImports) @@ -265,25 +328,17 @@ extractMinimalImports (Just hsc) (Just TcModuleResult {..}) = do notExported [] _ = True notExported exports (L _ ImportDecl{ideclName = L _ name}) = not $ any (\e -> ("module " ++ moduleNameString name) == e) exports -extractMinimalImports _ _ = return ([], Nothing) +#if !MIN_VERSION_ghc (9,0,0) + notExported _ _ = True +#endif -mkExplicitEdit :: (ModuleName -> Bool) -> PositionMapping -> LImportDecl GhcRn -> T.Text -> Maybe TextEdit -mkExplicitEdit pred posMapping (L (locA -> src) imp) explicit - -- Explicit import list case +isExplicitImport :: ImportDecl GhcRn -> Bool #if MIN_VERSION_ghc (9,5,0) - | ImportDecl {ideclImportList = Just (Exactly, _)} <- imp = +isExplicitImport ImportDecl {ideclImportList = Just (Exactly, _)} = True #else - | ImportDecl {ideclHiding = Just (False, _)} <- imp = +isExplicitImport ImportDecl {ideclHiding = Just (False, _)} = True #endif - Nothing - | not (isQualifiedImport imp), - RealSrcSpan l _ <- src, - L _ mn <- ideclName imp, - pred mn, - Just rng <- toCurrentRange posMapping $ realSrcSpanToRange l = - Just $ TextEdit rng explicit - | otherwise = - Nothing +isExplicitImport _ = False -- This number is somewhat arbitrarily chosen. Ideally the protocol would tell us these things, -- but at the moment I don't believe we know it. @@ -292,23 +347,6 @@ mkExplicitEdit pred posMapping (L (locA -> src) imp) explicit maxColumns :: Int maxColumns = 120 --- | Given an import declaration, generate a code lens unless it has an --- explicit import list or it's qualified -generateLens :: PluginId -> Uri -> TextEdit -> IO (Maybe CodeLens) -generateLens pId uri importEdit@TextEdit {_range, _newText} = do - let - title = abbreviateImportTitle _newText - -- the code lens has no extra data - _data_ = Nothing - -- an edit that replaces the whole declaration with the explicit one - edit = WorkspaceEdit (Just editsMap) Nothing Nothing - editsMap = Map.fromList [(uri, [importEdit])] - -- the command argument is simply the edit - _arguments = Just [toJSON $ ImportCommandParams edit] - -- create the command - _command = Just $ mkLspCommand pId importCommandId title _arguments - -- create and return the code lens - return $ Just CodeLens {..} -- | The title of the command is ideally the minimal explicit import decl, but -- we don't want to create a really massive code lens (and the decl can be extremely large!). @@ -332,6 +370,7 @@ abbreviateImportTitle input = numAdditionalItems = T.count "," actualSuffix + 1 -- We want to make text like this: import Foo (AImport, BImport, ... (30 items)) -- We also want it to look sensible if we end up splitting in the module name itself, + summaryText :: Int -> T.Text summaryText n = " ... (" <> fromString (show n) <> " items)" -- so we only add a trailing paren if we've split in the export list suffixText = summaryText numAdditionalItems <> if T.count "(" prefix > 0 then ")" else "" @@ -344,10 +383,6 @@ abbreviateImportTitle input = -------------------------------------------------------------------------------- --- | A helper to run ide actions -runIde :: IdeState -> Action a -> IO a -runIde = runAction "importLens" - within :: Range -> SrcSpan -> Bool -within (Range start end) span = - isInsideSrcSpan start span || isInsideSrcSpan end span +within (Range start end) srcSpan = + isInsideSrcSpan start srcSpan || isInsideSrcSpan end srcSpan diff --git a/plugins/hls-explicit-imports-plugin/test/Main.hs b/plugins/hls-explicit-imports-plugin/test/Main.hs index 6a5303ecba2..d787630b7fd 100644 --- a/plugins/hls-explicit-imports-plugin/test/Main.hs +++ b/plugins/hls-explicit-imports-plugin/test/Main.hs @@ -1,33 +1,40 @@ {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} - module Main ( main ) where -import Data.Foldable (find, forM_) +import Control.Lens ((^.)) +import Data.Either.Extra +import Data.Foldable (find) +import Data.Row ((.+), (.==)) import Data.Text (Text) import qualified Data.Text as T import qualified Ide.Plugin.ExplicitImports as ExplicitImports +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message -import System.FilePath ((<.>), ()) +import System.FilePath (()) import Test.Hls explicitImportsPlugin :: PluginTestDescriptor ExplicitImports.Log explicitImportsPlugin = mkPluginTestDescriptor ExplicitImports.descriptor "explicitImports" -longModule :: T.Text -longModule = "F" <> T.replicate 80 "o" - main :: IO () main = defaultTestRunner $ testGroup "Make imports explicit" - [ codeActionGoldenTest "UsualCase" 3 0 + [ codeActionAllGoldenTest "UsualCase" 3 0 + , codeActionAllResolveGoldenTest "UsualCase" 3 0 + , codeActionOnlyGoldenTest "OnlyThis" 3 0 + , codeActionOnlyResolveGoldenTest "OnlyThis" 3 0 , codeLensGoldenTest "UsualCase" 0 + , codeActionBreakFile "BreakFile" 4 0 + , codeActionStaleAction "StaleAction" 4 0 , testCase "No CodeAction when exported" $ runSessionWithServer explicitImportsPlugin testDataDir $ do doc <- openDoc "Exported.hs" "haskell" @@ -65,12 +72,74 @@ main = defaultTestRunner $ -- code action tests -codeActionGoldenTest :: FilePath -> Int -> Int -> TestTree -codeActionGoldenTest fp l c = goldenWithExplicitImports fp $ \doc -> do +codeActionAllGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionAllGoldenTest fp l c = goldenWithExplicitImports " code action" fp codeActionNoResolveCaps $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + case find ((== Just "Make all imports explicit") . caTitle) actions of + Just (InR x) -> executeCodeAction x + _ -> liftIO $ assertFailure "Unable to find CodeAction" + +codeActionBreakFile :: FilePath -> Int -> Int -> TestTree +codeActionBreakFile fp l c = goldenWithExplicitImports " code action" fp codeActionNoResolveCaps $ \doc -> do + _ <- waitForDiagnostics + changeDoc doc [edit] actions <- getCodeActions doc (pointRange l c) case find ((== Just "Make all imports explicit") . caTitle) actions of Just (InR x) -> executeCodeAction x _ -> liftIO $ assertFailure "Unable to find CodeAction" + where edit = TextDocumentContentChangeEvent $ InL $ #range .== pointRange 2 21 + .+ #rangeLength .== Nothing + .+ #text .== "x" + +codeActionStaleAction :: FilePath -> Int -> Int -> TestTree +codeActionStaleAction fp l c = goldenWithExplicitImports " code action" fp codeActionResolveCaps $ \doc -> do + _ <- waitForDiagnostics + actions <- getCodeActions doc (pointRange l c) + changeDoc doc [edit] + _ <- waitForDiagnostics + case find ((== Just "Make this import explicit") . caTitle) actions of + Just (InR x) -> + maybeResolveCodeAction x >>= + \case Just _ -> liftIO $ assertFailure "Code action still valid" + Nothing -> pure () + _ -> liftIO $ assertFailure "Unable to find CodeAction" + where edit = TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 6 0) (Position 6 0) + .+ #rangeLength .== Nothing + .+ #text .== "\ntesting = undefined" + +codeActionAllResolveGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionAllResolveGoldenTest fp l c = goldenWithExplicitImports " code action resolve" fp codeActionResolveCaps $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + Just (InR x) <- pure $ find ((== Just "Make all imports explicit") . caTitle) actions + resolved <- resolveCodeAction x + executeCodeAction resolved + +codeActionOnlyGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionOnlyGoldenTest fp l c = goldenWithExplicitImports " code action" fp codeActionNoResolveCaps $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + case find ((== Just "Make this import explicit") . caTitle) actions of + Just (InR x) -> executeCodeAction x + _ -> liftIO $ assertFailure "Unable to find CodeAction" + +codeActionOnlyResolveGoldenTest :: FilePath -> Int -> Int -> TestTree +codeActionOnlyResolveGoldenTest fp l c = goldenWithExplicitImports " code action resolve" fp codeActionResolveCaps $ \doc -> do + actions <- getCodeActions doc (pointRange l c) + Just (InR x) <- pure $ find ((== Just "Make this import explicit") . caTitle) actions + resolved <- resolveCodeAction x + executeCodeAction resolved + +-- TODO: use the one from lsp-test once that's released +resolveCodeAction :: CodeAction -> Session CodeAction +resolveCodeAction ca = do + resolveResponse <- request SMethod_CodeActionResolve ca + Right resolved <- pure $ resolveResponse ^. L.result + pure resolved + +maybeResolveCodeAction :: CodeAction -> Session (Maybe CodeAction) +maybeResolveCodeAction ca = do + resolveResponse <- request SMethod_CodeActionResolve ca + let resolved = resolveResponse ^. L.result + pure $ eitherToMaybe resolved caTitle :: (Command |? CodeAction) -> Maybe Text caTitle (InR CodeAction {_title}) = Just _title @@ -79,18 +148,17 @@ caTitle _ = Nothing -- code lens tests codeLensGoldenTest :: FilePath -> Int -> TestTree -codeLensGoldenTest fp codeLensIdx = goldenWithExplicitImports fp $ \doc -> do - codeLens <- (!! codeLensIdx) <$> getCodeLensesBy isExplicitImports doc - mapM_ executeCmd - [c | CodeLens{_command = Just c} <- [codeLens]] - -getCodeLensesBy :: (CodeLens -> Bool) -> TextDocumentIdentifier -> Session [CodeLens] -getCodeLensesBy f doc = filter f <$> getCodeLenses doc - -isExplicitImports :: CodeLens -> Bool -isExplicitImports (CodeLens _ (Just (Command _ cmd _)) _) - | ":explicitImports:" `T.isInfixOf` cmd = True -isExplicitImports _ = False +codeLensGoldenTest fp _ = goldenWithExplicitImports " code lens" fp codeActionNoResolveCaps $ \doc -> do + (codeLens: _) <- getCodeLenses doc + CodeLens {_command = Just c} <- resolveCodeLens codeLens + executeCmd c + +-- TODO: use the one from lsp-test once that's released +resolveCodeLens :: CodeLens -> Session CodeLens +resolveCodeLens cl = do + resolveResponse <- request SMethod_CodeLensResolve cl + Right resolved <- pure $ resolveResponse ^. L.result + pure resolved -- Execute command and wait for result executeCmd :: Command -> Session () @@ -102,8 +170,8 @@ executeCmd cmd = do -- helpers -goldenWithExplicitImports :: FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree -goldenWithExplicitImports fp = goldenWithHaskellDoc explicitImportsPlugin (fp <> " (golden)") testDataDir fp "expected" "hs" +goldenWithExplicitImports :: String -> FilePath -> ClientCapabilities -> (TextDocumentIdentifier -> Session ()) -> TestTree +goldenWithExplicitImports title fp caps = goldenWithHaskellAndCaps caps explicitImportsPlugin (fp <> title <> " (golden)") testDataDir fp "expected" "hs" testDataDir :: String testDataDir = "test" "testdata" diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/B.hs b/plugins/hls-explicit-imports-plugin/test/testdata/B.hs new file mode 100644 index 00000000000..80159dc10bf --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/B.hs @@ -0,0 +1,7 @@ +module B where + +b1 :: String +b1 = "b1" + +b2 :: String +b2 = "b2" diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.expected.hs new file mode 100644 index 00000000000..6ef3eeec691 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.expected.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall #-} +module BreakFile whexe + +import A ( a1 ) + +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.hs b/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.hs new file mode 100644 index 00000000000..2a570ae2d8a --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/BreakFile.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall #-} +module BreakFile where + +import A + +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.expected.hs new file mode 100644 index 00000000000..5911ee5562e --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.expected.hs @@ -0,0 +1,7 @@ +module OnlyThis where + +import A ( a1 ) +import B + +main :: IO () +main = putStrLn $ "hello " ++ a1 ++ b1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.hs b/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.hs new file mode 100644 index 00000000000..9663d1b1740 --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/OnlyThis.hs @@ -0,0 +1,7 @@ +module OnlyThis where + +import A +import B + +main :: IO () +main = putStrLn $ "hello " ++ a1 ++ b1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.expected.hs new file mode 100644 index 00000000000..a345a5c91ed --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.expected.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -Wall #-} +module StaleAction where + +import A + +main = putStrLn $ "hello " ++ a1 + +testing = undefined \ No newline at end of file diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.hs b/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.hs new file mode 100644 index 00000000000..6d38cc62c4c --- /dev/null +++ b/plugins/hls-explicit-imports-plugin/test/testdata/StaleAction.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall #-} +module StaleAction where + +import A + +main = putStrLn $ "hello " ++ a1 diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.expected.hs b/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.expected.hs index 8355eafde23..ec0b512b3ba 100644 --- a/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.expected.hs +++ b/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.expected.hs @@ -1,4 +1,4 @@ -module Main where +module UsualCase where import A ( a1 ) diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.hs b/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.hs index b5c65ba8eaf..4bf33dc0945 100644 --- a/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.hs +++ b/plugins/hls-explicit-imports-plugin/test/testdata/UsualCase.hs @@ -1,4 +1,4 @@ -module Main where +module UsualCase where import A diff --git a/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml b/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml index c1a3993dc4a..8d08bfb527f 100644 --- a/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml +++ b/plugins/hls-explicit-imports-plugin/test/testdata/hie.yaml @@ -1,6 +1,10 @@ + cradle: direct: arguments: + - OnlyThis.hs + - StaleAction.hs - UsualCase.hs - Exported.hs - A.hs + - B.hs 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 d5d30de1689..faca4a20d57 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 @@ -57,9 +57,9 @@ import Development.IDE.Graph.Classes (Hashable, NFData (rnf)) import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), getFirstPragma, insertNewPragma) -import Development.IDE.Types.Logger (Priority (..), cmapWithPrio, - logWith, (<+>)) import GHC.Generics (Generic) +import Ide.Logger (Priority (..), cmapWithPrio, + logWith, (<+>)) import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap import Ide.PluginUtils (getNormalizedFilePath, diff --git a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs index 2c8f6fb92e7..c8abd55b365 100644 --- a/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs +++ b/plugins/hls-floskell-plugin/src/Ide/Plugin/Floskell.hs @@ -33,7 +33,7 @@ provider _ideState typ contents fp _ = liftIO $ do config <- findConfigOrDefault file let (range, selectedContents) = case typ of FormatText -> (fullRange contents, contents) - FormatRange r -> (normalize r, extractRange r contents) + FormatRange r -> (normalize r, extractTextInRange (extendToFullLines r) contents) result = reformat config (Just file) . TL.encodeUtf8 $ TL.fromStrict selectedContents case result of Left err -> pure $ Left $ responseError $ T.pack $ "floskellCmd: " ++ err diff --git a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs index 93c1805d82a..fcd5d8ebef0 100644 --- a/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs +++ b/plugins/hls-gadt-plugin/src/Ide/Plugin/GADT.hs @@ -12,8 +12,7 @@ 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.Aeson (FromJSON, ToJSON, Value, toJSON) import Data.Either.Extra (maybeToEither) import qualified Data.Map as Map import qualified Data.Text as T @@ -29,7 +28,7 @@ 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.Protocol.Types import Language.LSP.Server (sendRequest) descriptor :: PluginId -> PluginDescriptor IdeState @@ -72,7 +71,7 @@ toGADTCommand pId@(PluginId pId') state ToGADTParams{..} = pluginResponse $ do (ApplyWorkspaceEditParams Nothing (workSpaceEdit nfp (TextEdit range txt : insertEdit))) (\_ -> pure ()) - pure Null + pure $ InR Null where workSpaceEdit nfp edits = WorkspaceEdit (pure $ Map.fromList diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 4faefa7a24d..ee59553ab33 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -1,23 +1,24 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} -- On 9.4 we get a new redundant constraint warning, but deleting the @@ -117,6 +118,7 @@ import qualified Refact.Fixity as Refact import Ide.Plugin.Config hiding (Config) import Ide.Plugin.Properties +import Ide.Plugin.Resolve import Ide.PluginUtils import Ide.Types hiding (Config) @@ -143,8 +145,6 @@ import GHC.Generics (Generic) import System.Environment (setEnv, unsetEnv) #endif -import Data.Aeson (Result (Error, Success), - fromJSON) import Text.Regex.TDFA.Text () -- --------------------------------------------------------------------- @@ -154,7 +154,7 @@ data Log | LogGeneratedIdeas NormalizedFilePath [[Refact.Refactoring Refact.SrcSpan]] | LogGetIdeas NormalizedFilePath | LogUsingExtensions NormalizedFilePath [String] -- Extension is only imported conditionally, so we just stringify them - deriving Show + | forall a. (Pretty a) => LogResolve a instance Pretty Log where pretty = \case @@ -163,6 +163,7 @@ instance Pretty Log where LogGeneratedIdeas fp ideas -> "Generated hlint ideas for for" <+> viaShow fp <> ":" <+> viaShow ideas LogUsingExtensions fp exts -> "Using extensions for " <+> viaShow fp <> ":" <+> pretty exts LogGetIdeas fp -> "Getting hlint ideas for " <+> viaShow fp + LogResolve msg -> pretty msg #ifdef HLINT_ON_GHC_LIB -- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib @@ -188,7 +189,8 @@ fromStrictMaybe Strict.Nothing = Nothing descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = - let (pluginCommands, pluginHandlers) = mkCodeActionWithResolveAndCommand plId codeActionProvider (resolveProvider recorder) + let resolveRecorder = cmapWithPrio LogResolve recorder + (pluginCommands, pluginHandlers) = mkCodeActionWithResolveAndCommand resolveRecorder plId codeActionProvider (resolveProvider recorder) in (defaultPluginDescriptor plId) { pluginRules = rules recorder plId , pluginCommands = pluginCommands @@ -423,7 +425,7 @@ codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context where applyAllAction verTxtDocId = - let args = Just $ toJSON (AA verTxtDocId) + let args = Just $ toJSON (ApplyHint verTxtDocId Nothing) in LSP.CodeAction "Apply all hints" (Just LSP.CodeActionKind_QuickFix) Nothing Nothing Nothing Nothing Nothing args -- |Some hints do not have an associated refactoring @@ -434,24 +436,16 @@ codeActionProvider ideState _pluginId (CodeActionParams _ _ documentId _ context diags = context ^. LSP.diagnostics -resolveProvider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_CodeActionResolve -resolveProvider recorder ideState _pluginId ca@CodeAction {_data_ = Just data_} = pluginResponse $ do - case fromJSON data_ of - (Success (AA verTxtDocId@(VersionedTextDocumentIdentifier uri _))) -> do - file <- getNormalizedFilePath uri - edit <- ExceptT $ liftIO $ applyHint recorder ideState file Nothing verTxtDocId - pure $ ca & LSP.edit ?~ edit - (Success (AO verTxtDocId@(VersionedTextDocumentIdentifier uri _) pos hintTitle)) -> do - let oneHint = OneHint pos hintTitle - file <- getNormalizedFilePath uri - edit <- ExceptT $ liftIO $ applyHint recorder ideState file (Just oneHint) verTxtDocId +resolveProvider :: Recorder (WithPriority Log) -> ResolveFunction IdeState HlintResolveCommands Method_CodeActionResolve +resolveProvider recorder ideState _plId ca uri resolveValue = pluginResponse $ do + file <- getNormalizedFilePath uri + case resolveValue of + (ApplyHint verTxtDocId oneHint) -> do + edit <- ExceptT $ liftIO $ applyHint recorder ideState file oneHint verTxtDocId pure $ ca & LSP.edit ?~ edit - (Success (IH verTxtDocId@(VersionedTextDocumentIdentifier uri _) hintTitle )) -> do - file <- getNormalizedFilePath uri + (IgnoreHint verTxtDocId hintTitle ) -> do edit <- ExceptT $ liftIO $ ignoreHint recorder ideState file verTxtDocId hintTitle pure $ ca & LSP.edit ?~ edit - Error s-> throwE ("JSON decoding error: " <> s) -resolveProvider _ _ _ _ = pluginResponse $ throwE "CodeAction with no data field" -- | Convert a hlint diagnostic into an apply and an ignore code action -- if applicable @@ -461,13 +455,13 @@ diagnosticToCodeActions verTxtDocId diagnostic , let isHintApplicable = "refact:" `T.isPrefixOf` code , let hint = T.replace "refact:" "" code , let suppressHintTitle = "Ignore hint \"" <> hint <> "\" in this module" - , let suppressHintArguments = IH verTxtDocId hint + , let suppressHintArguments = IgnoreHint verTxtDocId hint = catMaybes -- Applying the hint is marked preferred because it addresses the underlying error. -- Disabling the rule isn't, because less often used and configuration can be adapted. [ if | isHintApplicable , let applyHintTitle = "Apply hint \"" <> hint <> "\"" - applyHintArguments = AO verTxtDocId start hint -> + applyHintArguments = ApplyHint verTxtDocId (Just $ OneHint start hint) -> Just (mkCodeAction applyHintTitle diagnostic (Just (toJSON applyHintArguments)) True) | otherwise -> Nothing , Just (mkCodeAction suppressHintTitle diagnostic (Just (toJSON suppressHintArguments)) False) @@ -525,22 +519,25 @@ ignoreHint _recorder ideState nfp verTxtDocId ignoreHintTitle = do Nothing -> pure $ Left "Unable to get fileContents" -- --------------------------------------------------------------------- -data HlintResolveCommands = AA { verTxtDocId :: VersionedTextDocumentIdentifier} - | AO { verTxtDocId :: VersionedTextDocumentIdentifier - , start_pos :: Position - -- | There can be more than one hint suggested at the same position, so HintTitle is used to distinguish between them. - , hintTitle :: HintTitle - } - | IH { verTxtDocId :: VersionedTextDocumentIdentifier - , ignoreHintTitle :: HintTitle - } deriving (Generic, ToJSON, FromJSON) +data HlintResolveCommands = + ApplyHint + { verTxtDocId :: VersionedTextDocumentIdentifier + -- |If Nothing, apply all hints, otherise only apply + -- the given hint + , oneHint :: Maybe OneHint + } + | IgnoreHint + { verTxtDocId :: VersionedTextDocumentIdentifier + , ignoreHintTitle :: HintTitle + } deriving (Generic, ToJSON, FromJSON) type HintTitle = T.Text -data OneHint = OneHint - { oneHintPos :: Position - , oneHintTitle :: HintTitle - } deriving (Eq, Show) +data OneHint = + OneHint + { oneHintPos :: Position + , oneHintTitle :: HintTitle + } deriving (Generic, Eq, Show, ToJSON, FromJSON) applyHint :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> Maybe OneHint -> VersionedTextDocumentIdentifier -> IO (Either String WorkspaceEdit) applyHint recorder ide nfp mhint verTxtDocId = 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 f9336920dad..76a003d1ef2 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -21,7 +21,7 @@ import Control.Monad (forM_, void) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe -import Data.Aeson (Value (Null), toJSON) +import Data.Aeson (Value, toJSON) import Data.Char (isLower) import Data.List (intercalate, isPrefixOf, minimumBy) @@ -51,10 +51,10 @@ import Development.IDE.GHC.Compat (GenLocated (L), locA, moduleNameString, pattern RealSrcSpan, pm_parsed_source, unLoc) -import Development.IDE.Types.Logger (Pretty (..)) +import Ide.Logger (Pretty (..)) import Ide.Types import Language.LSP.Protocol.Message -import Language.LSP.Protocol.Types hiding (Null) +import Language.LSP.Protocol.Types import Language.LSP.Server import Language.LSP.VFS (virtualFileText) import System.Directory (makeAbsolute) @@ -94,7 +94,7 @@ command recorder state uri = do edit = WorkspaceEdit (Just $ Map.singleton aUri [TextEdit aRange aCode]) Nothing Nothing in void $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (const (pure ())) - pure $ Right Null + pure $ Right $ InR Null -- | A source code change data Action = Replace 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 12884290a0e..2ccf3af9869 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 @@ -62,6 +62,7 @@ test-suite tests , ghcide , text , hls-overloaded-record-dot-plugin + , hls-plugin-api , lens , lsp-test , lsp-types 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 7a743bcdd5f..89ca4e73c97 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 @@ -70,20 +70,21 @@ import Development.IDE.Graph.Classes (Hashable, NFData (rnf)) import Development.IDE.Spans.Pragmas (NextPragmaInfo (..), getFirstPragma, insertNewPragma) -import Development.IDE.Types.Logger (Priority (..), +import GHC.Generics (Generic) +import Ide.Logger (Priority (..), cmapWithPrio, logWith, (<+>)) -import GHC.Generics (Generic) import Ide.Plugin.RangeMap (RangeMap) import qualified Ide.Plugin.RangeMap as RangeMap +import Ide.Plugin.Resolve (mkCodeActionHandlerWithResolve) import Ide.PluginUtils (getNormalizedFilePath, handleMaybeM, pluginResponse) import Ide.Types (PluginDescriptor (..), PluginId (..), PluginMethodHandler, + ResolveFunction, defaultPluginDescriptor, - mkCodeActionHandlerWithResolve, mkPluginHandler) import Language.LSP.Protocol.Lens (HasChanges (changes)) import qualified Language.LSP.Protocol.Lens as L @@ -99,16 +100,19 @@ import Language.LSP.Protocol.Types (CodeAction (..), normalizedFilePathToUri, type (|?) (..)) import Language.LSP.Server (getClientCapabilities) + data Log = LogShake Shake.Log | LogCollectedRecordSelectors [RecordSelectorExpr] | LogTextEdits [TextEdit] + | forall a. (Pretty a) => LogResolve a instance Pretty Log where pretty = \case LogShake shakeLog -> pretty shakeLog LogCollectedRecordSelectors recs -> "Collected record selectors:" <+> pretty recs + LogResolve msg -> pretty msg data CollectRecordSelectors = CollectRecordSelectors deriving (Eq, Show, Generic) @@ -167,28 +171,27 @@ instance FromJSON ORDResolveData descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState -descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = - mkCodeActionHandlerWithResolve codeActionProvider resolveProvider +descriptor recorder plId = + let resolveRecorder = cmapWithPrio LogResolve recorder + pluginHandler = mkCodeActionHandlerWithResolve resolveRecorder codeActionProvider resolveProvider + in (defaultPluginDescriptor plId) + { pluginHandlers = pluginHandler , pluginRules = collectRecSelsRule recorder } -resolveProvider :: PluginMethodHandler IdeState 'Method_CodeActionResolve -resolveProvider ideState pId ca@(CodeAction _ _ _ _ _ _ _ (Just resData)) = - pluginResponse $ do - case fromJSON resData of - Success (ORDRD uri int) -> do - nfp <- getNormalizedFilePath uri - CRSR _ crsDetails exts <- collectRecSelResult ideState nfp - pragma <- getFirstPragma pId ideState nfp - case IntMap.lookup int crsDetails of - Just rse -> pure $ ca {_edit = mkWorkspaceEdit uri rse exts pragma} - -- We need to throw a content modified error here, see - -- https://github.com/microsoft/language-server-protocol/issues/1738 - -- but we need fendor's plugin error response pr to make it - -- convenient to use here, so we will wait to do that till that's merged - _ -> throwE "Content Modified Error" - _ -> throwE "Unable to deserialize the data" +resolveProvider :: ResolveFunction IdeState ORDResolveData 'Method_CodeActionResolve +resolveProvider ideState plId ca uri (ORDRD _ int) = + pluginResponse $ do + nfp <- getNormalizedFilePath uri + CRSR _ crsDetails exts <- collectRecSelResult ideState nfp + pragma <- getFirstPragma plId ideState nfp + case IntMap.lookup int crsDetails of + Just rse -> pure $ ca {_edit = mkWorkspaceEdit uri rse exts pragma} + -- We need to throw a content modified error here, see + -- https://github.com/microsoft/language-server-protocol/issues/1738 + -- but we need fendor's plugin error response pr to make it + -- convenient to use here, so we will wait to do that till that's merged + _ -> throwE "Content Modified Error" codeActionProvider :: PluginMethodHandler IdeState 'Method_TextDocumentCodeAction codeActionProvider ideState pId (CodeActionParams _ _ caDocId caRange _) = diff --git a/plugins/hls-overloaded-record-dot-plugin/test/Main.hs b/plugins/hls-overloaded-record-dot-plugin/test/Main.hs index 6015eedcba4..25bfb583b15 100644 --- a/plugins/hls-overloaded-record-dot-plugin/test/Main.hs +++ b/plugins/hls-overloaded-record-dot-plugin/test/Main.hs @@ -13,7 +13,7 @@ import Data.Row import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL -import Development.IDE.Types.Logger (Doc, Logger (Logger), +import Ide.Logger (Doc, Logger (Logger), Pretty (pretty), Priority (Debug), Recorder (Recorder, logger_), diff --git a/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal b/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal index 7cd78a21f8e..42cd50c7adb 100644 --- a/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal +++ b/plugins/hls-refactor-plugin/hls-refactor-plugin.cabal @@ -86,6 +86,9 @@ library , lens , data-default , time + -- FIXME: Only needed to workaround for qualified imports in GHC 9.4 + , regex-applicative + , parser-combinators ghc-options: -Wall -Wno-name-shadowing default-language: Haskell2010 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 661f7dbccee..0521e087514 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs @@ -81,7 +81,7 @@ import Development.IDE.GHC.Compat.ExactPrint import Development.IDE.Graph (RuleResult, Rules) import Development.IDE.Graph.Classes import Development.IDE.Types.Location -import Development.IDE.Types.Logger (Pretty (pretty), +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) 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 97fdd80e70e..eafe606e69a 100644 --- a/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs +++ b/plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs @@ -15,6 +15,7 @@ module Development.IDE.Plugin.CodeAction ) where import Control.Applicative ((<|>)) +import Control.Applicative.Combinators.NonEmpty (sepBy1) import Control.Arrow (second, (&&&), (>>>)) @@ -22,7 +23,6 @@ import Control.Concurrent.STM.Stats (atomically) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Maybe -import Data.Aeson as A import Data.Char import qualified Data.DList as DL import Data.Function @@ -65,15 +65,17 @@ import Development.IDE.Plugin.Plugins.ImportUtils import Development.IDE.Plugin.TypeLenses (suggestSignature) import Development.IDE.Types.Exports import Development.IDE.Types.Location -import Development.IDE.Types.Logger hiding - (group) import Development.IDE.Types.Options import GHC.Exts (fromList) import qualified GHC.LanguageExtensions as Lang +import Ide.Logger hiding + (group) +import qualified Text.Regex.Applicative as RE #if MIN_VERSION_ghc(9,4,0) import GHC.Parser.Annotation (TokenLocation (..)) #endif -import Ide.PluginUtils (subRange) +import Ide.PluginUtils (extractTextInRange, + subRange) import Ide.Types import Language.LSP.Protocol.Message (ResponseError, SMethod (..)) @@ -85,7 +87,7 @@ import Language.LSP.Protocol.Types (ApplyWorkspa Command, Diagnostic (..), MessageType (..), - Null, + Null (Null), ShowMessageParams (..), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit, _range), @@ -212,7 +214,7 @@ extendImportHandler ideState edit@ExtendImport {..} = do <> printOutputable srcSpan <> ")" void $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return $ Right A.Null + return $ Right $ InR Null extendImportHandler' :: IdeState -> ExtendImport -> MaybeT IO (NormalizedFilePath, WorkspaceEdit) extendImportHandler' ideState ExtendImport {..} @@ -1474,7 +1476,7 @@ suggestNewOrExtendImportForClassMethod packageExportsMap ps fileContents Diagnos where moduleText = moduleNameText identInfo suggestNewImport :: DynFlags -> ExportsMap -> Annotated ParsedSource -> T.Text -> Diagnostic -> [(T.Text, CodeActionKind, TextEdit)] -suggestNewImport df packageExportsMap ps fileContents Diagnostic{_message} +suggestNewImport df packageExportsMap ps fileContents Diagnostic{..} | msg <- unifySpaces _message , Just thingMissing <- extractNotInScopeName msg , qual <- extractQualifiedModuleName msg @@ -1483,17 +1485,93 @@ suggestNewImport df packageExportsMap ps fileContents Diagnostic{_message} >>= (findImportDeclByModuleName hsmodImports . T.unpack) >>= ideclAs . unLoc <&> T.pack . moduleNameString . unLoc + , -- tentative workaround for detecting qualification in GHC 9.4 + -- FIXME: We can delete this after dropping the support for GHC 9.4 + qualGHC94 <- + guard (ghcVersion == GHC94) + *> extractQualifiedModuleNameFromMissingName (extractTextInRange _range fileContents) , Just (range, indent) <- newImportInsertRange ps fileContents , extendImportSuggestions <- matchRegexUnifySpaces msg "Perhaps you want to add ‘[^’]*’ to the import list in the import of ‘([^’]*)’" = let qis = qualifiedImportStyle df + -- FIXME: we can use thingMissing once the support for GHC 9.4 is dropped. + -- In what fllows, @missing@ is assumed to be qualified name. + -- @thingMissing@ is already as desired with GHC != 9.4. + -- In GHC 9.4, however, GHC drops a module qualifier from a qualified symbol. + -- Thus we need to explicitly concatenate qualifier explicity in GHC 9.4. + missing + | GHC94 <- ghcVersion + , isNothing (qual <|> qual') + , Just q <- qualGHC94 = + qualify q thingMissing + | otherwise = thingMissing suggestions = nubSortBy simpleCompareImportSuggestion - (constructNewImportSuggestions packageExportsMap (qual <|> qual', thingMissing) extendImportSuggestions qis) in + (constructNewImportSuggestions packageExportsMap (qual <|> qual' <|> qualGHC94, missing) extendImportSuggestions qis) in map (\(ImportSuggestion _ kind (unNewImport -> imp)) -> (imp, kind, TextEdit range (imp <> "\n" <> T.replicate indent " "))) suggestions where + qualify q (NotInScopeDataConstructor d) = NotInScopeDataConstructor (q <> "." <> d) + qualify q (NotInScopeTypeConstructorOrClass d) = NotInScopeTypeConstructorOrClass (q <> "." <> d) + qualify q (NotInScopeThing d) = NotInScopeThing (q <> "." <> d) + L _ HsModule {..} = astA ps suggestNewImport _ _ _ _ _ = [] +{- | +Extracts qualifier of the symbol from the missing symbol. +Input must be either a plain qualified variable or possibly-parenthesized qualified binary operator (though no strict checking is done for symbol part). +This is only needed to alleviate the issue #3473. + +FIXME: We can delete this after dropping the support for GHC 9.4 + +>>> extractQualifiedModuleNameFromMissingName "P.lookup" +Just "P" + +>>> extractQualifiedModuleNameFromMissingName "ΣP3_'.σlookup" +Just "\931P3_'" + +>>> extractQualifiedModuleNameFromMissingName "ModuleA.Gre_ekσ.goodδ" +Just "ModuleA.Gre_ek\963" + +>>> extractQualifiedModuleNameFromMissingName "(ModuleA.Gre_ekσ.+)" +Just "ModuleA.Gre_ek\963" + +>>> extractQualifiedModuleNameFromMissingName "(ModuleA.Gre_ekσ..|.)" +Just "ModuleA.Gre_ek\963" + +>>> extractQualifiedModuleNameFromMissingName "A.B.|." +Just "A.B" +-} +extractQualifiedModuleNameFromMissingName :: T.Text -> Maybe T.Text +extractQualifiedModuleNameFromMissingName (T.strip -> missing) + = T.pack <$> (T.unpack missing RE.=~ qualIdentP) + where + {- + NOTE: Haskell 2010 allows /unicode/ upper & lower letters + as a module name component; otoh, regex-tdfa only allows + /ASCII/ letters to be matched with @[[:upper:]]@ and/or @[[:lower:]]@. + Hence we use regex-applicative(-text) for finer-grained predicates. + + RULES (from [Section 10 of Haskell 2010 Report](https://www.haskell.org/onlinereport/haskell2010/haskellch10.html)): + modid → {conid .} conid + conid → large {small | large | digit | ' } + small → ascSmall | uniSmall | _ + ascSmall → a | b | … | z + uniSmall → any Unicode lowercase letter + large → ascLarge | uniLarge + ascLarge → A | B | … | Z + uniLarge → any uppercase or titlecase Unicode letter + -} + + qualIdentP = parensQualOpP <|> qualVarP + parensQualOpP = RE.sym '(' *> modNameP <* RE.sym '.' <* RE.anySym <* RE.few RE.anySym <* RE.sym ')' + qualVarP = modNameP <* RE.sym '.' <* RE.some RE.anySym + conIDP = RE.withMatched $ + RE.psym isUpper + *> RE.many + (RE.psym $ \c -> c == '\'' || c == '_' || isUpper c || isLower c || isDigit c) + modNameP = fmap snd $ RE.withMatched $ conIDP `sepBy1` RE.sym '.' + + constructNewImportSuggestions :: ExportsMap -> (Maybe T.Text, NotInScope) -> Maybe [T.Text] -> QualifiedImportStyle -> [ImportSuggestion] constructNewImportSuggestions exportsMap (qual, thingMissing) notTheseModules qis = nubOrdBy simpleCompareImportSuggestion diff --git a/plugins/hls-refactor-plugin/test/Main.hs b/plugins/hls-refactor-plugin/test/Main.hs index d304c5c62fe..b7fac7ce763 100644 --- a/plugins/hls-refactor-plugin/test/Main.hs +++ b/plugins/hls-refactor-plugin/test/Main.hs @@ -1670,10 +1670,11 @@ suggestImportTests = testGroup "suggest import actions" , test True [] "f = empty" [] "import Control.Applicative (empty)" , test True [] "f = empty" [] "import Control.Applicative" , test True [] "f = (&)" [] "import Data.Function ((&))" - , ignoreForGHC94 "On GHC 9.4 the error message doesn't contain the qualified module name: https://gitlab.haskell.org/ghc/ghc/-/issues/20472" - $ test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE" - , ignoreForGHC94 "On GHC 9.4 the error message doesn't contain the qualified module name: https://gitlab.haskell.org/ghc/ghc/-/issues/20472" - $ test True [] "f = Data.List.NonEmpty.nonEmpty" [] "import qualified Data.List.NonEmpty" + , test True [] "f = NE.nonEmpty" [] "import qualified Data.List.NonEmpty as NE" + , test True [] "f = (NE.:|)" [] "import qualified Data.List.NonEmpty as NE" + , test True [] "f = (Data.List.NonEmpty.:|)" [] "import qualified Data.List.NonEmpty" + , test True [] "f = (B..|.)" [] "import qualified Data.Bits as B" + , test True [] "f = (Data.Bits..|.)" [] "import qualified Data.Bits" , test True [] "f :: Typeable a => a" ["f = undefined"] "import Data.Typeable (Typeable)" , test True [] "f = pack" [] "import Data.Text (pack)" , test True [] "f :: Text" ["f = undefined"] "import Data.Text (Text)" @@ -1682,17 +1683,14 @@ suggestImportTests = testGroup "suggest import actions" , test True [] "f = (.|.)" [] "import Data.Bits (Bits((.|.)))" , test True [] "f = (.|.)" [] "import Data.Bits ((.|.))" , test True [] "f :: a ~~ b" [] "import Data.Type.Equality ((~~))" - , ignoreForGHC94 "On GHC 9.4 the error message doesn't contain the qualified module name: https://gitlab.haskell.org/ghc/ghc/-/issues/20472" - $ test True + , test True ["qualified Data.Text as T" ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" - , ignoreForGHC94 "On GHC 9.4 the error message doesn't contain the qualified module name: https://gitlab.haskell.org/ghc/ghc/-/issues/20472" - $ test True + , test True [ "qualified Data.Text as T" , "qualified Data.Function as T" ] "f = T.putStrLn" [] "import qualified Data.Text.IO as T" - , ignoreForGHC94 "On GHC 9.4 the error message doesn't contain the qualified module name: https://gitlab.haskell.org/ghc/ghc/-/issues/20472" - $ test True + , test True [ "qualified Data.Text as T" , "qualified Data.Function as T" , "qualified Data.Functor as T" 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 2145fe6a2a9..2011f74b377 100644 --- a/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal +++ b/plugins/hls-refine-imports-plugin/hls-refine-imports-plugin.cabal @@ -35,6 +35,7 @@ library , hls-plugin-api == 2.1.0.0 , lsp , text + , transformers , unordered-containers default-language: Haskell2010 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 42a401e2add..1e8732c0e3e 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -15,7 +15,10 @@ import Control.Arrow (Arrow (second)) import Control.DeepSeq (rwhnf) import Control.Monad (join) import Control.Monad.IO.Class (liftIO) -import Data.Aeson.Types +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT), + runMaybeT) +import Data.Aeson.Types hiding (Null) import Data.IORef (readIORef) import Data.List (intercalate) import qualified Data.Map.Strict as Map @@ -40,7 +43,7 @@ import Development.IDE.GHC.Compat tcg_exports, unLoc) -} import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Graph.Classes -import qualified Development.IDE.Types.Logger as Logger +import qualified Ide.Logger as Logger import GHC.Generics (Generic) import Ide.Plugin.ExplicitImports (extractMinimalImports, within) @@ -57,7 +60,7 @@ import Language.LSP.Protocol.Types (ApplyWorkspaceEd TextEdit (..), WorkspaceEdit (..), type (|?) (InL, InR), - uriToNormalizedFilePath) + uriToNormalizedFilePath, Null (Null)) import Language.LSP.Protocol.Message (Method (Method_TextDocumentCodeAction, Method_TextDocumentCodeLens), SMethod (SMethod_TextDocumentCodeAction, SMethod_TextDocumentCodeLens, SMethod_WorkspaceApplyEdit),) newtype Log = LogShake Shake.Log deriving Show @@ -100,7 +103,7 @@ runRefineImportCommand :: CommandFunction IdeState RefineImportCommandParams runRefineImportCommand _state (RefineImportCommandParams edit) = do -- This command simply triggers a workspace edit! _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - return (Right Null) + return (Right $ InR Null) lensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens lensProvider @@ -184,28 +187,28 @@ instance Show RefineImportsResult where show _ = "" instance NFData RefineImportsResult where rnf = rwhnf refineImportsRule :: Recorder (WithPriority Log) -> Rules () -refineImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \RefineImports nfp -> do +refineImportsRule recorder = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \RefineImports nfp -> runMaybeT $ do -- Get the typechecking artifacts from the module - tmr <- use TypeCheck nfp + tmr <- MaybeT $ use TypeCheck nfp -- We also need a GHC session with all the dependencies - hsc <- use GhcSessionDeps nfp + hsc <- MaybeT $ use GhcSessionDeps nfp -- 2 layer map ModuleName -> ModuleName -> [Avails] (exports) import2Map <- do -- first layer is from current(editing) module to its imports - ImportMap currIm <- use_ GetImportMap nfp + ImportMap currIm <- lift $ use_ GetImportMap nfp forM currIm $ \path -> do -- second layer is from the imports of first layer to their imports - ImportMap importIm <- use_ GetImportMap path + ImportMap importIm <- lift $ use_ GetImportMap path forM importIm $ \imp_path -> do - imp_hir <- use_ GetModIface imp_path + imp_hir <- lift $ use_ GetModIface imp_path return $ mi_exports $ hirModIface imp_hir -- Use the GHC api to extract the "minimal" imports -- We shouldn't blindly refine imports -- instead we should generate imports statements -- for modules/symbols actually got used - (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr + (imports, mbMinImports) <- MaybeT $ liftIO $ extractMinimalImports hsc tmr let filterByImport :: LImportDecl GhcRn @@ -259,7 +262,7 @@ refineImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \RefineIm . Map.toList $ filteredInnerImports) -- for every minimal imports - | Just minImports <- [mbMinImports] + | minImports <- [mbMinImports] , i@(L _ ImportDecl{ideclName = L _ mn}) <- minImports -- we check for the inner imports , Just innerImports <- [Map.lookup mn import2Map] @@ -268,7 +271,7 @@ refineImportsRule recorder = define (cmapWithPrio LogShake recorder) $ \RefineIm -- if no symbols from this modules then don't need to generate new import , not $ null filteredInnerImports ] - return ([], RefineImportsResult res <$ mbMinImports) + pure $ RefineImportsResult res where -- Check if a name is exposed by AvailInfo (the available information of a module) diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 990e2617623..f517e75315d 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -33,8 +33,7 @@ import Control.Monad.Trans.Except (ExceptT (ExceptT), import Control.Monad.Trans.Maybe import Control.Monad.Trans.Writer.Strict import Data.Aeson (FromJSON (..), - ToJSON (..), - Value (Null)) + ToJSON (..), Value) import Data.Bifunctor (second) import qualified Data.ByteString as BS import Data.Coerce @@ -118,7 +117,7 @@ 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.Protocol.Types as LSP import Language.LSP.Server (LspM, ProgressCancellable (Cancellable), sendNotification, @@ -209,7 +208,7 @@ data RunRetrieParams = RunRetrieParams runRetrieCmd :: IdeState -> RunRetrieParams -> - LspM c (Either ResponseError Value) + LspM c (Either ResponseError (Value |? Null)) runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = withIndefiniteProgress description Cancellable $ do runMaybeT $ do @@ -236,7 +235,7 @@ runRetrieCmd state RunRetrieParams{originatingFile = uri, ..} = ["-" <> T.pack (show e) | e <- errors] lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edits) (\_ -> pure ()) return () - return $ Right Null + return $ Right $ InR Null data RunRetrieInlineThisParams = RunRetrieInlineThisParams { inlineIntoThisLocation :: !Location, @@ -246,7 +245,7 @@ data RunRetrieInlineThisParams = RunRetrieInlineThisParams deriving (Eq, Show, Generic, FromJSON, ToJSON) runRetrieInlineThisCmd :: IdeState - -> RunRetrieInlineThisParams -> LspM c (Either ResponseError Value) + -> RunRetrieInlineThisParams -> LspM c (Either ResponseError (Value |? Null)) runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = pluginResponse $ do nfp <- handleMaybe "uri" $ uriToNormalizedFilePath $ toNormalizedUri $ getLocationUri inlineIntoThisLocation nfpSource <- handleMaybe "sourceUri" $ @@ -287,7 +286,7 @@ runRetrieInlineThisCmd state RunRetrieInlineThisParams{..} = pluginResponse $ do , RealSrcSpan intoRange Nothing `GHC.isSubspanOf` replLocation] lift $ sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) - return Null + return $ InR Null -- Override to skip adding binders to the context, which prevents inlining -- nested defined functions diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 0cf5da4541b..d4af48ddbcd 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -37,7 +37,7 @@ import Control.Monad.IO.Unlift import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe -import Data.Aeson +import Data.Aeson hiding (Null) import Data.Foldable (Foldable (foldl')) import Data.Function import Data.Generics @@ -64,7 +64,7 @@ import Ide.Plugin.Splice.Types import Ide.Types import Language.Haskell.GHC.ExactPrint (uniqueSrcSpanT) import Language.LSP.Server -import Language.LSP.Protocol.Types hiding (Null) +import Language.LSP.Protocol.Types import Language.LSP.Protocol.Message import qualified Language.LSP.Protocol.Lens as J @@ -192,11 +192,11 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do Right edits -> pure (Right edits) case res of - Nothing -> pure $ Right Null + Nothing -> pure $ Right $ InR Null Just (Left err) -> pure $ Left err Just (Right edit) -> do _ <- sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ()) - pure $ Right Null + pure $ Right $ InR Null where range = realSrcSpanToRange spliceSpan 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 c68e6234012..6865bf9ee77 100644 --- a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs +++ b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs @@ -36,7 +36,7 @@ provider ide typ contents fp _opts = do mergedConfig <- liftIO $ getMergedConfig dyn config let (range, selectedContents) = case typ of FormatText -> (fullRange contents, contents) - FormatRange r -> (normalize r, extractRange r contents) + FormatRange r -> (normalize r, extractTextInRange (extendToFullLines r) contents) result = runStylishHaskell file mergedConfig selectedContents case result of Left err -> return $ Left $ responseError $ T.pack $ "stylishHaskellCmd: " ++ err diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs index c382082ed0a..044061d5799 100644 --- a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs @@ -64,7 +64,7 @@ import Wingman.Judgements.Theta import Wingman.Range import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax) import Wingman.Types -import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) +import Ide.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) import qualified Development.IDE.Core.Shake as Shake diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs index bbde652ae92..f8b62cde721 100644 --- a/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs @@ -15,7 +15,7 @@ import Wingman.LanguageServer hiding (Log) import qualified Wingman.LanguageServer as WingmanLanguageServer import Wingman.LanguageServer.Metaprogram (hoverProvider) import Wingman.StaticPlugin -import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) +import Ide.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) data Log = LogWingmanLanguageServer WingmanLanguageServer.Log diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs index c9c8e50fe3e..e31a2f6cd8e 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/AbstractLSP.hs @@ -103,7 +103,7 @@ runContinuation plId cont state (fc, b) = do res <- c_runCommand cont env args fc b -- This block returns a maybe error. - fmap (maybe (Right A.Null) Left . coerce . foldMap Last) $ + fmap (maybe (Right $ InR Null) Left . coerce . foldMap Last) $ for res $ \case ErrorMessages errs -> do traverse_ showUserFacingMessage errs diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs index 478bf8ecf6e..fde8705d556 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/LanguageServer.hs @@ -60,7 +60,7 @@ import Wingman.Judgements.Theta import Wingman.Range import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax) import Wingman.Types -import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) +import Ide.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) import qualified Development.IDE.Core.Shake as Shake diff --git a/plugins/hls-tactics-plugin/old/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/old/src/Wingman/Plugin.hs index 5b6cc891504..c8e6c2ae4f2 100644 --- a/plugins/hls-tactics-plugin/old/src/Wingman/Plugin.hs +++ b/plugins/hls-tactics-plugin/old/src/Wingman/Plugin.hs @@ -15,7 +15,7 @@ import Wingman.LanguageServer hiding (Log) import qualified Wingman.LanguageServer as WingmanLanguageServer import Wingman.LanguageServer.Metaprogram (hoverProvider) import Wingman.StaticPlugin -import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) +import Ide.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) data Log = LogWingmanLanguageServer WingmanLanguageServer.Log diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 00bb29a6303..22008d2a4af 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} module HlsPlugins where -import Development.IDE.Types.Logger (Pretty (pretty), Recorder, +import Ide.Logger (Pretty (pretty), Recorder, WithPriority, cmapWithPrio) import Ide.PluginUtils (pluginDescToIdePlugins) import Ide.Types (IdePlugins, diff --git a/src/Ide/Arguments.hs b/src/Ide/Arguments.hs index d8be0d69f78..6af7551adf5 100644 --- a/src/Ide/Arguments.hs +++ b/src/Ide/Arguments.hs @@ -20,8 +20,8 @@ module Ide.Arguments import Data.Version import Development.IDE (IdeState) import Development.IDE.Main (Command (..), commandP) -import Development.IDE.Types.Logger (Priority (..)) import GitHash (giHash, tGitInfoCwdTry) +import Ide.Logger (Priority (..)) import Ide.Types (IdePlugins) import Options.Applicative import Paths_haskell_language_server diff --git a/src/Ide/Main.hs b/src/Ide/Main.hs index ecfd944b718..b6ee489d7ce 100644 --- a/src/Ide/Main.hs +++ b/src/Ide/Main.hs @@ -24,13 +24,13 @@ import Development.IDE.Core.Tracing (withTelemetryLogger) import Development.IDE.Main (isLSP) import qualified Development.IDE.Main as IDEMain import qualified Development.IDE.Session as Session -import Development.IDE.Types.Logger as G import qualified Development.IDE.Types.Options as Ghcide import GHC.Stack (emptyCallStack) import qualified HIE.Bios.Environment as HieBios -import qualified HIE.Bios.Types as HieBios import HIE.Bios.Types hiding (Log) +import qualified HIE.Bios.Types as HieBios import Ide.Arguments +import Ide.Logger as G import Ide.Plugin.ConfigUtils (pluginsToDefaultConfig, pluginsToVSCodeExtensionSchema) import Ide.Types (IdePlugins, PluginId (PluginId), diff --git a/stack-lts19.yaml b/stack-lts21.yaml similarity index 59% rename from stack-lts19.yaml rename to stack-lts21.yaml index 0ece22d38af..b90fa0d4e50 100644 --- a/stack-lts19.yaml +++ b/stack-lts21.yaml @@ -1,4 +1,4 @@ -resolver: lts-19.19 +resolver: lts-21.2 # ghc-9.4 packages: - . @@ -9,61 +9,51 @@ packages: - ./hls-plugin-api - ./hls-test-utils # - ./shake-bench - - ./plugins/hls-cabal-plugin + - ./plugins/hls-alternate-number-format-plugin - ./plugins/hls-cabal-fmt-plugin + - ./plugins/hls-cabal-plugin - ./plugins/hls-call-hierarchy-plugin + - ./plugins/hls-change-type-signature-plugin - ./plugins/hls-class-plugin - - ./plugins/hls-haddock-comments-plugin + - ./plugins/hls-code-range-plugin - ./plugins/hls-eval-plugin + - ./plugins/hls-explicit-fixity-plugin - ./plugins/hls-explicit-imports-plugin - - ./plugins/hls-refine-imports-plugin - - ./plugins/hls-hlint-plugin - - ./plugins/hls-rename-plugin - - ./plugins/hls-retrie-plugin - - ./plugins/hls-splice-plugin - - ./plugins/hls-tactics-plugin - - ./plugins/hls-qualify-imported-names-plugin - - ./plugins/hls-stylish-haskell-plugin + - ./plugins/hls-explicit-record-fields-plugin - ./plugins/hls-floskell-plugin - ./plugins/hls-fourmolu-plugin - - ./plugins/hls-pragmas-plugin + - ./plugins/hls-gadt-plugin + # - ./plugins/hls-haddock-comments-plugin + - ./plugins/hls-hlint-plugin - ./plugins/hls-module-name-plugin - ./plugins/hls-ormolu-plugin - - ./plugins/hls-alternate-number-format-plugin - - ./plugins/hls-code-range-plugin - - ./plugins/hls-change-type-signature-plugin - - ./plugins/hls-gadt-plugin - - ./plugins/hls-explicit-fixity-plugin + - ./plugins/hls-overloaded-record-dot-plugin + - ./plugins/hls-pragmas-plugin + - ./plugins/hls-qualify-imported-names-plugin - ./plugins/hls-refactor-plugin - - ./plugins/hls-explicit-record-fields-plugin + - ./plugins/hls-refine-imports-plugin + - ./plugins/hls-rename-plugin + - ./plugins/hls-retrie-plugin + - ./plugins/hls-splice-plugin + # - ./plugins/hls-stan-plugin + - ./plugins/hls-stylish-haskell-plugin + # - ./plugins/hls-tactics-plugin ghc-options: "$everything": -haddock +# stylish-haskell>strict +allow-newer: true + extra-deps: -- Cabal-3.6.0.0 -# needed for tests of hls-cabal-fmt-plugin -- cabal-fmt-0.1.6@sha256:54041d50c8148c32d1e0a67aef7edeebac50ae33571bef22312f6815908eac19,3626 -- floskell-0.10.6@sha256:e77d194189e8540abe2ace2c7cb8efafc747ca35881a2fefcbd2d40a1292e036,3819 -- fourmolu-0.6.0.0 -- ghc-lib-9.2.4.20220729 -- ghc-lib-parser-9.2.4.20220729 -- ghc-lib-parser-ex-9.2.0.4 +- floskell-0.10.7 - hiedb-0.4.3.0 -- hlint-3.4 -- implicit-hie-0.1.2.7@sha256:82bbbb1a8c05f99c8af3c16ac53e80c8648d8bf047b25ed5ce45a135bd736907,3122 -- implicit-hie-cradle-0.5.0.0@sha256:4276f60f3a59bc22df03fd918f73bca9f777de9568f85e3a8be8bd7566234a59,2368 +- implicit-hie-0.1.2.7 +- implicit-hie-cradle-0.5.0.1 - monad-dijkstra-0.1.1.3 -- ormolu-0.5.0.0 -- refinery-0.4.0.0@sha256:fe3a43add8ff1db5cfffee7e7694c86128b1dfe62c541f26e25a8eadf9585610,1663 -- retrie-1.1.0.0 -- 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.1 -- lsp-test-0.15.0.0 -- hie-bios-0.12.0 -- row-types-1.0.1.2 +- algebraic-graphs-0.6.1 +- retrie-1.2.2 +- stylish-haskell-0.14.4.0 configure-options: ghcide: @@ -79,7 +69,7 @@ flags: # Stack doesn't support automatic flags. hyphenation: embed: true - hlint: + stylish-haskell: ghc-lib: true nix: diff --git a/stack.yaml b/stack.yaml index c28042b4c00..473661211e4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,93 +1,74 @@ -resolver: nightly-2022-08-15 +resolver: nightly-2023-07-10 # ghc-9.6.2 packages: -- . -- ./hie-compat -- ./hls-graph -- ./ghcide/ -- ./ghcide/test -- ./hls-plugin-api -- ./hls-test-utils -- ./shake-bench -- ./plugins/hls-cabal-plugin -- ./plugins/hls-cabal-fmt-plugin -- ./plugins/hls-call-hierarchy-plugin -- ./plugins/hls-class-plugin -# - ./plugins/hls-haddock-comments-plugin -- ./plugins/hls-eval-plugin -- ./plugins/hls-explicit-imports-plugin -- ./plugins/hls-qualify-imported-names-plugin -- ./plugins/hls-refine-imports-plugin -- ./plugins/hls-hlint-plugin -- ./plugins/hls-rename-plugin -# - ./plugins/hls-retrie-plugin -# - ./plugins/hls-splice-plugin -# - ./plugins/hls-tactics-plugin -- ./plugins/hls-stylish-haskell-plugin -- ./plugins/hls-floskell-plugin -- ./plugins/hls-fourmolu-plugin -- ./plugins/hls-pragmas-plugin -- ./plugins/hls-module-name-plugin -- ./plugins/hls-ormolu-plugin -- ./plugins/hls-alternate-number-format-plugin -- ./plugins/hls-code-range-plugin -- ./plugins/hls-change-type-signature-plugin -- ./plugins/hls-gadt-plugin -- ./plugins/hls-explicit-fixity-plugin -- ./plugins/hls-refactor-plugin -- ./plugins/hls-explicit-record-fields-plugin -- ./plugins/hls-overloaded-record-dot-plugin + - . + - ./hie-compat + - ./hls-graph + - ./ghcide/ + - ./ghcide/test + - ./hls-plugin-api + - ./hls-test-utils + # - ./shake-bench + - ./plugins/hls-alternate-number-format-plugin + - ./plugins/hls-cabal-fmt-plugin + - ./plugins/hls-cabal-plugin + - ./plugins/hls-call-hierarchy-plugin + - ./plugins/hls-change-type-signature-plugin + - ./plugins/hls-class-plugin + - ./plugins/hls-code-range-plugin + - ./plugins/hls-eval-plugin + - ./plugins/hls-explicit-fixity-plugin + - ./plugins/hls-explicit-imports-plugin + - ./plugins/hls-explicit-record-fields-plugin + # - ./plugins/hls-floskell-plugin + - ./plugins/hls-fourmolu-plugin + - ./plugins/hls-gadt-plugin + # - ./plugins/hls-haddock-comments-plugin + - ./plugins/hls-hlint-plugin + - ./plugins/hls-module-name-plugin + - ./plugins/hls-ormolu-plugin + - ./plugins/hls-overloaded-record-dot-plugin + - ./plugins/hls-pragmas-plugin + - ./plugins/hls-qualify-imported-names-plugin + - ./plugins/hls-refactor-plugin + - ./plugins/hls-refine-imports-plugin + - ./plugins/hls-rename-plugin + - ./plugins/hls-retrie-plugin + - ./plugins/hls-splice-plugin + # - ./plugins/hls-stan-plugin + - ./plugins/hls-stylish-haskell-plugin + # - ./plugins/hls-tactics-plugin -extra-deps: -# needed for tests of hls-cabal-fmt-plugin -- cabal-fmt-0.1.6@sha256:54041d50c8148c32d1e0a67aef7edeebac50ae33571bef22312f6815908eac19,3626 -- floskell-0.10.6@sha256:e77d194189e8540abe2ace2c7cb8efafc747ca35881a2fefcbd2d40a1292e036,3819 -- hiedb-0.4.3.0 -- implicit-hie-0.1.2.7@sha256:82bbbb1a8c05f99c8af3c16ac53e80c8648d8bf047b25ed5ce45a135bd736907,3122 -- implicit-hie-cradle-0.5.0.0@sha256:4276f60f3a59bc22df03fd918f73bca9f777de9568f85e3a8be8bd7566234a59,2368 -- monad-dijkstra-0.1.1.3@sha256:d2fc098d7c122555e726830a12ae0423ac187f89de9228f32e56e2f6fc2238e1,1900 -- retrie-1.2.0.1 -- co-log-core-0.3.1.0 -- lsp-2.0.0.0 -- lsp-types-2.0.0.1 -- lsp-test-0.15.0.0 -- hie-bios-0.12.0 -- row-types-1.0.1.2 +ghc-options: + "$everything": -haddock -# currently needed for ghcide>extra, etc. +# Remove this after https://github.com/haskell-works/hw-prim/pull/146 merged allow-newer: true -ghc-options: - "$everything": -haddock +extra-deps: +# - floskell-0.10.7 +- hiedb-0.4.3.0 +- implicit-hie-0.1.2.7 +- implicit-hie-cradle-0.5.0.1 +- fourmolu-0.12.0.0 +- algebraic-graphs-0.6.1 +- retrie-1.2.2 +- hw-fingertree-0.1.2.1 +- hw-prim-0.6.3.2 +- ansi-terminal-0.11.5 configure-options: ghcide: - - --disable-library-for-ghci + - --disable-library-for-ghci haskell-language-server: - - --disable-library-for-ghci - heapsize: - - --disable-library-for-ghci + - --disable-library-for-ghci flags: haskell-language-server: pedantic: true - - ignore-plugins-ghc-bounds: true - haddockComments: false - retrie: false - splice: false - tactic: false - retrie: BuildExecutable: false # Stack doesn't support automatic flags. - # Use ghc-lib force instead of ghc itself - ghc-lib-parser-ex: - auto: false - hlint: - ghc-lib: true - stylish-haskell: - ghc-lib: true hyphenation: embed: true @@ -95,5 +76,3 @@ nix: packages: [ icu libcxx zlib ] concurrent-tests: false - -system-ghc: true diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index 08280d4c4f8..0511e75fcce 100644 --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -7,6 +7,7 @@ import Control.Lens hiding ((.=)) import Control.Monad import Data.Aeson (object, (.=)) import Data.Foldable (find) +import Data.Maybe (isJust) import Data.Row.Records (focus) import qualified Data.Text as T import Ide.Plugin.Config (maxCompletions) @@ -18,10 +19,13 @@ getResolvedCompletions :: TextDocumentIdentifier -> Position -> Session [Complet getResolvedCompletions doc pos = do xs <- getCompletions doc pos forM xs $ \item -> do - rsp <- request SMethod_CompletionItemResolve item - case rsp ^. result of - Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) - Right x -> pure x + if isJust (item ^. data_) + then do + 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 tests :: TestTree tests = testGroup "completions" [ diff --git a/test/functional/Definition.hs b/test/functional/Definition.hs index 24ce49297d0..3c32f2cf720 100644 --- a/test/functional/Definition.hs +++ b/test/functional/Definition.hs @@ -7,18 +7,43 @@ import Test.Hls import Test.Hls.Command tests :: TestTree -tests = testGroup "definitions" [ +tests = testGroup "definitions" [symbolTests, moduleTests] - ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/References.hs" $ - testCase "goto's symbols" $ runSession hlsCommand fullCaps "test/testdata" $ do +symbolTests :: TestTree +symbolTests = testGroup "gotoDefinition on symbols" + -- gotoDefinition where the definition is in the same file + [ testCase "gotoDefinition in this file" $ runSession hlsCommand fullCaps "test/testdata" $ do doc <- openDoc "References.hs" "haskell" defs <- getDefinitions doc (Position 7 8) let expRange = Range (Position 4 0) (Position 4 3) liftIO $ defs @?= InL (Definition (InR [Location (doc ^. uri) expRange])) + -- gotoDefinition where the definition is in a different file + , testCase "gotoDefinition in other file" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do + doc <- openDoc "Foo.hs" "haskell" + defs <- getDefinitions doc (Position 4 11) + let expRange = Range (Position 2 0) (Position 2 1) + liftIO $ do + fp <- canonicalizePath "test/testdata/definition/Bar.hs" + defs @?= InL (Definition (InR [Location (filePathToUri fp) expRange])) + + -- gotoDefinition where the definition is in a different file and the + -- definition in the other file is on a line number that is greater + -- than the number of lines in the file we are requesting from + , testCase "gotoDefinition in other file past lines in this file" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do + doc <- openDoc "Foo.hs" "haskell" + defs <- getDefinitions doc (Position 5 13) + let expRange = Range (Position 8 0) (Position 8 1) + liftIO $ do + fp <- canonicalizePath "test/testdata/definition/Bar.hs" + defs @?= InL (Definition (InR [Location (filePathToUri fp) expRange])) + ] + -- ----------------------------------- - , ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ +moduleTests :: TestTree +moduleTests = testGroup "gotoDefinition on modules" + [ ignoreTestBecause "Broken: file:///Users/jwindsor/src/haskell-language-server/test/testdata/Bar.hs" $ testCase "goto's imported modules" $ runSession hlsCommand fullCaps "test/testdata/definition" $ do doc <- openDoc "Foo.hs" "haskell" defs <- getDefinitions doc (Position 2 8) diff --git a/test/testdata/definition/Bar.hs b/test/testdata/definition/Bar.hs index 02a244cd4dc..9ae116114e8 100644 --- a/test/testdata/definition/Bar.hs +++ b/test/testdata/definition/Bar.hs @@ -1,3 +1,9 @@ module Bar where a = 42 + +-- These blank lines are here +-- to ensure that b is defined +-- on a line number larger than +-- the number of lines in Foo.hs. +b = 43 diff --git a/test/testdata/definition/Foo.hs b/test/testdata/definition/Foo.hs index 6dfb3ba2e6d..ca73e2d3757 100644 --- a/test/testdata/definition/Foo.hs +++ b/test/testdata/definition/Foo.hs @@ -1,3 +1,6 @@ module Foo (module Bar) where import Bar + +fortyTwo = a +fortyThree = b diff --git a/test/testdata/definition/hie.yaml b/test/testdata/definition/hie.yaml new file mode 100644 index 00000000000..9adb47d0f3e --- /dev/null +++ b/test/testdata/definition/hie.yaml @@ -0,0 +1,5 @@ +cradle: + direct: + arguments: + - "Foo" + - "Bar"