From 0b3bb10cd22cb265b7cbab84514178bcf4ae4f92 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Mon, 7 Jun 2021 01:16:29 +0800 Subject: [PATCH] Ghc 9.0.1 support for ghcide (#1649) * hie-compat: Add basic support for ghc-9.0.1 A tiny step towards #297 * hie-compat: Remove dependency on ghc-api-compat * hie-compat: Add more backwards compatability * Import a bunch of upstream ghc9 fixes * cabal.project: allow-newer: *:* The lazy solution to making things compile * Add more upstream fixes * Bump patch of ghc-check * ghcide: Add basic support for GHC-9.0.1 I tried to limit the use of CPP to the Compat module as much as possible by re-exporting the new functions under the old names, but there is still plenty of pragmas all over the code. I'm using ghc-api-compat so the imports doesn't need to be changed as much. * ghcide: Fix backwards compatability with ghc-8.8.4 * ghc9-ghcide: Fix some more issues that caused runtime errors * Restore initDynLinker for older versions of ghc It was probably important for something * Fix ghc-8.6.5 compatability * Fix completion test failures for ghc9 With this example: f asdfgh = asd it would suggest to complete `asd` into `asd_arNC`, which seems to be a name it generated because of deferred-out-of-scope-variables * Ghc-check now supports ghc-9.0.1 * Retrie now supports ghc-9.0.1 But it's not on hackage yet. * Restore retrie orphans * tests: Ghc9 shows [Char] as String by default This seems like an improvement, so just update the test-suite * tests: Ghc9 shows TH-errors after the dollar sign Instead of including it like older versions did $(foo) ~~~~ some TH error/warning * Fix two more test failures - GHC9 uses a more lenient haddock parser - TH2.17 has polymorphic Q monad with a type class * ghc9: Fix "Remove redundant imports" code action In ghc9, only the specific unused function is highlighted, instead of the whole line. * ghcide-tests: Show errors where they are caused instead of deep inside some generic helper function * Only use nub on SrcSpan for ghc>=9 * Remove more CPP pragmas * Remove a bit more CPP This could almost be handled by ghc-api-compat, but if it was imported from TyCoPpr, it doesn't work with ghc < 8.10 * Update stack files to support new versions * Use the version of retire on hackage The new version is now released * Don't use allow-newer: *:* * ghcide-tests: Enable test no longer broken in ghc9 * Update hiedb version for ghcide * Adjust for a minor change in test output for ghc9 * Fix benchmark test for ghc9 Cabal-3.2 is not buildable on ghc9, but 3.4 is builable on older ghc. * Mark minor issues as broken for ghc9 Ghc9 highlights both the constructor and the other fields Maybe this should just be accepted and not seen as broken? * haddock-comments-plugin: Ghc9 support * hls-eval-plugin: Partial ghc9 support * WIP: hls-eval-plugin: Partial ghc9 support * hls-explicit-imports-plugin: Add ghc9 support Now ignores any imports with Unhelpful locations, since we can't make a map of SrcLoc * hls-retrie-plugin: Add ghc9 support * hls-hlint-plugin: Add ghc9 support * Fix backwards compatability of hlint plugin * Fix stack builds (Broken by previous hlint fixes) * Disable tests when their required plugins are disabled Not all plugins are supported on ghc9 yet, but we still want to run the tests for the supported parts * ghc9: Fix module name plugin * Add a stack file and run tests for ghc9 in ci * Add missing packages to ghc-9 stack * Resolve rebase issues Maybe it's better to create merge commits instead? * Allow newer for more packages so cabal stops complaining These aren't really working, but since they are dependencies of packages in the `packages:` section the resolver won't allow us to build anything without this, even if those plugins are disabled. * Replace MIN_GHC_API_VERSION with MIN_VERSION_ghc * Revert incorrect change to hlint code * Remove remaining traces of GHC_LIB flag * Add back ghc 9 to github workflow * Revert "Add back ghc 9 to github workflow" This reverts commit c465a1e51aaaabf56dc7ef8f7fa801ef0abf8fdc. * hie-compat: Add basic support for ghc-9.0.1 A tiny step towards #297 * hie-compat: Remove dependency on ghc-api-compat * hie-compat: Add more backwards compatability * Disable CI for ghc9 * Use newer version of apply-refact * Don't needlessly duplicate code from ghc * hie-compat: Reexport the original version of HieBin * Don't include broken "allow-newer"s * FIx stack build for ghc9 * Fix warning from imperfect merge commit * Don't needlessly duplicate code from ghc * hie-compat: Reexport the original version of HieBin * Add missing ghc-api-compat * Fix ghc9 build for ModuleName * Add more conditionals on flags for tests * Add a separate cabal.project file for ghc9 As far as I know, this is the only way to disable the packages who's dependencies doesn't compile in GHC9 yet. * Fix and re-enable CI for GHC9 * Remove accidental non-breaking space * Fix CI build for ghc9 Since we are changing the flags for haskell-language-server, which CI renames to hls, we need to use the shortened name in those flags as well * Run tests for ghc9 in CI * Minor CI changes * Use proper values when enriching hie * Don't try to test hls-refine-imports-plugin on ghc9 * Update comment about ghc9 crashing on initDynLinker * setSessionDynamicFlags to prevent ghc9 from crashing The only way to set the dynamic linker is with the function `setSessionDynFlags` so we call it with the result from `getSessionDynFlags` to give it a (hopefully sensible) argument. See also this commit: https://gitlab.haskell.org/ghc/ghc/commit/18757cab04c5c5c48eaceea19469d4811c5d0371 * Revert "setSessionDynamicFlags to prevent ghc9 from crashing" This reverts commit 4065ac8394065f8aa15b1b36e0d56e3ba7762e44. That change made the "ghcide.cradle.muli" tests fail. * Simplify logic in hls-hlint-plugin.cabal * Add comment on OldRealSrcSpan * Remove source overrides for non-ghc9 builds in cabal.project * Remove commented out code Co-authored-by: Pepe Iborra * Remove resolved question from comment "This code is only concerned with extracting argument names, so I don't see how multiplicity would be relevant here" https://github.com/haskell/haskell-language-server/pull/1649#discussion_r642606967 * ghc9: Update to latest version of LSP per * cabal-ghc901.project: Remove commented out code * Update the lsp commit hash for stack as well * Use a version of lsp without haskell/lsp#326 That patch was causing test failures, but the issues should be fixed for real at some point, so that patch can be incluede Co-authored-by: Pepe Iborra Co-authored-by: Pepe Iborra --- .circleci/config.yml | 6 + .github/workflows/test.yml | 30 +- cabal-ghc901.project | 153 +++++++++ cabal.project | 55 ++- ghcide/bench/lib/Experiments.hs | 2 +- ghcide/ghcide.cabal | 7 +- .../session-loader/Development/IDE/Session.hs | 19 +- ghcide/src/Development/IDE/Core/Compile.hs | 51 ++- .../src/Development/IDE/Core/Preprocessor.hs | 6 +- ghcide/src/Development/IDE/Core/Shake.hs | 2 + ghcide/src/Development/IDE/GHC/CPP.hs | 7 +- ghcide/src/Development/IDE/GHC/Compat.hs | 325 ++++++++++++++++-- ghcide/src/Development/IDE/GHC/Error.hs | 21 +- ghcide/src/Development/IDE/GHC/Orphans.hs | 24 +- ghcide/src/Development/IDE/GHC/Util.hs | 24 +- ghcide/src/Development/IDE/GHC/Warnings.hs | 10 +- .../src/Development/IDE/Import/FindImports.hs | 8 +- ghcide/src/Development/IDE/LSP/Outline.hs | 48 ++- .../src/Development/IDE/Plugin/CodeAction.hs | 33 +- .../src/Development/IDE/Plugin/Completions.hs | 4 + .../IDE/Plugin/Completions/Logic.hs | 12 +- .../src/Development/IDE/Plugin/TypeLenses.hs | 1 - ghcide/src/Development/IDE/Spans/AtPoint.hs | 23 +- ghcide/src/Development/IDE/Spans/Common.hs | 6 +- .../Development/IDE/Spans/Documentation.hs | 22 +- .../Development/IDE/Spans/LocalBindings.hs | 4 +- ghcide/src/Development/IDE/Types/HscEnvEq.hs | 15 +- ghcide/src/Development/IDE/Types/Options.hs | 4 +- ghcide/test/exe/Main.hs | 82 ++++- ghcide/test/src/Development/IDE/Test.hs | 14 +- haskell-language-server.cabal | 35 ++ hls-plugin-api/hls-plugin-api.cabal | 1 + .../hls-class-plugin/hls-class-plugin.cabal | 1 + plugins/hls-eval-plugin/hls-eval-plugin.cabal | 1 + .../src/Ide/Plugin/Eval/CodeLens.hs | 61 +++- .../src/Ide/Plugin/Eval/GHC.hs | 5 +- .../src/Ide/Plugin/Eval/Parse/Comments.hs | 2 +- .../src/Ide/Plugin/Eval/Util.hs | 3 +- .../hls-explicit-imports-plugin.cabal | 1 + .../src/Ide/Plugin/ExplicitImports.hs | 14 +- .../src/Ide/Plugin/HaddockComments.hs | 16 +- .../hls-hlint-plugin/hls-hlint-plugin.cabal | 41 ++- .../hls-hlint-plugin/src/Ide/Plugin/Hlint.hs | 25 +- .../src/Ide/Plugin/ModuleName.hs | 17 +- .../hls-retrie-plugin/hls-retrie-plugin.cabal | 1 + .../src/Ide/Plugin/Retrie.hs | 15 +- stack-8.10.2.yaml | 7 + stack-8.10.3.yaml | 7 + stack-8.10.4.yaml | 14 + stack-8.6.4.yaml | 7 +- stack-8.6.5.yaml | 9 +- stack-8.8.2.yaml | 8 +- stack-8.8.3.yaml | 7 + stack-8.8.4.yaml | 7 + stack-9.0.1.yaml | 131 +++++++ stack.yaml | 6 + test/functional/Command.hs | 3 +- test/functional/Format.hs | 12 +- test/functional/Progress.hs | 7 +- test/utils/Test/Hls/Flags.hs | 131 +++++++ 60 files changed, 1353 insertions(+), 260 deletions(-) create mode 100644 cabal-ghc901.project create mode 100644 stack-9.0.1.yaml create mode 100644 test/utils/Test/Hls/Flags.hs diff --git a/.circleci/config.yml b/.circleci/config.yml index b9702220fa..7257876959 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -103,6 +103,11 @@ jobs: - STACK_FILE: "stack-8.10.4.yaml" <<: *defaults + ghc-9.0.1: + environment: + - STACK_FILE: "stack-9.0.1.yaml" + <<: *defaults + ghc-default: environment: - STACK_FILE: "stack.yaml" @@ -121,4 +126,5 @@ workflows: - ghc-8.10.2 - ghc-8.10.3 - ghc-8.10.4 + - ghc-9.0.1 - ghc-default diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index f4cbca11c6..34f7d4860b 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -33,10 +33,13 @@ jobs: strategy: fail-fast: true matrix: - ghc: ["8.10.4", "8.10.3", "8.10.2", "8.8.4", "8.8.3", "8.8.2", "8.6.5", "8.6.4"] + ghc: ["9.0.1", "8.10.4", "8.10.3", "8.10.2", "8.8.4", "8.8.3", "8.8.2", "8.6.5", "8.6.4"] os: [ubuntu-latest, macOS-latest] include: # only test supported ghc major versions + - os: ubuntu-latest + ghc: '9.0.1' + test: true - os: ubuntu-latest ghc: '8.10.4' test: true @@ -70,7 +73,7 @@ jobs: uses: haskell/actions/setup@v1 with: ghc-version: ${{ matrix.ghc }} - cabal-version: "3.2" + cabal-version: "3.4" - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} run: ./fmt.sh @@ -88,6 +91,11 @@ jobs: echo "CABAL_STORE_DIR=~/.cabal/store" >> $GITHUB_ENV echo "CABAL_PKGS_DIR=~/.cabal/packages" >> $GITHUB_ENV + # Needs to be before Cache Cabal so the cache can detect changes to the modified cabal.project file + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.ghc == '9.0.1' }} + name: Use modified cabal.project for ghc9 + run: cp cabal-ghc901.project cabal.project + - if: ${{ needs.pre_job.outputs.should_skip != 'true' }} name: Cache Cabal uses: actions/cache@v2 @@ -112,7 +120,7 @@ jobs: run: | sed -i.bak -e 's/haskell-language-server/hls/g' \ -e 's/haskell_language_server/hls/g' \ - haskell-language-server.cabal + haskell-language-server.cabal cabal.project sed -i.bak -e 's/Paths_haskell_language_server/Paths_hls/g' \ src/**/*.hs exe/*.hs @@ -146,15 +154,15 @@ jobs: # instances to be spun up for the poor github actions runner to handle run: cabal test wrapper-test --test-options="-j1" || cabal test wrapper-test --test-options="-j1" || cabal test wrapper-test --test-options="-j1" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} name: Test hls-brittany-plugin run: cabal test hls-brittany-plugin --test-options="-j1 --rerun-update" || cabal test hls-brittany-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-brittany-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} name: Test hls-class-plugin run: cabal test hls-class-plugin --test-options="-j1 --rerun-update" || cabal test hls-class-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-class-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} name: Test hls-eval-plugin run: cabal test hls-eval-plugin --test-options="-j1 --rerun-update" || cabal test hls-eval-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-eval-plugin --test-options="-j1 --rerun" @@ -162,22 +170,22 @@ jobs: name: Test hls-haddock-comments-plugin run: cabal test hls-haddock-comments-plugin --test-options="-j1 --rerun-update" || cabal test hls-haddock-comments-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-haddock-comments-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} name: Test hls-splice-plugin run: cabal test hls-splice-plugin --test-options="-j1 --rerun-update" || cabal test hls-splice-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-splice-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} name: Test hls-stylish-haskell-plugin run: cabal test hls-stylish-haskell-plugin --test-options="-j1 --rerun-update" || cabal test hls-stylish-haskell-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-stylish-haskell-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} name: Test hls-fourmolu-plugin run: cabal test hls-fourmolu-plugin --test-options="-j1 --rerun-update" || cabal test hls-fourmolu-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-fourmolu-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} name: Test hls-tactics-plugin test suite run: cabal test hls-tactics-plugin --test-options="-j1 --rerun-update" || cabal test hls-tactics-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-tactics-plugin --test-options="-j1 --rerun" - - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }} name: Test hls-refine-imports-plugin test suite run: cabal test hls-refine-imports-plugin --test-options="-j1 --rerun-update" || cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-refine-imports-plugin --test-options="-j1 --rerun" diff --git a/cabal-ghc901.project b/cabal-ghc901.project new file mode 100644 index 0000000000..017783b414 --- /dev/null +++ b/cabal-ghc901.project @@ -0,0 +1,153 @@ +packages: + ./ + ./hie-compat + ./shake-bench + ./hls-graph + ./ghcide + ./hls-plugin-api + ./hls-test-utils + -- ./plugins/hls-tactics-plugin + -- ./plugins/hls-brittany-plugin + -- ./plugins/hls-stylish-haskell-plugin + -- ./plugins/hls-fourmolu-plugin + ./plugins/hls-class-plugin + ./plugins/hls-eval-plugin + ./plugins/hls-explicit-imports-plugin + ./plugins/hls-refine-imports-plugin + ./plugins/hls-hlint-plugin + ./plugins/hls-retrie-plugin + ./plugins/hls-haddock-comments-plugin + -- ./plugins/hls-splice-plugin + ./plugins/hls-floskell-plugin + ./plugins/hls-pragmas-plugin + ./plugins/hls-module-name-plugin + -- ./plugins/hls-ormolu-plugin +tests: true + +package * + ghc-options: -haddock + test-show-details: direct + +source-repository-package + type: git + location: https://github.com/jwaldmann/blaze-textual.git + tag: d8ee6cf80e27f9619d621c936bb4bda4b99a183f + -- https://github.com/jwaldmann/blaze-textual/commit/d8ee6cf80e27f9619d621c936bb4bda4b99a183f + -- https://github.com/bos/blaze-textual/issues/13 + +source-repository-package + type: git + location: https://github.com/mithrandi/czipwith.git + tag: b6245884ae83e00dd2b5261762549b37390179f8 + -- https://github.com/lspitzner/czipwith/pull/2 + + +source-repository-package + type: git + location: https://github.com/jneira/hie-bios/ + tag: 9b1445ab5efcabfad54043fc9b8e50e9d8c5bbf3 + -- https://github.com/mpickering/hie-bios/pull/285 + +source-repository-package + type: git + location: https://github.com/hsyl20/ghc-api-compat + tag: 6178d75772c7d923918dfffa0b1f503dfb36d0a6 + +source-repository-package + type: git + location: https://github.com/anka-213/th-extras + tag: 57a97b4df128eb7b360e8ab9c5759392de8d1659 +-- https://github.com/mokus0/th-extras/pull/8 +-- https://github.com/mokus0/th-extras/issues/7 + +source-repository-package + type: git + location: https://github.com/anka-213/dependent-sum + tag: 8cf4c7fbc3bfa2be475a17bb7c94a1e1e9a830b5 + subdir: dependent-sum-template +-- https://github.com/obsidiansystems/dependent-sum/pull/57 + +source-repository-package + type: git + location: https://github.com/anka-213/HieDb + tag: a3f7521f6c5af1b977040cce09c8f7354f8984eb +-- https://github.com/wz1000/HieDb/pull/31 + +source-repository-package + type: git + location: https://github.com/anka-213/lsp + tag: tag-ghc-9.0.1-without-pr-326 + subdir: lsp-types + subdir: lsp + subdir: lsp-test +-- https://github.com/haskell/lsp/pull/312 + +source-repository-package + type: git + location: https://github.com/diagrams/active + tag: ca23431a8dfa013992f9164ccc882a3277361f17 +-- https://github.com/diagrams/active/pull/36 + +write-ghc-environment-files: never + +index-state: 2021-05-21T05:01:41Z + +constraints: + -- Diagrams doesn't support optparse-applicative >= 0.16 yet + optparse-applicative < 0.16 + -- These plugins doesn't work on GHC9 yet + , haskell-language-server -brittany -class -eval -fourmolu -modulename -ormolu -splice -stylishhaskell -tactic -refineImports + + +allow-newer: + -- -- Broken on ghc9, but let's pretend it's not so we can build the other things + -- brittany:base, + -- brittany:ghc, + -- brittany:ghc-boot-th, + -- butcher:base, + -- fourmolu:ghc-lib-parser, + -- ormolu:ghc-lib-parser, + -- stylish-haskell:ghc-lib-parser, + -- stylish-haskell:Cabal, + -- multistate:base, + -- ghc-source-gen:ghc, + + active:base, + assoc:base, + cryptohash-md5:base, + cryptohash-sha1:base, + constraints-extras:template-haskell, + data-tree-print:base, + deepseq:base, + dependent-sum:some, + dependent-sum:constraints, + diagrams-contrib:base, + diagrams-contrib:lens, + diagrams-contrib:random, + diagrams-core:base, + diagrams-core:lens, + diagrams-lib:base, + diagrams-lib:lens, + diagrams-postscript:base, + diagrams-postscript:lens, + diagrams-svg:base, + diagrams-svg:lens, + dual-tree:base, + -- Does this make any sense? + entropy:Cabal, + force-layout:base, + force-layout:lens, + floskell:ghc-prim, + floskell:base, + hashable:base, + hslogger:base, + monoid-extras:base, + newtype-generics:base, + parallel:base, + regex-base:base, + regex-tdfa:base, + statestack:base, + svg-builder:base, + these:base, + time-compat:base + diff --git a/cabal.project b/cabal.project index c182e65bf1..26b29981e7 100644 --- a/cabal.project +++ b/cabal.project @@ -32,16 +32,47 @@ write-ghc-environment-files: never index-state: 2021-05-21T05:01:41Z +constraints: + -- Diagrams doesn't support optparse-applicative >= 0.16 yet + optparse-applicative < 0.16 + allow-newer: - active:base, - data-tree-print:base, - diagrams-contrib:base, - diagrams-core:base, - diagrams-lib:base, - diagrams-postscript:base, - diagrams-svg:base, - dual-tree:base, - force-layout:base, - monoid-extras:base, - statestack:base, - svg-builder:base + active:base, + assoc:base, + cryptohash-md5:base, + cryptohash-sha1:base, + constraints-extras:template-haskell, + data-tree-print:base, + deepseq:base, + dependent-sum:some, + dependent-sum:constraints, + diagrams-contrib:base, + diagrams-contrib:lens, + diagrams-contrib:random, + diagrams-core:base, + diagrams-core:lens, + diagrams-lib:base, + diagrams-lib:lens, + diagrams-postscript:base, + diagrams-postscript:lens, + diagrams-svg:base, + diagrams-svg:lens, + dual-tree:base, + -- Does this make any sense? + entropy:Cabal, + force-layout:base, + force-layout:lens, + floskell:ghc-prim, + floskell:base, + hashable:base, + hslogger:base, + monoid-extras:base, + newtype-generics:base, + parallel:base, + regex-base:base, + regex-tdfa:base, + statestack:base, + svg-builder:base, + these:base, + time-compat:base + diff --git a/ghcide/bench/lib/Experiments.hs b/ghcide/bench/lib/Experiments.hs index 919804d1b6..955df3e5d5 100644 --- a/ghcide/bench/lib/Experiments.hs +++ b/ghcide/bench/lib/Experiments.hs @@ -204,7 +204,7 @@ configP = <*> option auto (long "timeout" <> value 60 <> help "timeout for waiting for a ghcide response") <*> ( GetPackage <$> strOption (long "example-package-name" <> value "Cabal") <*> (some moduleOption <|> pure ["Distribution/Simple.hs"]) - <*> option versionP (long "example-package-version" <> value (makeVersion [3,2,0,0])) + <*> option versionP (long "example-package-version" <> value (makeVersion [3,4,0,0])) <|> UsePackage <$> strOption (long "example-path") <*> some moduleOption diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 93388e3ee0..dc41bb9999 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -13,7 +13,7 @@ description: A library for building Haskell IDE's on top of the GHC API. homepage: https://github.com/haskell/haskell-language-server/tree/master/ghcide#readme bug-reports: https://github.com/haskell/haskell-language-server/issues -tested-with: GHC == 8.6.4 || == 8.6.5 || == 8.8.2 || == 8.8.3 || == 8.8.4 || == 8.10.2 || == 8.10.3 || == 8.10.4 +tested-with: GHC == 8.6.4 || == 8.6.5 || == 8.8.2 || == 8.8.3 || == 8.8.4 || == 8.10.2 || == 8.10.3 || == 8.10.4 || == 9.0.1 extra-source-files: README.md CHANGELOG.md test/data/**/*.project test/data/**/*.cabal @@ -59,7 +59,7 @@ library hie-compat ^>= 0.1.0.0, hls-plugin-api ^>= 1.1.0.0, lens, - hiedb == 0.3.0.1, + hiedb == 0.3.0.*, lsp-types == 1.2.*, lsp == 1.2.*, mtl, @@ -95,8 +95,9 @@ library ghc-boot-th, ghc-boot, ghc >= 8.6, - ghc-check >=0.5.0.1, + ghc-check >=0.5.0.4, ghc-paths, + ghc-api-compat, cryptohash-sha1 >=0.11.100 && <0.12, hie-bios >= 0.7.1 && < 0.8.0, implicit-hie-cradle >= 0.3.0.2 && < 0.4, diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 44bfbb3b2d..e9320f6032 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -78,7 +78,6 @@ import HscTypes (hsc_IC, hsc_NC, import Linker import Module import NameCache -import Packages import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TQueue @@ -108,7 +107,7 @@ data SessionLoadingOptions = SessionLoadingOptions , getCacheDirs :: String -> [String] -> IO CacheDirs -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' , getInitialGhcLibDir :: IO (Maybe LibDir) - , fakeUid :: InstalledUnitId + , fakeUid :: GHC.InstalledUnitId -- ^ unit id used to tag the internal component built by ghcide -- To reuse external interface files the unit ids must match, -- thus make sure to build them with `--this-unit-id` set to the @@ -121,7 +120,7 @@ instance Default SessionLoadingOptions where ,loadCradle = loadWithImplicitCradle ,getCacheDirs = getCacheDirsDefault ,getInitialGhcLibDir = getInitialGhcLibDirDefault - ,fakeUid = toInstalledUnitId (stringToUnitId "main") + ,fakeUid = GHC.toInstalledUnitId (GHC.stringToUnit "main") } -- | Find the cradle for a given 'hie.yaml' configuration. @@ -528,7 +527,11 @@ cradleToOptsAndLibDir cradle file = do emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do env <- runGhc (Just libDir) getSession +#if !MIN_VERSION_ghc(9,0,0) + -- This causes ghc9 to crash with the error: + -- Couldn't find a target code interpreter. Try with -fexternal-interpreter initDynLinker env +#endif pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } } data TargetDetails = TargetDetails @@ -754,12 +757,12 @@ removeInplacePackages -> [InstalledUnitId] -> DynFlags -> (DynFlags, [InstalledUnitId]) -removeInplacePackages fake_uid us df = (df { packageFlags = ps - , thisInstalledUnitId = fake_uid }, uids) +removeInplacePackages fake_uid us df = (setThisInstalledUnitId fake_uid $ + df { packageFlags = ps }, uids) where (uids, ps) = partitionEithers (map go (packageFlags df)) - go p@(ExposePackage _ (UnitIdArg u) _) = if toInstalledUnitId u `elem` us - then Left (toInstalledUnitId u) + go p@(ExposePackage _ (UnitIdArg u) _) = if GHC.toInstalledUnitId u `elem` us + then Left (GHC.toInstalledUnitId u) else Right p go p = Right p @@ -800,7 +803,7 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do -- initPackages parses the -package flags and -- sets up the visibility for each component. -- Throws if a -package flag cannot be satisfied. - (final_df, _) <- liftIO $ wrapPackageSetupException $ initPackages dflags'' + final_df <- liftIO $ wrapPackageSetupException $ initUnits dflags'' return (final_df, targets) -- we don't want to generate object code so we compile to bytecode diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 3d7e0433a7..4d64e978dd 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -80,7 +80,15 @@ import MkIface import StringBuffer as SB import TcIface (typecheckIface) import TcRnMonad hiding (newUnique) +#if MIN_VERSION_ghc(9,0,1) +import GHC.Builtin.Names +import GHC.Iface.Recomp +import GHC.Tc.Gen.Splice +import GHC.Tc.Types.Evidence (EvBind) +#else +import PrelNames import TcSplice +#endif import TidyPgm import Bag @@ -103,7 +111,6 @@ import qualified GHC.LanguageExtensions as LangExt import HeaderInfo import Linker (unload) import Maybes (orElse) -import PrelNames import System.Directory import System.FilePath import System.IO.Extra (fixIO, newTempFileWithin) @@ -143,10 +150,10 @@ computePackageDeps -> IO (Either [FileDiagnostic] [InstalledUnitId]) computePackageDeps env pkg = do let dflags = hsc_dflags env - case lookupInstalledPackage dflags pkg of + case oldLookupInstalledPackage dflags pkg of Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $ T.pack $ "unknown package: " ++ show pkg] - Just pkgInfo -> return $ Right $ depends pkgInfo + Just pkgInfo -> return $ Right $ unitDepends pkgInfo typecheckModule :: IdeDefer -> HscEnv @@ -267,7 +274,10 @@ mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do (guts, details) <- tidyProgram session simplified_guts (diags, linkable) <- genLinkable session ms guts pure (linkable, details, diags) -#if MIN_VERSION_ghc(8,10,0) +#if MIN_VERSION_ghc(9,0,1) + let !partial_iface = force (mkPartialIface session details simplified_guts) + final_iface <- mkFullIface session partial_iface Nothing +#elif MIN_VERSION_ghc(8,10,0) let !partial_iface = force (mkPartialIface session details simplified_guts) final_iface <- mkFullIface session partial_iface #else @@ -335,7 +345,11 @@ generateObjectCode session summary guts = do target = defaultObjectTarget $ targetPlatform $ hsc_dflags session #endif session' = session { hsc_dflags = updOptLevel 0 $ (ms_hspp_opts summary') { outputFile = Just dot_o , hscTarget = target}} +#if MIN_VERSION_ghc(9,0,1) + (outputFilename, _mStub, _foreign_files, _cinfos) <- hscGenHardCode session' guts +#else (outputFilename, _mStub, _foreign_files) <- hscGenHardCode session' guts +#endif #if MIN_VERSION_ghc(8,10,0) (ms_location summary') #else @@ -463,7 +477,15 @@ generateHieAsts hscEnv tcm = -- don't export an interface which allows for additional information to be added to hie files. let fake_splice_binds = listToBag (map (mkVarBind unitDataConId) (spliceExpresions $ tmrTopLevelSplices tcm)) real_binds = tcg_binds $ tmrTypechecked tcm +#if MIN_VERSION_ghc(9,0,1) + ts = tmrTypechecked tcm :: TcGblEnv + top_ev_binds = tcg_ev_binds ts :: Bag EvBind + insts = tcg_insts ts :: [ClsInst] + tcs = tcg_tcs ts :: [TyCon] + Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs +#else Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) +#endif where dflags = hsc_dflags hscEnv @@ -650,7 +672,7 @@ setupFinderCache mss session = do -- Make modules available for others that import them, -- by putting them in the finder cache. - let ims = map (InstalledModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss + let ims = map (installedModule (thisInstalledUnitId $ hsc_dflags session) . moduleName . ms_mod) mss ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) mss ims -- set the target and module graph in the session graph = mkModuleGraph mss @@ -708,7 +730,7 @@ getModSummaryFromImports env fp modTime contents = do mod = fmap unLoc mb_mod `orElse` mAIN_NAME - (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps + (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps -- GHC.Prim doesn't exist physically, so don't go looking for it. ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc @@ -777,7 +799,11 @@ parseHeader => DynFlags -- ^ flags to use -> FilePath -- ^ the filename (for source locations) -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported) +#if MIN_VERSION_ghc(9,0,1) + -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule)) +#else -> ExceptT [FileDiagnostic] m ([FileDiagnostic], Located(HsModule GhcPs)) +#endif parseHeader dflags filename contents = do let loc = mkRealSrcLoc (mkFastString filename) 1 1 case unP Parser.parseHeader (mkPState dflags contents loc) of @@ -826,10 +852,21 @@ parseFileContents env customPreprocessor filename ms = do throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr #endif POk pst rdr_module -> - let hpm_annotations = + let hpm_annotations :: ApiAnns + hpm_annotations = +#if MIN_VERSION_ghc(9,0,1) + -- Copied from GHC.Driver.Main + ApiAnns { + apiAnnItems = Map.fromListWith (++) $ annotations pst, + apiAnnEofPos = eof_pos pst, + apiAnnComments = Map.fromList (annotations_comments pst), + apiAnnRogueComments = comment_q pst + } +#else (Map.fromListWith (++) $ annotations pst, Map.fromList ((noSrcSpan,comment_q pst) :annotations_comments pst)) +#endif (warns, errs) = getMessages pst dflags in do diff --git a/ghcide/src/Development/IDE/Core/Preprocessor.hs b/ghcide/src/Development/IDE/Core/Preprocessor.hs index a09a379ba3..544a88e7d7 100644 --- a/ghcide/src/Development/IDE/Core/Preprocessor.hs +++ b/ghcide/src/Development/IDE/Core/Preprocessor.hs @@ -58,7 +58,7 @@ preprocessor env filename mbContents = do else do cppLogs <- liftIO $ newIORef [] contents <- ExceptT - $ (Right <$> (runCpp dflags {log_action = logAction cppLogs} filename + $ (Right <$> (runCpp dflags {log_action = logActionCompat $ logAction cppLogs} filename $ if isOnDisk then Nothing else Just contents)) `catch` ( \(e :: GhcException) -> do @@ -78,7 +78,7 @@ preprocessor env filename mbContents = do (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents return (contents, opts, dflags) where - logAction :: IORef [CPPLog] -> LogAction + logAction :: IORef [CPPLog] -> LogActionCompat logAction cppLogs dflags _reason severity srcSpan _style msg = do let log = CPPLog severity srcSpan $ T.pack $ showSDoc dflags msg modifyIORef cppLogs (log :) @@ -107,7 +107,7 @@ diagsFromCPPLogs filename logs = -- informational log messages and attaches them to the initial log message. go :: [CPPDiag] -> [CPPLog] -> [CPPDiag] go acc [] = reverse $ map (\d -> d {cdMessage = reverse $ cdMessage d}) acc - go acc (CPPLog sev (RealSrcSpan span) msg : logs) = + go acc (CPPLog sev (OldRealSrcSpan span) msg : logs) = let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg] in go (diag : acc) logs go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) = diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 92c231fb5e..66ce807f72 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -664,6 +664,8 @@ newSession extras@ShakeExtras{..} shakeDb acts = do logPriority logger (actionPriority d) msg notifyTestingLogMessage extras msg + -- The inferred type signature doesn't work in ghc >= 9.0.1 + workRun :: (forall b. IO b -> IO b) -> IO (IO ()) workRun restore = withSpan "Shake session" $ \otSpan -> do whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toList kk) let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts) diff --git a/ghcide/src/Development/IDE/GHC/CPP.hs b/ghcide/src/Development/IDE/GHC/CPP.hs index e12c4c6481..287ce61ac4 100644 --- a/ghcide/src/Development/IDE/GHC/CPP.hs +++ b/ghcide/src/Development/IDE/GHC/CPP.hs @@ -24,9 +24,8 @@ module Development.IDE.GHC.CPP(doCpp, addOptP) where -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat as Compat import FileCleanup -import Module import Packages import Panic import SysTools @@ -187,7 +186,7 @@ addOptP opt = onSettings (onOptP (opt:)) -- --------------------------------------------------------------------------- -- Macros (cribbed from Cabal) -generatePackageVersionMacros :: [PackageConfig] -> String +generatePackageVersionMacros :: [Compat.PackageConfig] -> String generatePackageVersionMacros pkgs = concat -- Do not add any C-style comments. See #3389. [ generateMacros "" pkgname version @@ -220,7 +219,7 @@ getGhcVersionPathName dflags = do candidates <- case ghcVersionFile dflags of Just path -> return [path] Nothing -> (map ( "ghcversion.h")) <$> - (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId]) + (getPackageIncludePath dflags [Compat.toInstalledUnitId Compat.rtsUnit]) found <- filterM doesFileExist candidates case found of diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index c814ef0613..31071421e3 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS -Wno-dodgy-imports -Wno-incomplete-uni-patterns #-} +{-# OPTIONS -Wno-missing-signatures #-} -- TODO: Remove! -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat( @@ -16,7 +17,6 @@ module Development.IDE.GHC.Compat( mkHieFile, mkHieFile', enrichHie, - RefMap, writeHieFile, readHieFile, supportsHieFiles, @@ -25,6 +25,7 @@ module Development.IDE.GHC.Compat( #if !MIN_VERSION_ghc(8,8,0) ml_hie_file, addBootSuffixLocnOut, + getRealSrcSpan, #endif hPutStringBuffer, addIncludePathsQuote, @@ -52,6 +53,74 @@ module Development.IDE.GHC.Compat( linkableTime, #endif +#if MIN_VERSION_ghc(9,0,1) + -- Reexports from GHC + UnitId, + moduleUnitId, + pkgState, + thisInstalledUnitId, + -- Reexports from DynFlags + thisPackage, + writeIfaceFile, + + gcatch, +#else + RefMap, + Unit, +#endif + -- Linear + Scaled, + scaledThing, + + lookupUnit', + preloadClosureUs, + -- Reexports from Package + InstalledUnitId, + PackageConfig, + getPackageConfigMap, + getPackageIncludePath, + installedModule, + + pattern DefiniteUnitId, + packageName, + packageNameString, + packageVersion, + toInstalledUnitId, + lookupPackage, + -- lookupPackage', + explicitPackages, + exposedModules, + packageConfigId, + setThisInstalledUnitId, + initUnits, + lookupInstalledPackage, + oldLookupInstalledPackage, + unitDepends, + + haddockInterfaces, + + oldUnhelpfulSpan , + pattern IsBoot, + pattern NotBoot, + pattern OldRealSrcSpan, + + oldRenderWithStyle, + oldMkUserStyle, + oldMkErrStyle, + oldFormatErrDoc, + oldListVisibleModuleNames, + oldLookupModuleWithSuggestions, + + nodeInfo', + getNodeIds, + stringToUnit, + rtsUnit, + + LogActionCompat, + logActionCompat, + + pprSigmaType, + module GHC, module DynFlags, initializePlugins, @@ -65,21 +134,37 @@ module Development.IDE.GHC.Compat( import LinkerTypes #endif -import Compat.HieAst (enrichHie, mkHieFile) +import DynFlags hiding (ExposePackage) +import qualified DynFlags +import qualified ErrUtils as Err +import Fingerprint (Fingerprint) +import qualified Module +import qualified Outputable as Out +import StringBuffer +#if MIN_VERSION_ghc(9,0,1) +import Control.Exception.Safe as Safe (Exception, MonadCatch, catch) +import qualified Data.Set as S +import GHC.Core.TyCo.Ppr (pprSigmaType) +import GHC.Core.TyCo.Rep (Scaled, scaledThing) +import GHC.Iface.Load +import GHC.Types.Unique.Set (emptyUniqSet) +import qualified SrcLoc +#else +import Module (InstalledUnitId, + UnitId (DefiniteUnitId), + toInstalledUnitId) +import TcType (pprSigmaType) +#endif +import Compat.HieAst (enrichHie, mkHieFile) import Compat.HieBin import Compat.HieTypes import Compat.HieUtils -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import Data.IORef -import DynFlags hiding (ExposePackage) -import qualified DynFlags -import Fingerprint (Fingerprint) import HscTypes import MkIface -import qualified Module import NameCache import Packages -import StringBuffer import TcRnTypes #if MIN_VERSION_ghc(8,10,0) @@ -89,22 +174,24 @@ import HsExtension #endif import Avail -import GHC hiding (HasSrcSpan, ModLocation, getLoc, - lookupName) +import GHC hiding (HasSrcSpan, ModLocation, getLoc, + lookupName) import qualified GHC import qualified TyCoRep #if MIN_VERSION_ghc(8,8,0) -import Data.List (foldl') +import Data.List (foldl') #else -import Data.List (foldl', isSuffixOf) +import Data.List (foldl', isSuffixOf) #endif -import Data.Map.Strict (Map) +import qualified Data.Map as M import DynamicLoading -import Plugins (Plugin (parsedResultAction), withPlugins) +import Plugins (Plugin (parsedResultAction), + withPlugins) #if !MIN_VERSION_ghc(8,8,0) -import System.FilePath ((-<.>)) +import SrcLoc (RealLocated) +import System.FilePath ((-<.>)) #endif #if !MIN_VERSION_ghc(8,8,0) @@ -148,7 +235,9 @@ upNameCache = updNameCache #endif -type RefMap a = Map Identifier [(Span, IdentifierDetails a)] +#if !MIN_VERSION_ghc(9,0,1) +type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)] +#endif mkHieFile' :: ModSummary -> [AvailInfo] @@ -173,10 +262,11 @@ addIncludePathsQuote path x = x{includePaths = f $ includePaths x} where f i = i{includePathsQuote = path : includePathsQuote i} pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation -pattern ModLocation a b c <- #if MIN_VERSION_ghc(8,8,0) +pattern ModLocation a b c <- GHC.ModLocation a b c _ where ModLocation a b c = GHC.ModLocation a b c "" #else +pattern ModLocation a b c <- GHC.ModLocation a b c where ModLocation a b c = GHC.ModLocation a b c #endif @@ -221,8 +311,20 @@ nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)] nameListFromAvails as = map (\n -> (nameSrcSpan n, n)) (concatMap availNames as) -#if MIN_VERSION_ghc(8,8,0) +#if MIN_VERSION_ghc(9,0,0) +-- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x) +-- type HasSrcSpan x = () :: Constraint + +class HasSrcSpan a where + getLoc :: a -> SrcSpan + +instance HasSrcSpan (GenLocated SrcSpan a) where + getLoc = GHC.getLoc + +-- getLoc :: GenLocated l a -> l +-- getLoc = GHC.getLoc +#elif MIN_VERSION_ghc(8,8,0) type HasSrcSpan = GHC.HasSrcSpan getLoc :: HasSrcSpan a => a -> SrcSpan getLoc = GHC.getLoc @@ -252,8 +354,137 @@ getModuleHash = mi_mod_hash . mi_final_exts getModuleHash = mi_mod_hash #endif -getPackageName :: DynFlags -> Module.InstalledUnitId -> Maybe PackageName -getPackageName dfs i = packageName <$> lookupPackage dfs (Module.DefiniteUnitId (Module.DefUnitId i)) +-- type PackageName = Packages.PackageName +#if MIN_VERSION_ghc(9,0,0) +-- NOTE: Since both the new and old version uses UnitId with different meaning, +-- we try to avoid it and instead use InstalledUnitId and Unit, since it is unambiguous. +type UnitId = Module.Unit +type InstalledUnitId = Module.UnitId +type PackageConfig = Packages.UnitInfo +pattern DefiniteUnitId x = Module.RealUnit x +definiteUnitId = Module.RealUnit +defUnitId = Module.Definite +installedModule = Module.Module +-- pattern InstalledModule a b = Module.Module a b +packageName = Packages.unitPackageName +lookupPackage = Packages.lookupUnit . unitState +-- lookupPackage' = undefined +-- lookupPackage' b pm u = Packages.lookupUnit' b pm undefined u +-- lookupPackage' b pm u = Packages.lookupUnit' b pm emptyUniqSet u -- TODO: Is this correct? +-- lookupPackage' = fmap Packages.lookupUnit' . unitState +getPackageConfigMap = Packages.unitInfoMap . unitState +preloadClosureUs = Packages.preloadClosure . unitState +-- getPackageConfigMap = unitState +-- getPackageIncludePath = undefined +getPackageIncludePath = Packages.getUnitIncludePath +explicitPackages = Packages.explicitUnits +pkgState = GHC.unitState +packageNameString = Packages.unitPackageNameString +packageVersion = Packages.unitPackageVersion +-- toInstalledUnitId = id -- Module.toUnitId -- TODO: This is probably wrong +toInstalledUnitId = Module.toUnitId +exposedModules = Packages.unitExposedModules +packageConfigId = Packages.mkUnit +moduleUnitId = Module.moduleUnit +lookupInstalledPackage = Packages.lookupUnitId +oldLookupInstalledPackage = Packages.lookupUnitId . unitState +-- initUnits = Packages.initUnits +-- initPackages = initPackagesx +haddockInterfaces = unitHaddockInterfaces + +thisInstalledUnitId = GHC.homeUnitId +thisPackage = DynFlags.homeUnit +setThisInstalledUnitId uid df = df { homeUnitId = uid} + +oldUnhelpfulSpan = UnhelpfulSpan . SrcLoc.UnhelpfulOther +-- unhelpfulOther = unhelpfulOther . _ +pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan +pattern OldRealSrcSpan x <- RealSrcSpan x _ where + OldRealSrcSpan x = RealSrcSpan x Nothing +{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-} + +oldListVisibleModuleNames = Packages.listVisibleModuleNames . unitState +oldLookupModuleWithSuggestions = Packages.lookupModuleWithSuggestions . unitState +-- oldLookupInPackageDB = Packages.lookupInPackageDB . unitState + +oldRenderWithStyle dflags sdoc sty = Out.renderWithStyle (initSDocContext dflags sty) sdoc +oldMkUserStyle _ = Out.mkUserStyle +oldMkErrStyle _ = Out.mkErrStyle + +-- TODO: This is still a mess! +oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc +oldFormatErrDoc dflags = Err.formatErrDoc dummySDocContext + where dummySDocContext = initSDocContext dflags Out.defaultUserStyle +-- oldFormatErrDoc = Err.formatErrDoc . undefined +writeIfaceFile = writeIface + +type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> Out.SDoc -> IO () + +-- alwaysQualify seems to still do the right thing here, according to the "unqualified warnings" test. +logActionCompat :: LogActionCompat -> LogAction +logActionCompat logAction dynFlags wr severity loc = logAction dynFlags wr severity loc alwaysQualify + +-- We are using Safe here, which is not equivalent, but probably what we want. +gcatch :: (Exception e, MonadCatch m) => m a -> (e -> m a) -> m a +gcatch = Safe.catch + +#else + +type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> Out.SDoc -> IO () + +logActionCompat :: LogActionCompat -> LogAction +logActionCompat logAction dynFlags wr severity loc style = logAction dynFlags wr severity loc (Out.queryQual style) + +type Unit = Module.UnitId +-- type PackageConfig = Packages.PackageConfig +definiteUnitId :: Module.DefUnitId -> UnitId +definiteUnitId = Module.DefiniteUnitId +defUnitId :: InstalledUnitId -> Module.DefUnitId +defUnitId = Module.DefUnitId +installedModule :: InstalledUnitId -> ModuleName -> Module.InstalledModule +installedModule = Module.InstalledModule +oldLookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig +oldLookupInstalledPackage = Packages.lookupInstalledPackage +-- packageName = Packages.packageName +-- lookupPackage = Packages.lookupPackage +-- getPackageConfigMap = Packages.getPackageConfigMap +setThisInstalledUnitId :: InstalledUnitId -> DynFlags -> DynFlags +setThisInstalledUnitId uid df = df { thisInstalledUnitId = uid} + +lookupUnit' :: Bool -> PackageConfigMap -> p -> UnitId -> Maybe PackageConfig +lookupUnit' b pcm _ = Packages.lookupPackage' b pcm +preloadClosureUs = const () + +oldUnhelpfulSpan = UnhelpfulSpan +pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan +pattern OldRealSrcSpan x = RealSrcSpan x +{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-} + +pattern NotBoot, IsBoot :: IsBootInterface +pattern NotBoot = False +pattern IsBoot = True + +initUnits = fmap fst . Packages.initPackages + +unitDepends = depends + +oldListVisibleModuleNames = Packages.listVisibleModuleNames +oldLookupModuleWithSuggestions = Packages.lookupModuleWithSuggestions +-- oldLookupInPackageDB = Packages.lookupInPackageDB + +oldRenderWithStyle = Out.renderWithStyle +oldMkUserStyle = Out.mkUserStyle +oldMkErrStyle = Out.mkErrStyle +oldFormatErrDoc = Err.formatErrDoc + +-- Linear Haskell +type Scaled a = a +scaledThing :: Scaled a -> a +scaledThing = id +#endif + +getPackageName :: DynFlags -> InstalledUnitId -> Maybe PackageName +getPackageName dfs i = packageName <$> lookupPackage dfs (definiteUnitId (defUnitId i)) disableWarningsAsErrors :: DynFlags -> DynFlags disableWarningsAsErrors df = @@ -263,6 +494,9 @@ disableWarningsAsErrors df = wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags wopt_unset_fatal dfs f = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } + +getRealSrcSpan :: RealLocated a -> RealSrcSpan +getRealSrcSpan = GHC.getLoc #endif applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> ApiAnns -> ParsedSource -> IO ParsedSource @@ -304,3 +538,54 @@ isQualifiedImport ImportDecl{} = True isQualifiedImport ImportDecl{ideclQualified} = ideclQualified #endif isQualifiedImport _ = False + + + +#if __GLASGOW_HASKELL__ >= 900 +getNodeIds :: HieAST a -> M.Map Identifier (IdentifierDetails a) +getNodeIds = M.foldl' combineNodeIds M.empty . getSourcedNodeInfo . sourcedNodeInfo + +ad `combineNodeIds` (NodeInfo _ _ bd) = M.unionWith (<>) ad bd + +-- Copied from GHC and adjusted to accept TypeIndex instead of Type +-- nodeInfo' :: Ord a => HieAST a -> NodeInfo a +nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex +nodeInfo' = M.foldl' combineNodeInfo' emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo + +combineNodeInfo' :: Ord a => NodeInfo a -> NodeInfo a -> NodeInfo a +(NodeInfo as ai ad) `combineNodeInfo'` (NodeInfo bs bi bd) = + NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd) + where + mergeSorted :: Ord a => [a] -> [a] -> [a] + mergeSorted la@(a:as) lb@(b:bs) = case compare a b of + LT -> a : mergeSorted as lb + EQ -> a : mergeSorted as bs + GT -> b : mergeSorted la bs + mergeSorted as [] = as + mergeSorted [] bs = bs + +stringToUnit = Module.stringToUnit +rtsUnit = Module.rtsUnit +#else + +getNodeIds = nodeIdentifiers . nodeInfo +-- import qualified FastString as FS + +-- nodeInfo' :: HieAST TypeIndex -> NodeInfo TypeIndex +nodeInfo' :: Ord a => HieAST a -> NodeInfo a +nodeInfo' = nodeInfo +-- type Unit = UnitId +-- unitString :: Unit -> String +-- unitString = unitIdString +stringToUnit :: String -> Unit +stringToUnit = Module.stringToUnitId +-- moduleUnit :: Module -> Unit +-- moduleUnit = moduleUnitId +-- unhelpfulSpanFS :: FS.FastString -> FS.FastString +-- unhelpfulSpanFS = id +rtsUnit = Module.rtsUnitId +#endif + +#if MIN_VERSION_ghc(9,0,0) +#else +#endif diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index d8404b6123..f025957e8d 100644 --- a/ghcide/src/Development/IDE/GHC/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Error.hs @@ -33,6 +33,7 @@ import Bag import Data.Maybe import Data.String (fromString) import qualified Data.Text as T +import qualified Development.IDE.GHC.Compat as GHC import Development.IDE.GHC.Orphans () import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location @@ -68,8 +69,8 @@ diagFromErrMsg diagSource dflags e = formatErrorWithQual :: DynFlags -> ErrMsg -> String formatErrorWithQual dflags e = Out.showSDoc dflags - $ Out.withPprStyle (Out.mkErrStyle dflags $ errMsgContext e) - $ ErrUtils.formatErrDoc dflags + $ Out.withPprStyle (GHC.oldMkErrStyle dflags $ errMsgContext e) + $ GHC.oldFormatErrDoc dflags $ ErrUtils.errMsgDoc e diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic] @@ -77,8 +78,9 @@ diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) -- | Convert a GHC SrcSpan to a DAML compiler Range srcSpanToRange :: SrcSpan -> Maybe Range -srcSpanToRange (UnhelpfulSpan _) = Nothing -srcSpanToRange (RealSrcSpan real) = Just $ realSrcSpanToRange real +srcSpanToRange (UnhelpfulSpan _) = Nothing +srcSpanToRange (GHC.OldRealSrcSpan real) = Just $ realSrcSpanToRange real +-- srcSpanToRange = fmap realSrcSpanToRange . realSpan realSrcSpanToRange :: RealSrcSpan -> Range realSrcSpanToRange real = @@ -93,7 +95,8 @@ realSrcLocToPosition real = -- FIXME This may not be an _absolute_ file name, needs fixing. srcSpanToFilename :: SrcSpan -> Maybe FilePath srcSpanToFilename (UnhelpfulSpan _) = Nothing -srcSpanToFilename (RealSrcSpan real) = Just $ FS.unpackFS $ srcSpanFile real +srcSpanToFilename (GHC.OldRealSrcSpan real) = Just $ FS.unpackFS $ srcSpanFile real +-- srcSpanToFilename = fmap (FS.unpackFS . srcSpanFile) . realSpan realSrcSpanToLocation :: RealSrcSpan -> Location realSrcSpanToLocation real = Location file (realSrcSpanToRange real) @@ -107,7 +110,7 @@ srcSpanToLocation src = do pure $ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' fs) rng rangeToSrcSpan :: NormalizedFilePath -> Range -> SrcSpan -rangeToSrcSpan = fmap RealSrcSpan . rangeToRealSrcSpan +rangeToSrcSpan = fmap GHC.OldRealSrcSpan . rangeToRealSrcSpan rangeToRealSrcSpan :: NormalizedFilePath -> Range -> RealSrcSpan @@ -149,7 +152,7 @@ diagFromString diagSource sev sp x = [diagFromText diagSource sev sp $ T.pack x] -- | Produces an "unhelpful" source span with the given string. noSpan :: String -> SrcSpan -noSpan = UnhelpfulSpan . FS.fsLit +noSpan = GHC.oldUnhelpfulSpan . FS.fsLit -- | creates a span with zero length in the filename of the argument passed @@ -160,8 +163,8 @@ zeroSpan file = realSrcLocSpan (mkRealSrcLoc file 1 1) realSpan :: SrcSpan -> Maybe RealSrcSpan realSpan = \case - RealSrcSpan r -> Just r - UnhelpfulSpan _ -> Nothing + GHC.OldRealSrcSpan r -> Just r + UnhelpfulSpan _ -> Nothing -- | Catch the errors thrown by GHC (SourceErrors and diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 493a391d19..ba92091be6 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -35,14 +35,22 @@ instance Show Linkable where show = prettyPrint instance NFData Linkable where rnf = rwhnf instance Show PackageFlag where show = prettyPrint instance Show InteractiveImport where show = prettyPrint -instance Show ComponentId where show = prettyPrint instance Show PackageName where show = prettyPrint + +#if !MIN_VERSION_ghc(9,0,1) +instance Show ComponentId where show = prettyPrint instance Show SourcePackageId where show = prettyPrint -instance Show InstalledUnitId where +instance Show GhcPlugins.InstalledUnitId where show = installedUnitIdString -instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS +instance NFData GhcPlugins.InstalledUnitId where rnf = rwhnf . installedUnitIdFS + +instance Hashable GhcPlugins.InstalledUnitId where + hashWithSalt salt = hashWithSalt salt . installedUnitIdString +#else +instance Show InstalledUnitId where show = prettyPrint +#endif instance NFData SB.StringBuffer where rnf = rwhnf @@ -71,9 +79,6 @@ instance NFData FastString where instance NFData ParsedModule where rnf = rwhnf -instance Hashable InstalledUnitId where - hashWithSalt salt = hashWithSalt salt . installedUnitIdString - instance Show HieFile where show = show . hie_module @@ -150,3 +155,10 @@ instance Show (Annotated ParsedSource) where instance NFData (Annotated ParsedSource) where rnf = rwhnf + +#if MIN_VERSION_ghc(9,0,1) +instance (NFData HsModule) where +#else +instance (NFData (HsModule a)) where +#endif + rnf = rwhnf diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index f50cf1e386..fd13dd8f27 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -67,12 +67,8 @@ import Lexer import Module (moduleNameSlashes) import OccName (parenSymOcc) import Outputable (Depth (..), Outputable, SDoc, - mkUserStyle, neverQualify, ppr, - renderWithStyle, + neverQualify, ppr, showSDocUnsafe) -import PackageConfig (PackageConfig) -import Packages (getPackageConfigMap, - lookupPackage') import RdrName (nameRdrName, rdrNameOcc) import SrcLoc (mkRealSrcLoc) import StringBuffer @@ -92,15 +88,17 @@ modifyDynFlags f = do modifySession $ \h -> h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} } --- | Given a 'UnitId' try and find the associated 'PackageConfig' in the environment. -lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig -lookupPackageConfig unitId env = - lookupPackage' False pkgConfigMap unitId +-- | Given a 'Unit' try and find the associated 'PackageConfig' in the environment. +lookupPackageConfig :: Unit -> HscEnv -> Maybe GHC.PackageConfig +lookupPackageConfig unit env = + -- GHC.lookupPackage' False pkgConfigMap unit + GHC.lookupUnit' False pkgConfigMap prClsre unit where pkgConfigMap = -- For some weird reason, the GHC API does not provide a way to get the PackageConfigMap -- from PackageState so we have to wrap it in DynFlags first. getPackageConfigMap $ hsc_dflags env + prClsre = preloadClosureUs $ hsc_dflags env -- | Convert from the @text@ package to the @GHC@ 'StringBuffer'. @@ -127,7 +125,7 @@ prettyPrint :: Outputable a => a -> String prettyPrint = unsafePrintSDoc . ppr unsafePrintSDoc :: SDoc -> String -unsafePrintSDoc sdoc = renderWithStyle dflags sdoc (mkUserStyle dflags neverQualify AllTheWay) +unsafePrintSDoc sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags neverQualify AllTheWay) where dflags = unsafeGlobalDynFlags @@ -260,13 +258,17 @@ dupHandleTo filepath h other_side -- | This is copied unmodified from GHC since it is not exposed. -- Note the beautiful inline comment! +#if MIN_VERSION_ghc(9,0,0) +dupHandle_ :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev +#else dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev +#endif -> FilePath -> Maybe (MVar Handle__) -> Handle__ -> Maybe HandleFinalizer -> IO Handle -dupHandle_ new_dev filepath other_side _h_@Handle__{..} mb_finalizer = do +dupHandle_ new_dev filepath other_side Handle__{..} mb_finalizer = do -- XXX wrong! mb_codec <- if isJust haEncoder then fmap Just getLocaleEncoding else return Nothing mkHandle new_dev filepath haType True{-buffered-} mb_codec diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index f6838ce51c..df7ef0fb39 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/ghcide/src/Development/IDE/GHC/Warnings.hs @@ -11,6 +11,8 @@ import GhcPlugins as GHC hiding (Var, (<>)) import Control.Concurrent.Strict import qualified Data.Text as T +import Development.IDE.GHC.Compat (LogActionCompat, + logActionCompat) import Development.IDE.GHC.Error import Development.IDE.Types.Diagnostics import Language.LSP.Types (type (|?) (..)) @@ -28,11 +30,11 @@ import Language.LSP.Types (type (|?) (..)) withWarnings :: T.Text -> ((ModSummary -> ModSummary) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) withWarnings diagSource action = do warnings <- newVar [] - let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () - newAction dynFlags wr _ loc style msg = do - let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc (queryQual style) msg + let newAction :: LogActionCompat + newAction dynFlags wr _ loc prUnqual msg = do + let wr_d = map ((wr,) . third3 (attachReason wr)) $ diagFromErrMsg diagSource dynFlags $ mkWarnMsg dynFlags loc prUnqual msg modifyVar_ warnings $ return . (wr_d:) - res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = newAction}} + res <- action $ \x -> x{ms_hspp_opts = (ms_hspp_opts x){log_action = logActionCompat newAction}} warns <- readVar warnings return (reverse $ concat warns, res) diff --git a/ghcide/src/Development/IDE/Import/FindImports.hs b/ghcide/src/Development/IDE/Import/FindImports.hs index bfcdf3f510..c5ab02a312 100644 --- a/ghcide/src/Development/IDE/Import/FindImports.hs +++ b/ghcide/src/Development/IDE/Import/FindImports.hs @@ -13,7 +13,7 @@ module Development.IDE.Import.FindImports , mkImportDirs ) where -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Error as ErrUtils import Development.IDE.GHC.Orphans () import Development.IDE.Types.Diagnostics @@ -87,7 +87,7 @@ locateModuleFile import_dirss exts doesExist isSource modName = do -- It only returns Just for unit-ids which are possible to import into the -- current module. In particular, it will return Nothing for 'main' components -- as they can never be imported into another package. -mkImportDirs :: DynFlags -> (M.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath]) +mkImportDirs :: DynFlags -> (Compat.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath]) mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i -- | locate a module in either the file system or the package database. Where we go from *daml to @@ -95,7 +95,7 @@ mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName locateModule :: MonadIO m => DynFlags - -> [(M.InstalledUnitId, DynFlags)] -- ^ Import directories + -> [(Compat.InstalledUnitId, DynFlags)] -- ^ Import directories -> [String] -- ^ File extensions -> (ModuleName -> NormalizedFilePath -> m Bool) -- ^ does file exist predicate -> Located ModuleName -- ^ Module name @@ -135,7 +135,7 @@ locateModule dflags comp_info exts doesExist modName mbPkgName isSource = do Just file -> toModLocation file lookupInPackageDB dfs = - case lookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of + case oldLookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of LookupFound _m _pkgConfig -> return $ Right PackageImport reason -> return $ Left $ notFoundErr dfs modName reason diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index fa8eaabe79..f90b96f04f 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -38,7 +38,7 @@ moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentif -> let declSymbols = mapMaybe documentSymbolForDecl hsmodDecls moduleSymbol = hsmodName >>= \case - (L (RealSrcSpan l) m) -> Just $ + (L (OldRealSrcSpan l) m) -> Just $ (defDocumentSymbol l :: DocumentSymbol) { _name = pprText m , _kind = SkFile @@ -61,7 +61,7 @@ moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentif Nothing -> pure $ Right $ InL (List []) documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol -documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) +documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n <> (case pprText fdTyVars of @@ -71,7 +71,7 @@ documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl , _detail = Just $ pprText fdInfo , _kind = SkFunction } -documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) +documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name <> (case pprText tcdTyVars of @@ -87,11 +87,11 @@ documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ nam , _kind = SkMethod , _selectionRange = realSrcSpanToRange l' } - | L (RealSrcSpan l) (ClassOpSig _ False names _) <- tcdSigs - , L (RealSrcSpan l') n <- names + | L (OldRealSrcSpan l) (ClassOpSig _ False names _) <- tcdSigs + , L (OldRealSrcSpan l') n <- names ] } -documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) +documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name , _kind = SkStruct @@ -101,10 +101,10 @@ documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name { _name = showRdrName n , _kind = SkConstructor , _selectionRange = realSrcSpanToRange l' - , _children = conArgRecordFields (getConArgs x) + , _children = conArgRecordFields (con_args x) } - | L (RealSrcSpan l ) x <- dd_cons - , L (RealSrcSpan l') n <- getConNames x + | L (OldRealSrcSpan l ) x <- dd_cons + , L (OldRealSrcSpan l') n <- getConNames' x ] } where @@ -115,48 +115,48 @@ documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name , _kind = SkField } | L _ cdf <- lcdfs - , L (RealSrcSpan l) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf + , L (OldRealSrcSpan l) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf ] conArgRecordFields _ = Nothing -documentSymbolForDecl (L (RealSrcSpan l) (TyClD _ SynDecl { tcdLName = L (RealSrcSpan l') n })) = Just +documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ SynDecl { tcdLName = L (OldRealSrcSpan l') n })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n , _kind = SkTypeParameter , _selectionRange = realSrcSpanToRange l' } -documentSymbolForDecl (L (RealSrcSpan l) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) +documentSymbolForDecl (L (OldRealSrcSpan l) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty , _kind = SkInterface } -documentSymbolForDecl (L (RealSrcSpan l) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) +documentSymbolForDecl (L (OldRealSrcSpan l) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords (map pprText feqn_pats) , _kind = SkInterface } -documentSymbolForDecl (L (RealSrcSpan l) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) +documentSymbolForDecl (L (OldRealSrcSpan l) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName (unLoc feqn_tycon) <> " " <> T.unwords (map pprText feqn_pats) , _kind = SkInterface } -documentSymbolForDecl (L (RealSrcSpan l) (DerivD _ DerivDecl { deriv_type })) = +documentSymbolForDecl (L (OldRealSrcSpan l) (DerivD _ DerivDecl { deriv_type })) = gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) -> (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs) name , _kind = SkInterface } -documentSymbolForDecl (L (RealSrcSpan l) (ValD _ FunBind{fun_id = L _ name})) = Just +documentSymbolForDecl (L (OldRealSrcSpan l) (ValD _ FunBind{fun_id = L _ name})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name , _kind = SkFunction } -documentSymbolForDecl (L (RealSrcSpan l) (ValD _ PatBind{pat_lhs})) = Just +documentSymbolForDecl (L (OldRealSrcSpan l) (ValD _ PatBind{pat_lhs})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText pat_lhs , _kind = SkFunction } -documentSymbolForDecl (L (RealSrcSpan l) (ForD _ x)) = Just +documentSymbolForDecl (L (OldRealSrcSpan l) (ForD _ x)) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = case x of ForeignImport{} -> name @@ -190,7 +190,7 @@ documentSymbolForImportSummary importSymbols = } documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol -documentSymbolForImport (L (RealSrcSpan l) ImportDecl { ideclName, ideclQualified }) = Just +documentSymbolForImport (L (OldRealSrcSpan l) ImportDecl { ideclName, ideclQualified }) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = "import " <> pprText ideclName , _kind = SkModule @@ -218,3 +218,13 @@ showRdrName = pprText pprText :: Outputable a => a -> Text pprText = pack . showSDocUnsafe . ppr + +-- the version of getConNames for ghc9 is restricted to only the renaming phase +getConNames' :: ConDecl GhcPs -> [Located (IdP GhcPs)] +getConNames' ConDeclH98 {con_name = name} = [name] +getConNames' ConDeclGADT {con_names = names} = names +#if !MIN_VERSION_ghc(8,10,0) +getConNames' (XConDecl NoExt) = [] +#elif !MIN_VERSION_ghc(9,0,0) +getConNames' (XConDecl x) = noExtCon x +#endif diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 767bf7a768..1f2d478335 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -241,7 +241,7 @@ suggestHideShadow ps@(L _ HsModule {hsmodImports}) mTcM mHar Diagnostic {_messag | Just tcM <- mTcM, Just har <- mHar, [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s], - isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s'), + isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (OldRealSrcSpan s'), mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName, title <- "Hide " <> identifier <> " from " <> modName = if modName == "Prelude" && null mDecl @@ -289,7 +289,7 @@ suggestRemoveRedundantImport :: ParsedModule -> Maybe T.Text -> Diagnostic -> [( suggestRemoveRedundantImport ParsedModule{pm_parsed_source = L _ HsModule{hsmodImports}} contents Diagnostic{_range=_range,..} -- The qualified import of ‘many’ from module ‘Control.Applicative’ is redundant | Just [_, bindings] <- matchRegexUnifySpaces _message "The( qualified)? import of ‘([^’]*)’ from module [^ ]* is redundant" - , Just (L _ impDecl) <- find (\(L l _) -> srcSpanToRange l == Just _range ) hsmodImports + , Just (L _ impDecl) <- find (\(L l _) -> _start _range `isInsideSrcSpan` l && _end _range `isInsideSrcSpan` l ) hsmodImports , Just c <- contents , ranges <- map (rangesForBindingImport impDecl . T.unpack) (T.splitOn ", " bindings) , ranges' <- extendAllToIncludeCommaIfPossible False (indexedByPosition $ T.unpack c) (concat ranges) @@ -425,10 +425,10 @@ suggestDeleteUnusedBinding findRelatedSpans indexedContent name - (L (RealSrcSpan l) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = + (L (OldRealSrcSpan l) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = case lname of (L nLoc _name) | isTheBinding nLoc -> - let findSig (L (RealSrcSpan l) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig + let findSig (L (OldRealSrcSpan l) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig findSig _ = [] in extendForSpaces indexedContent (toRange l) : @@ -451,7 +451,7 @@ suggestDeleteUnusedBinding let maybeSpan = findRelatedSigSpan1 name sig in case maybeSpan of Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int - Just (RealSrcSpan span, False) -> pure $ toRange span -- a, b :: Int, a is unused + Just (OldRealSrcSpan span, False) -> pure $ toRange span -- a, b :: Int, a is unused _ -> [] -- Second of the tuple means there is only one match @@ -502,10 +502,10 @@ suggestDeleteUnusedBinding indexedContent name lsigs - (L (RealSrcSpan l) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = + (L (OldRealSrcSpan l) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = if isTheBinding (getLoc lname) then - let findSig (L (RealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig + let findSig (L (OldRealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig findSig _ = [] in extendForSpaces indexedContent (toRange l) : concatMap findSig lsigs else concatMap (findRelatedSpanForMatch indexedContent name) matches @@ -547,7 +547,7 @@ suggestExportUnusedTopBinding srcOpt ParsedModule{pm_parsed_source = L _ HsModul -- we get the last export and the closing bracket and check for comma in that range needsComma :: T.Text -> Located [LIE GhcPs] -> Bool needsComma _ (L _ []) = False - needsComma source (L (RealSrcSpan l) exports) = + needsComma source (L (OldRealSrcSpan l) exports) = let closeParan = _end $ realSrcSpanToRange l lastExport = fmap _end . getLocatedRange $ last exports in case lastExport of @@ -675,7 +675,7 @@ newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text - newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ | Range _ lastLineP : _ <- [ realSrcSpanToRange sp - | (L l@(RealSrcSpan sp) _) <- hsmodDecls + | (L l@(OldRealSrcSpan sp) _) <- hsmodDecls , _start `isInsideSrcSpan` l] , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0} = [ ("Define " <> sig @@ -919,7 +919,14 @@ suggestImportDisambiguation df (Just txt) ps@(L _ HsModule {hsmodImports}) diag@ , mode <- [ ToQualified parensed qual | ExistingImp imps <- [modTarget] +#if MIN_VERSION_ghc(9,0,0) + {- HLINT ignore suggestImportDisambiguation "Use nubOrd" -} + -- TODO: The use of nub here is slow and maybe wrong for UnhelpfulLocation + -- nubOrd can't be used since SrcSpan is intentionally no Ord + , L _ qual <- nub $ mapMaybe (ideclAs . unLoc) +#else , L _ qual <- nubOrd $ mapMaybe (ideclAs . unLoc) +#endif $ NE.toList imps ] ++ [ToQualified parensed modName @@ -987,10 +994,10 @@ disambiguateSymbol pm Diagnostic {..} (T.unpack -> symbol) = \case liftParseAST @(HsExpr GhcPs) df $ prettyPrint $ HsVar @GhcPs noExtField $ - L (UnhelpfulSpan "") rdr + L (oldUnhelpfulSpan "") rdr else Rewrite (rangeToSrcSpan "" _range) $ \df -> liftParseAST @RdrName df $ - prettyPrint $ L (UnhelpfulSpan "") rdr + prettyPrint $ L (oldUnhelpfulSpan "") rdr ] findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) @@ -1266,11 +1273,11 @@ newImportInsertRange :: ParsedSource -> Maybe (Range, Int) newImportInsertRange (L _ HsModule {..}) | Just (uncurry Position -> insertPos, col) <- case hsmodImports of [] -> case getLoc (head hsmodDecls) of - RealSrcSpan s -> let col = srcLocCol (realSrcSpanStart s) - 1 + OldRealSrcSpan s -> let col = srcLocCol (realSrcSpanStart s) - 1 in Just ((srcLocLine (realSrcSpanStart s) - 1, col), col) _ -> Nothing _ -> case getLoc (last hsmodImports) of - RealSrcSpan s -> let col = srcLocCol (realSrcSpanStart s) - 1 + OldRealSrcSpan s -> let col = srcLocCol (realSrcSpanStart s) - 1 in Just ((srcLocLine $ realSrcSpanEnd s,col), col) _ -> Nothing = Just (Range insertPos insertPos, col) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index fc969ba43d..80fa95239a 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -39,7 +39,11 @@ import Ide.Types import qualified Language.LSP.Server as LSP import Language.LSP.Types import qualified Language.LSP.VFS as VFS +#if MIN_VERSION_ghc(9,0,0) +import GHC.Tc.Module (tcRnImportDecls) +#else import TcRnDriver (tcRnImportDecls) +#endif descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 4526dbb999..9f958f17e0 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -266,7 +266,7 @@ mkNameCompItem doc thingParent origName origMod thingType isInfix docs !imp = CI let (args, ret) = splitFunTys t in if isForAllTy ret then getArgs ret - else Prelude.filter (not . isDictTy) args + else Prelude.filter (not . isDictTy) $ map scaledThing args | isPiTy t = getArgs $ snd (splitPiTys t) #if MIN_VERSION_ghc(8,10,0) | Just (Pair _ t) <- coercionKind <$> isCoercionTy_maybe t @@ -309,7 +309,7 @@ cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do packageState = hscEnv env curModName = moduleName curMod - importMap = Map.fromList [ (getLoc imp, imp) | imp <- limports ] + importMap = Map.fromList [ (l, imp) | imp@(L (OldRealSrcSpan l) _) <- limports ] iDeclToModName :: ImportDecl name -> ModuleName iDeclToModName = unLoc . ideclName @@ -337,8 +337,12 @@ cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do (, mempty) <$> toCompItem par curMod curModName n Nothing getComplsForOne (GRE n par False prov) = flip foldMapM (map is_decl prov) $ \spec -> do - -- we don't want to extend import if it's already in scope - let originalImportDecl = if null $ lookupGRE_Name inScopeEnv n then Map.lookup (is_dloc spec) importMap else Nothing + let originalImportDecl = do + -- we don't want to extend import if it's already in scope + guard . null $ lookupGRE_Name inScopeEnv n + -- or if it doesn't have a real location + loc <- realSpan $ is_dloc spec + Map.lookup loc importMap compItem <- toCompItem par curMod (is_mod spec) n originalImportDecl let unqual | is_qual spec = [] diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index d5980d0d0b..cae5364b88 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -80,7 +80,6 @@ import PatSyn (patSynName) import TcEnv (tcInitTidyEnv) import TcRnMonad (initTcWithGbl) import TcRnTypes (TcGblEnv (..)) -import TcType (pprSigmaType) import Text.Regex.TDFA ((=~), (=~~)) typeLensCommandId :: T.Text diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 4f000e1df6..a6c8d7038c 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -60,7 +60,7 @@ import HieDb hiding (pointCommand) -- | Gives a Uri for the module, given the .hie file location and the the module info -- The Bool denotes if it is a boot module -type LookupModule m = FilePath -> ModuleName -> UnitId -> Bool -> MaybeT m Uri +type LookupModule m = FilePath -> ModuleName -> Unit -> Bool -> MaybeT m Uri -- | HieFileResult for files of interest, along with the position mappings newtype FOIReferences = FOIReferences (HM.HashMap NormalizedFilePath (HieAstResult, PositionMapping)) @@ -89,7 +89,7 @@ foiReferencesAtPoint file pos (FOIReferences asts) = Nothing -> ([],[],[]) Just (HAR _ hf _ _ _,mapping) -> let posFile = fromMaybe pos $ fromCurrentPosition mapping pos - names = concat $ pointCommand hf posFile (rights . M.keys . nodeIdentifiers . nodeInfo) + names = concat $ pointCommand hf posFile (rights . M.keys . getNodeIds) adjustedLocs = HM.foldr go [] asts go (HAR _ _ rf tr _, mapping) xs = refs ++ typerefs ++ xs where @@ -154,7 +154,7 @@ documentHighlight -> MaybeT m [DocumentHighlight] documentHighlight hf rf pos = pure highlights where - ns = concat $ pointCommand hf pos (rights . M.keys . nodeIdentifiers . nodeInfo) + ns = concat $ pointCommand hf pos (rights . M.keys . getNodeIds) highlights = do n <- ns ref <- fromMaybe [] (M.lookup (Right n) rf) @@ -209,7 +209,7 @@ atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) pos = listToMaybe $ point range = realSrcSpanToRange $ nodeSpan ast wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n" - info = nodeInfo ast + info = nodeInfoH kind ast names = M.assocs $ nodeIdentifiers info types = nodeType info @@ -251,7 +251,7 @@ typeLocationsAtPoint hiedb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) ts = concat $ pointCommand ast pos getts unfold = map (arr A.!) getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) - where ni = nodeInfo x + where ni = nodeInfo' x getTypes ts = flip concatMap (unfold ts) $ \case HTyVarTy n -> [n] #if MIN_VERSION_ghc(8,8,0) @@ -261,7 +261,11 @@ typeLocationsAtPoint hiedb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) #endif HTyConApp tc (HieArgs xs) -> ifaceTyConName tc : getTypes (map snd xs) HForAllTy _ a -> getTypes [a] +#if MIN_VERSION_ghc(9,0,1) + HFunTy a b c -> getTypes [a,b,c] +#else HFunTy a b -> getTypes [a,b] +#endif HQualTy a b -> getTypes [a,b] HCastTy a -> getTypes [a] _ -> [] @@ -296,7 +300,7 @@ locationsAtPoint -> HieASTs a -> m [Location] locationsAtPoint hiedb lookupModule _ideOptions imports pos ast = - let ns = concat $ pointCommand ast pos (M.keys . nodeIdentifiers . nodeInfo) + let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) zeroPos = Position 0 0 zeroRange = Range zeroPos zeroPos modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports @@ -306,7 +310,7 @@ locationsAtPoint hiedb lookupModule _ideOptions imports pos ast = nameToLocation :: MonadIO m => HieDb -> LookupModule m -> Name -> m (Maybe [Location]) nameToLocation hiedb lookupModule name = runMaybeT $ case nameSrcSpan name of - sp@(RealSrcSpan rsp) + sp@(OldRealSrcSpan rsp) -- Lookup in the db if we got a location in a boot file | not $ "boot" `isSuffixOf` unpackFS (srcSpanFile rsp) -> MaybeT $ pure $ fmap pure $ srcSpanToLocation sp sp -> do @@ -368,3 +372,8 @@ pointCommand hf pos k = sp fs = mkRealSrcSpan (sloc fs) (sloc fs) line = _line pos cha = _character pos + +-- In ghc9, nodeInfo is monomorphic, so we need a case split here +nodeInfoH :: HieKind a -> HieAST a -> NodeInfo a +nodeInfoH (HieFromDisk _) = nodeInfo' +nodeInfoH HieFresh = nodeInfo diff --git a/ghcide/src/Development/IDE/Spans/Common.hs b/ghcide/src/Development/IDE/Spans/Common.hs index 1436c3cd2a..895379e89a 100644 --- a/ghcide/src/Development/IDE/Spans/Common.hs +++ b/ghcide/src/Development/IDE/Spans/Common.hs @@ -30,6 +30,8 @@ import NameEnv import Outputable hiding ((<>)) import Var +import Development.IDE.GHC.Compat (oldMkUserStyle, + oldRenderWithStyle) import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util import qualified Documentation.Haddock.Parser as H @@ -49,8 +51,8 @@ showNameWithoutUniques :: Outputable a => a -> T.Text showNameWithoutUniques = T.pack . prettyprint where dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques - prettyprint x = renderWithStyle dyn (ppr x) style - style = mkUserStyle dyn neverQualify AllTheWay + prettyprint x = oldRenderWithStyle dyn (ppr x) style + style = oldMkUserStyle dyn neverQualify AllTheWay -- | Shows IEWrappedName, without any modifier, qualifier or unique identifier. unqualIEWrapName :: IEWrappedName RdrName -> T.Text diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index 6681379410..95cc889d40 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -36,7 +36,6 @@ import HscTypes (HscEnv (hsc_dflags)) import Language.LSP.Types (filePathToUri, getUri) import Name import NameEnv -import Packages import SrcLoc (RealLocated) import TcRnTypes @@ -142,9 +141,7 @@ getDocumentation sources targetName = fromMaybe [] $ do pure $ docHeaders $ filter (\(L target _) -> isBetween target prevNameSpan targetNameSpan) - $ mapMaybe (\(L l v) -> L <$> realSpan l <*> pure v) - $ join - $ M.elems + $ fold docs where -- Get the name bound by a binding. We only concern ourselves with @@ -157,14 +154,15 @@ getDocumentation sources targetName = fromMaybe [] $ do sortedNameSpans :: [Located RdrName] -> [RealSrcSpan] sortedNameSpans ls = nubSort (mapMaybe (realSpan . getLoc) ls) isBetween target before after = before <= target && target <= after - ann = snd . pm_annotations +#if MIN_VERSION_ghc(9,0,0) + ann = apiAnnComments . pm_annotations +#else + ann = fmap filterReal . snd . pm_annotations + filterReal :: [Located a] -> [RealLocated a] + filterReal = mapMaybe (\(L l v) -> (`L`v) <$> realSpan l) +#endif annotationFileName :: ParsedModule -> Maybe FastString - annotationFileName = fmap srcSpanFile . listToMaybe . realSpans . ann - realSpans :: M.Map SrcSpan [Located a] -> [RealSrcSpan] - realSpans = - mapMaybe (realSpan . getLoc) - . join - . M.elems + annotationFileName = fmap srcSpanFile . listToMaybe . map getRealSrcSpan . fold . ann -- | Shows this part of the documentation docHeaders :: [RealLocated AnnotationComment] @@ -215,7 +213,7 @@ lookupHtmlForModule mkDocPath df m = do -- The file might use "." or "-" as separator map (`intercalate` chunks) [".", "-"] -lookupHtmls :: DynFlags -> UnitId -> Maybe [FilePath] +lookupHtmls :: DynFlags -> Unit -> Maybe [FilePath] lookupHtmls df ui = -- use haddockInterfaces instead of haddockHTMLs: GHC treats haddockHTMLs as URL not path -- and therefore doesn't expand $topdir on Windows diff --git a/ghcide/src/Development/IDE/Spans/LocalBindings.hs b/ghcide/src/Development/IDE/Spans/LocalBindings.hs index 46a3dd5435..cf23e37040 100644 --- a/ghcide/src/Development/IDE/Spans/LocalBindings.hs +++ b/ghcide/src/Development/IDE/Spans/LocalBindings.hs @@ -23,6 +23,7 @@ import Development.IDE.GHC.Compat (Name, RefMap, Scope (..), Type, identType) import Development.IDE.GHC.Error import Development.IDE.Types.Location +import Name (isSystemName) import NameEnv import SrcLoc @@ -118,7 +119,8 @@ getDefiningBindings bs rss -- This is meant for use with the fuzzy `PositionRange` returned by `PositionMapping` getFuzzyScope :: Bindings -> Position -> Position -> [(Name, Maybe Type)] getFuzzyScope bs a b - = nameEnvElts + = filter (not . isSystemName . fst) + $ nameEnvElts $ foldMap snd $ IM.intersections (Interval a b) $ getLocalBindings bs diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index bece015000..bca62f96f4 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -26,15 +26,10 @@ import Development.IDE.GHC.Error (catchSrcErrors) import Development.IDE.GHC.Util (lookupPackageConfig) import Development.IDE.Graph.Classes import Development.IDE.Types.Exports (ExportsMap, createExportsMap) -import GhcPlugins (HscEnv (hsc_dflags), - InstalledPackageInfo (exposedModules), - Module (..), - PackageState (explicitPackages), - listVisibleModuleNames, - packageConfigId) +import GhcPlugins (HscEnv (hsc_dflags)) import LoadIface (loadInterface) import qualified Maybes -import Module (InstalledUnitId) +-- import Module (InstalledUnitId) import OpenTelemetry.Eventlog (withSpan) import System.Directory (canonicalizePath) import System.FilePath @@ -95,8 +90,8 @@ newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do doOne (pkg, mn) = do modIface <- liftIO $ initIfaceLoad hscEnv $ loadInterface "" - (Module (packageConfigId pkg) mn) - (ImportByUser False) + (mkModule (packageConfigId pkg) mn) + (ImportByUser NotBoot) return $ case modIface of Maybes.Failed _r -> Nothing Maybes.Succeeded mi -> Just mi @@ -109,7 +104,7 @@ newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do <$> catchSrcErrors dflags "listVisibleModuleNames" - (evaluate . force . Just $ listVisibleModuleNames dflags) + (evaluate . force . Just $ oldListVisibleModuleNames dflags) return HscEnvEq{..} diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 2989420f97..817481dfea 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -22,11 +22,9 @@ module Development.IDE.Types.Options import qualified Data.Text as T import Data.Typeable import Development.IDE.Core.RuleTypes +import Development.IDE.GHC.Compat as GHC import Development.IDE.Graph import Development.IDE.Types.Diagnostics -import GHC hiding (parseModule, - typecheckModule) -import GhcPlugins as GHC hiding (fst3, (<>)) import Ide.Plugin.Config import Ide.Types (DynFlagsModifications) import qualified Language.LSP.Types.Capabilities as LSP diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 461eda9123..ede8f20822 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -538,12 +538,17 @@ diagnosticTests = testGroup "diagnostics" , "foo = 1 {-|-}" ] _ <- createDoc "Foo.hs" "haskell" fooContent +#if MIN_VERSION_ghc(9,0,1) + -- Haddock parse errors are ignored on ghc-9.0.1 + pure () +#else expectDiagnostics [ ( "Foo.hs" , [(DsWarning, (2, 8), "Haddock parse error on input") ] ) ] +#endif , testSessionWait "strip file path" $ do let name = "Testing" @@ -2213,14 +2218,14 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t [ (DsWarning, (6, 8), "Defaulting the following constraint") , (DsWarning, (6, 16), "Defaulting the following constraint") ] - "Add type annotation ‘[Char]’ to ‘\"debug\"’" + ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" , "module A (f) where" , "" , "import Debug.Trace" , "" - , "f = seq (\"debug\" :: [Char]) traceShow \"debug\"" + , "f = seq (\"debug\" :: " <> listOfChar <> ") traceShow \"debug\"" ]) , testSession "add default type to satisfy two contraints" $ testFor @@ -2233,14 +2238,14 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t , "f a = traceShow \"debug\" a" ]) [ (DsWarning, (6, 6), "Defaulting the following constraint") ] - "Add type annotation ‘[Char]’ to ‘\"debug\"’" + ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" , "module A (f) where" , "" , "import Debug.Trace" , "" - , "f a = traceShow (\"debug\" :: [Char]) a" + , "f a = traceShow (\"debug\" :: " <> listOfChar <> ") a" ]) , testSession "add default type to satisfy two contraints with duplicate literals" $ testFor @@ -2253,14 +2258,14 @@ addTypeAnnotationsToLiteralsTest = testGroup "add type annotations to literals t , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow \"debug\"))" ]) [ (DsWarning, (6, 54), "Defaulting the following constraint") ] - "Add type annotation ‘[Char]’ to ‘\"debug\"’" + ("Add type annotation ‘" <> listOfChar <> "’ to ‘\"debug\"’") (T.unlines [ "{-# OPTIONS_GHC -Wtype-defaults #-}" , "{-# LANGUAGE OverloadedStrings #-}" , "module A (f) where" , "" , "import Debug.Trace" , "" - , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: [Char])))" + , "f = seq (\"debug\" :: [Char]) (seq (\"debug\" :: [Char]) (traceShow (\"debug\" :: " <> listOfChar <> ")))" ]) ] where @@ -3406,7 +3411,7 @@ addSigLensesTests = , ("pattern Some a = Just a", "pattern Some :: a -> Maybe a") , ("qualifiedSigTest= C.realPart", "qualifiedSigTest :: C.Complex a -> a") , ("head = 233", "head :: Integer") - , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, [Char])") + , ("rank2Test (k :: forall a . a -> a) = (k 233 :: Int, k \"QAQ\")", "rank2Test :: (forall a. a -> a) -> (Int, " <> listOfChar <> ")") , ("symbolKindTest = Proxy @\"qwq\"", "symbolKindTest :: Proxy \"qwq\"") , ("promotedKindTest = Proxy @Nothing", "promotedKindTest :: Proxy 'Nothing") , ("typeOperatorTest = Refl", "typeOperatorTest :: a :~: a") @@ -3578,7 +3583,13 @@ findDefinitionAndHoverTests = let in mkFindTests -- def hover look expect - [ test yes yes fffL4 fff "field in record definition" + [ +#if MIN_VERSION_ghc(9,0,0) + -- It suggests either going to the constructor or to the field + test broken yes fffL4 fff "field in record definition" +#else + test yes yes fffL4 fff "field in record definition" +#endif , test yes yes fffL8 fff "field in record construction #1102" , test yes yes fffL14 fff "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs , test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120 @@ -3614,7 +3625,11 @@ findDefinitionAndHoverTests = let , test no broken chrL36 litC "literal Char in hover info #1016" , test no broken txtL8 litT "literal Text in hover info #1016" , test no broken lstL43 litL "literal List in hover info #1016" +#if MIN_VERSION_ghc(9,0,0) + , test no yes docL41 constr "type constraint in hover info #1012" +#else , test no broken docL41 constr "type constraint in hover info #1012" +#endif , test broken broken outL45 outSig "top-level signature #767" , test broken broken innL48 innSig "inner signature #767" , test no yes holeL60 hleInfo "hole without internal name #831" @@ -3802,6 +3817,8 @@ thTests = T.unlines [ "{-# LANGUAGE TemplateHaskell #-}" , "module A (a) where" + , "import Language.Haskell.TH (ExpQ)" + , "a :: ExpQ" -- TH 2.17 requires an explicit type signature since splices are polymorphic , "a = [| glorifiedID |]" , "glorifiedID :: a -> a" , "glorifiedID = id" ] @@ -3844,7 +3861,7 @@ thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do bdoc <- createDoc bPath "haskell" bSource cdoc <- createDoc cPath "haskell" cSource - expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] + expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] -- Change th from () to Bool let aSource' = T.unlines $ init (T.lines aSource) ++ ["th_a = [d| a = False|]"] @@ -3856,7 +3873,7 @@ thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do expectDiagnostics [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) ,("THC.hs", [(DsWarning, (6,0), "Top-level binding")]) - ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")]) + ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level bindin")]) ] closeDoc adoc @@ -3879,7 +3896,7 @@ thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do adoc <- createDoc aPath "haskell" aSource bdoc <- createDoc bPath "haskell" bSource - expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] + expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] let aSource' = T.unlines $ init (init (T.lines aSource)) ++ ["th :: DecsQ", "th = [d| a = False|]"] changeDoc adoc [TextDocumentContentChangeEvent Nothing Nothing aSource'] @@ -3888,7 +3905,7 @@ thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"] changeDoc bdoc [TextDocumentContentChangeEvent Nothing Nothing bSource'] - expectDiagnostics [("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] + expectDiagnostics [("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] closeDoc adoc closeDoc bdoc @@ -4339,16 +4356,21 @@ highlightTests = testGroup "highlight" , DocumentHighlight (R 6 10 6 13) (Just HkRead) , DocumentHighlight (R 7 12 7 15) (Just HkRead) ] - , testSessionWait "record" $ do + , +#if MIN_VERSION_ghc(9,0,0) + expectFailBecause "Ghc9 highlights the constructor and not just this field" $ +#endif + testSessionWait "record" $ do doc <- createDoc "A.hs" "haskell" recsource _ <- waitForDiagnostics highlights <- getHighlights doc (Position 4 15) liftIO $ highlights @?= List -- Span is just the .. on 8.10, but Rec{..} before + [ #if MIN_VERSION_ghc(8,10,0) - [ DocumentHighlight (R 4 8 4 10) (Just HkWrite) + DocumentHighlight (R 4 8 4 10) (Just HkWrite) #else - [ DocumentHighlight (R 4 4 4 11) (Just HkWrite) + DocumentHighlight (R 4 4 4 11) (Just HkWrite) #endif , DocumentHighlight (R 4 14 4 20) (Just HkRead) ] @@ -4742,7 +4764,12 @@ dependentFileTest = testGroup "addDependentFile" _ <- createDoc "Foo.hs" "haskell" fooContent doc <- createDoc "Baz.hs" "haskell" bazContent expectDiagnostics +#if MIN_VERSION_ghc(9,0,0) + -- String vs [Char] causes this change in error message + [("Foo.hs", [(DsError, (4, 6), "Couldn't match type")])] +#else [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] +#endif -- Now modify the dependent file liftIO $ writeFile depFilePath "B" sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ @@ -4890,7 +4917,7 @@ ifaceTHTest = testCase "iface-th-test" $ runWithExtraFiles "TH" $ \dir -> do changeDoc cdoc [TextDocumentContentChangeEvent Nothing Nothing cSource] expectDiagnostics [("THC.hs", [(DsError, (4, 4), "Couldn't match expected type '()' with actual type 'Bool'")]) - ,("THB.hs", [(DsWarning, (4,0), "Top-level binding")])] + ,("THB.hs", [(DsWarning, (4,thDollarIdx), "Top-level binding")])] closeDoc cdoc ifaceErrorTest :: TestTree @@ -5009,7 +5036,12 @@ sessionDepsArePickedUp = testSession' -- Open without OverloadedStrings and expect an error. doc <- createDoc "Foo.hs" "haskell" fooContent expectDiagnostics +#if MIN_VERSION_ghc(9,0,0) + -- String vs [Char] causes this change in error message + [("Foo.hs", [(DsError, (3, 6), "Couldn't match type")])] +#else [("Foo.hs", [(DsError, (3, 6), "Couldn't match expected type")])] +#endif -- Update hie.yaml to enable OverloadedStrings. liftIO $ writeFileUTF8 @@ -5315,7 +5347,7 @@ testSessionWithExtraFiles prefix name = testCase name . runWithExtraFiles prefix testSession' :: String -> (FilePath -> Session ()) -> TestTree testSession' name = testCase name . run' -testSessionWait :: String -> Session () -> TestTree +testSessionWait :: HasCallStack => String -> Session () -> TestTree testSessionWait name = testSession name . -- Check that any diagnostics produced were already consumed by the test case. -- @@ -5716,3 +5748,19 @@ assertJust :: MonadIO m => String -> Maybe a -> m a assertJust s = \case Nothing -> liftIO $ assertFailure s Just x -> pure x + +-- | Before ghc9, lists of Char is displayed as [Char], but with ghc9 and up, it's displayed as String +listOfChar :: T.Text +#if MIN_VERSION_ghc(9,0,1) +listOfChar = "String" +#else +listOfChar = "[Char]" +#endif + +-- | Ghc 9 doesn't include the $-sign in TH warnings like earlier versions did +thDollarIdx :: Int +#if MIN_VERSION_ghc(9,0,1) +thDollarIdx = 1 +#else +thDollarIdx = 0 +#endif diff --git a/ghcide/test/src/Development/IDE/Test.hs b/ghcide/test/src/Development/IDE/Test.hs index 420fb6736c..90e9b7ba31 100644 --- a/ghcide/test/src/Development/IDE/Test.hs +++ b/ghcide/test/src/Development/IDE/Test.hs @@ -47,7 +47,7 @@ type Cursor = (Int, Int) cursorPosition :: Cursor -> Position cursorPosition (line, col) = Position line col -requireDiagnostic :: List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) -> Assertion +requireDiagnostic :: HasCallStack => List Diagnostic -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) -> Assertion requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) = do unless (any match actuals) $ assertFailure $ @@ -69,7 +69,7 @@ requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) -- |wait for @timeout@ seconds and report an assertion failure -- if any diagnostic messages arrive in that period -expectNoMoreDiagnostics :: Seconds -> Session () +expectNoMoreDiagnostics :: HasCallStack => Seconds -> Session () expectNoMoreDiagnostics timeout = expectMessages STextDocumentPublishDiagnostics timeout $ \diagsNot -> do let fileUri = diagsNot ^. params . uri @@ -109,7 +109,7 @@ flushMessages = do -- -- Rather than trying to assert the absence of diagnostics, introduce an -- expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic. -expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session () +expectDiagnostics :: HasCallStack => [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session () expectDiagnostics = expectDiagnosticsWithTags . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) @@ -117,7 +117,7 @@ expectDiagnostics unwrapDiagnostic :: NotificationMessage TextDocumentPublishDiagnostics -> (Uri, List Diagnostic) unwrapDiagnostic diagsNot = (diagsNot^.params.uri, diagsNot^.params.diagnostics) -expectDiagnosticsWithTags :: [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () +expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () expectDiagnosticsWithTags expected = do let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri next = unwrapDiagnostic <$> skipManyTill anyMessage diagnostic @@ -125,7 +125,7 @@ expectDiagnosticsWithTags expected = do expectDiagnosticsWithTags' next expected' expectDiagnosticsWithTags' :: - MonadIO m => + (HasCallStack, MonadIO m) => m (Uri, List Diagnostic) -> Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] -> m () @@ -165,12 +165,12 @@ expectDiagnosticsWithTags' next expected = go expected <> show actual go $ Map.delete canonUri m -expectCurrentDiagnostics :: TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session () +expectCurrentDiagnostics :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session () expectCurrentDiagnostics doc expected = do diags <- getCurrentDiagnostics doc checkDiagnosticsForDoc doc expected diags -checkDiagnosticsForDoc :: TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session () +checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session () checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do let expected' = Map.fromList [(nuri, map (\(ds, c, t) -> (ds, c, t, Nothing)) expected)] nuri = toNormalizedUri _uri diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index f360eaf32f..f9ad2379f6 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -316,6 +316,7 @@ executable haskell-language-server , cryptohash-sha1 , deepseq , ghc + , ghc-api-compat , ghc-boot-th , ghcide , hashable @@ -416,6 +417,7 @@ test-suite func-test Symbol TypeDefinition Test.Hls.Command + Test.Hls.Flags default-extensions: OverloadedStrings ghc-options: @@ -424,6 +426,39 @@ test-suite func-test if flag(pedantic) ghc-options: -Werror -Wredundant-constraints + if flag(class) || flag(all-plugins) + cpp-options: -Dclass + if flag(haddockComments) || flag(all-plugins) + cpp-options: -DhaddockComments + if flag(eval) || flag(all-plugins) + cpp-options: -Deval + if flag(importLens) || flag(all-plugins) + cpp-options: -DimportLens + if flag(retrie) || flag(all-plugins) + cpp-options: -Dretrie + if flag(tactic) || flag(all-plugins) + cpp-options: -Dtactic + if flag(hlint) || flag(all-plugins) + cpp-options: -Dhlint + if flag(moduleName) || flag(all-plugins) + cpp-options: -DmoduleName + if flag(pragmas) || flag(all-plugins) + cpp-options: -Dpragmas + if flag(splice) || flag(all-plugins) + cpp-options: -Dsplice + +-- formatters + if flag(floskell) || flag(all-formatters) + cpp-options: -Dfloskell + if flag(fourmolu) || flag(all-formatters) + cpp-options: -Dfourmolu + if flag(ormolu) || flag(all-formatters) + cpp-options: -Dormolu + if flag(stylishHaskell) || flag(all-formatters) + cpp-options: -DstylishHaskell + if (flag(brittany) || flag(all-formatters)) + cpp-options: -Dbrittany + test-suite wrapper-test type: exitcode-stdio-1.0 build-tool-depends: diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index 11ee0eb004..84de4c7f33 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -44,6 +44,7 @@ library , Diff ^>=0.4.0 , dlist , ghc + , ghc-api-compat , hashable , hslogger , lens diff --git a/plugins/hls-class-plugin/hls-class-plugin.cabal b/plugins/hls-class-plugin/hls-class-plugin.cabal index 96b4146dcb..6691b7483c 100644 --- a/plugins/hls-class-plugin/hls-class-plugin.cabal +++ b/plugins/hls-class-plugin/hls-class-plugin.cabal @@ -28,6 +28,7 @@ library , base >=4.12 && <5 , containers , ghc + , ghc-api-compat , ghc-exactprint , ghcide >=1.2 && <1.4 , hls-plugin-api ^>=1.1 diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index d8064b0390..84a1dee0ce 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -59,6 +59,7 @@ library , extra , filepath , ghc + , ghc-api-compat , ghc-boot-th , ghc-paths , ghcide >=1.2 && <1.4 diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index ab0cac5865..b0602a3583 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE FlexibleContexts #-} @@ -6,6 +7,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -74,7 +76,8 @@ import Development.IDE.GHC.Compat (AnnotationComment (AnnBlo GenLocated (L), GhcException, HscEnv, ParsedModule (..), - SrcSpan (RealSrcSpan, UnhelpfulSpan), + SrcSpan (UnhelpfulSpan), + moduleName, setInteractiveDynFlags, srcSpanFile) import qualified Development.IDE.GHC.Compat as SrcLoc @@ -89,7 +92,6 @@ import GHC (ExecOptions (execLineNumb HscTarget (HscInterpreted), LoadHowMuch (LoadAllTargets), ModSummary (ms_hspp_opts), - Module (moduleName), SuccessFlag (Failed, Succeeded), TcRnExprMode (..), execOptions, exprType, @@ -103,13 +105,9 @@ import GHC (ExecOptions (execLineNumb import GhcPlugins (DynFlags (..), defaultLogActionHPutStrDoc, gopt_set, gopt_unset, - hsc_dflags, interpWays, + hsc_dflags, parseDynamicFlagsCmdLine, - targetPlatform, - updateWays, - wayGeneralFlags, - wayUnsetGeneralFlags, - xopt_set) + targetPlatform, xopt_set) import HscTypes (InteractiveImport (IIModule), ModSummary (ms_mod), Target (Target), @@ -141,6 +139,27 @@ import System.IO (hClose) import UnliftIO.Temporary (withSystemTempFile) import Util (OverridingBool (Never)) + +#if MIN_VERSION_ghc(9,0,0) +import GHC.Parser.Annotation (ApiAnns (apiAnnComments)) +#else +import GhcPlugins (interpWays, updateWays, + wayGeneralFlags, + wayUnsetGeneralFlags) +#endif + +#if MIN_VERSION_ghc(9,0,0) +pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan +pattern RealSrcSpanAlready x = x +#else +apiAnnComments :: SrcLoc.ApiAnns -> Map.Map SrcSpan [SrcLoc.Located AnnotationComment] +apiAnnComments = snd + +pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan +pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x +#endif + + {- | Code Lens provider NOTE: Invoked every time the document is modified, not just when the document is saved. -} @@ -159,7 +178,7 @@ codeLens st plId CodeLensParams{_textDocument} = runAction "parsed" st $ useWithStale_ GetParsedModuleWithComments nfp let comments = foldMap ( foldMap $ \case - L (RealSrcSpan real) bdy + L (RealSrcSpanAlready real) bdy | unpackFS (srcSpanFile real) == fromNormalizedFilePath nfp , let ran0 = realSrcSpanToRange real @@ -176,7 +195,7 @@ codeLens st plId CodeLensParams{_textDocument} = _ -> mempty _ -> mempty ) - $ snd pm_annotations + $ apiAnnComments pm_annotations dbg "excluded comments" $ show $ DL.toList $ foldMap (foldMap $ \(L a b) -> @@ -185,7 +204,7 @@ codeLens st plId CodeLensParams{_textDocument} = AnnBlockComment{} -> mempty _ -> DL.singleton (a, b) ) - $ snd pm_annotations + $ apiAnnComments pm_annotations dbg "comments" $ show comments -- Extract tests from source code @@ -285,6 +304,20 @@ runEvalCmd st EvalParams{..} = df <- getSessionDynFlags setInteractiveDynFlags $ (foldl xopt_set idflags evalExtensions) +#if MIN_VERSION_ghc(9,0,0) + { unitState = + unitState + df + , unitDatabases = + unitDatabases + df + , packageFlags = + packageFlags + df + , useColor = Never + , canUseColor = False + } +#else { pkgState = pkgState df @@ -297,10 +330,16 @@ runEvalCmd st EvalParams{..} = , useColor = Never , canUseColor = False } +#endif -- set up a custom log action +#if MIN_VERSION_ghc(9,0,0) + setLogAction $ \_df _wr _sev _span _doc -> + defaultLogActionHPutStrDoc _df logHandle _doc +#else setLogAction $ \_df _wr _sev _span _style _doc -> defaultLogActionHPutStrDoc _df logHandle _doc _style +#endif -- Load the module with its current content (as the saved module might not be up to date) -- BUG: this fails for files that requires preprocessors (e.g. CPP) for ghc < 8.8 diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs index 5a0349f0ba..ae3c26150c 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs @@ -20,13 +20,10 @@ import Development.IDE.GHC.Compat import qualified EnumSet import GHC.LanguageExtensions.Type (Extension (..)) import GhcMonad (modifySession) -import GhcPlugins (DefUnitId (..), - InstalledUnitId (..), fsLit, - hsc_IC, pprHsString) +import GhcPlugins (fsLit, hsc_IC, pprHsString) import HscTypes (InteractiveContext (ic_dflags)) import Ide.Plugin.Eval.Util (asS, gStrictTry) import qualified Lexer -import Module (UnitId (DefiniteUnitId)) import Outputable (Outputable (ppr), SDoc, showSDocUnsafe, text, vcat, (<+>)) import qualified Parser diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs index c081d07189..2489fb2ab6 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Parse/Comments.hs @@ -322,7 +322,7 @@ resultBlockP :: BlockCommentParser [String] resultBlockP = do BlockEnv {..} <- ask many $ - fmap fst . nonEmptyNormalLineP isLhs $ + fmap fst $ nonEmptyNormalLineP isLhs $ Block blockRange positionToSourcePos :: Position -> SourcePos 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 82e3fcf9c3..1c0a6822d0 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -25,8 +25,9 @@ import Data.String (IsString (fromString)) import qualified Data.Text as T import Development.IDE (IdeState, Priority (..), ideLogger, logPriority) +import Development.IDE.GHC.Compat (gcatch) import Exception (ExceptionMonad, SomeException (..), - evaluate, gcatch) + evaluate) import GHC.Exts (toList) import GHC.Stack (HasCallStack, callStack, srcLocFile, srcLocStartCol, 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 88e01fffa5..9c85b93c44 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -19,6 +19,7 @@ library , containers , deepseq , ghc + , ghc-api-compat , ghcide ^>=1.3 , hls-graph , hls-plugin-api ^>=1.1 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 087b197f9e..4194a79e27 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -35,9 +35,14 @@ import Ide.PluginUtils (mkLspCommand) import Ide.Types import Language.LSP.Server import Language.LSP.Types +#if MIN_VERSION_ghc(9,0,0) +import GHC.Builtin.Names (pRELUDE) +#else import PrelNames (pRELUDE) +#endif import RnNames (findImportUsage, getMinimalImports) +import qualified SrcLoc import TcRnMonad (initTcWithGbl) import TcRnTypes (TcGblEnv (tcg_used_gres)) @@ -192,12 +197,13 @@ minimalImportsRule = define $ \MinimalImports nfp -> do (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr let importsMap = Map.fromList - [ (srcSpanStart l, T.pack (prettyPrint i)) - | L l i <- fromMaybe [] mbMinImports + [ (SrcLoc.realSrcSpanStart l, T.pack (prettyPrint i)) + | L (OldRealSrcSpan l) i <- fromMaybe [] mbMinImports ] res = - [ (i, Map.lookup (srcSpanStart (getLoc i)) importsMap) + [ (i, Map.lookup (SrcLoc.realSrcSpanStart l) importsMap) | i <- imports + , OldRealSrcSpan l <- [getLoc i] ] return ([], MinimalImportsResult res <$ mbMinImports) @@ -234,7 +240,7 @@ mkExplicitEdit pred posMapping (L src imp) explicit | ImportDecl {ideclHiding = Just (False, _)} <- imp = Nothing | not (isQualifiedImport imp), - RealSrcSpan l <- src, + OldRealSrcSpan l <- src, L _ mn <- ideclName imp, -- (almost) no one wants to see an explicit import list for Prelude pred mn, diff --git a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs index 58ee2c914a..554dea0836 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} @@ -90,7 +91,11 @@ genForSig = GenComments {..} isFresh Ann {annsDP} = null [() | (AnnComment _, _) <- annsDP] collectKeys = keyFromTyVar 0 +#if MIN_VERSION_ghc(9,0,0) + comment = mkComment "-- ^ " badRealSrcSpan +#else comment = mkComment "-- ^ " noSrcSpan +#endif dp = [(AnnComment comment, DP (0, 1)), (G AnnRarrow, DP (1, 2))] genForRecord :: GenComments @@ -109,7 +114,11 @@ genForRecord = GenComments {..} collectKeys = keyFromCon +#if MIN_VERSION_ghc(9,0,0) + comment = mkComment "-- | " badRealSrcSpan +#else comment = mkComment "-- | " noSrcSpan +#endif ----------------------------------------------------------------------------- @@ -131,7 +140,7 @@ toAction title uri edit = CodeAction {..} toRange :: SrcSpan -> Maybe Range toRange src - | (RealSrcSpan s) <- src, + | (OldRealSrcSpan s) <- src, range' <- realSrcSpanToRange s = Just range' | otherwise = Nothing @@ -146,7 +155,12 @@ cleanPriorComments x = x {annPriorComments = []} ----------------------------------------------------------------------------- keyFromTyVar :: Int -> LHsType GhcPs -> [AnnKey] +#if MIN_VERSION_ghc(9,0,0) +-- GHC9 HsFunTy has 4 arguments, we could extract this +keyFromTyVar dep c@(L _ (HsFunTy _ _ x y)) +#else keyFromTyVar dep c@(L _ (HsFunTy _ x y)) +#endif | dep < 1 = mkAnnKey c : keyFromTyVar dep x ++ keyFromTyVar dep y | otherwise = [] keyFromTyVar dep (L _ t@HsForAllTy {}) = keyFromTyVar dep (hst_body t) diff --git a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal index 08026aca49..93c1a900c4 100644 --- a/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal +++ b/plugins/hls-hlint-plugin/hls-hlint-plugin.cabal @@ -24,6 +24,13 @@ flag ghc-lib description: Force dependency on ghc-lib-parser even if GHC API in the ghc package is supported +flag hlint33 + default: True + manual: False + description: + Hlint-3.3 doesn't support versions ghc-lib < 9.0.1 nor ghc <= 8.6, so we can use hlint-3.2 for backwards compat + This flag can be removed when all dependencies support ghc-lib-9.0.1 and we drop support for ghc-8.6 + library exposed-modules: Ide.Plugin.Hlint hs-source-dirs: src @@ -43,7 +50,7 @@ library , ghc-exactprint >=0.6.3.4 , ghcide >=1.2 && <1.4 , hashable - , hlint ^>=3.2 + , hlint , hls-plugin-api ^>=1.1 , hslogger , lens @@ -54,16 +61,34 @@ library , transformers , unordered-containers - if ((!flag(ghc-lib) && impl(ghc >=8.10.1)) && impl(ghc <9.0.0)) - build-depends: ghc ^>=8.10 + if (flag(hlint33)) + -- This mirrors the logic in hlint.cabal for hlint-3.3 + -- https://github.com/ndmitchell/hlint/blob/d3576de4529d8df6cca5a345f5b7e04474ff7bff/hlint.cabal#L79-L88 + -- so we can make sure that we do the same thing as hlint + build-depends: hlint ^>=3.3 + if (!flag(ghc-lib) && impl(ghc >=9.0.1) && impl(ghc <9.1.0)) + build-depends: ghc ==9.0.* + else + build-depends: + , ghc + , ghc-lib == 9.0.* + , ghc-lib-parser-ex == 9.0.* + + cpp-options: -DHLINT_ON_GHC_LIB else - build-depends: - , ghc - , ghc-lib ^>=8.10.4.20210206 - , ghc-lib-parser-ex ^>=8.10 + -- This mirrors the logic in hlint.cabal for hlint-3.2 + -- https://github.com/ndmitchell/hlint/blob/c7354e473c7d09213c8adc3dc94bf50a6eb4a42d/hlint.cabal#L79-L88 + build-depends: hlint ^>=3.2 + if (!flag(ghc-lib) && impl(ghc >=8.10.1) && impl(ghc < 8.11.0)) + build-depends: ghc >=8.10 && < 9.0 + else + build-depends: + , ghc + , ghc-lib ^>= 8.10.4.20210206 + , ghc-lib-parser-ex ^>= 8.10 - cpp-options: -DHLINT_ON_GHC_LIB + cpp-options: -DHLINT_ON_GHC_LIB ghc-options: -Wall -Wredundant-constraints -Wno-name-shadowing diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 24895a563e..9086ec8b58 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -7,10 +7,17 @@ {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} +#ifdef HLINT_ON_GHC_LIB +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z) +#else +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z) +#endif + module Ide.Plugin.Hlint ( descriptor @@ -66,7 +73,8 @@ import System.IO (IOMode (Wri import System.IO.Temp #else import Development.IDE.GHC.Compat hiding - (DynFlags (..)) + (DynFlags (..), + OldRealSrcSpan) import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions) import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform) import Language.Haskell.GHC.ExactPrint.Types (Rigidity (..)) @@ -94,6 +102,15 @@ import System.Environment (setEnv, unsetEnv) -- --------------------------------------------------------------------- +-- Reimplementing this, since the one in Development.IDE.GHC.Compat isn't for ghc-lib +pattern OldRealSrcSpan :: RealSrcSpan -> SrcSpan +#if MIN_GHC_API_VERSION(9,0,0) +pattern OldRealSrcSpan span <- RealSrcSpan span _ +#else +pattern OldRealSrcSpan span <- RealSrcSpan span +#endif +{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-} + descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) { pluginRules = rules plId @@ -189,7 +206,7 @@ rules plugin = do -- This one is defined in Development.IDE.GHC.Error but here -- the types could come from ghc-lib or ghc srcSpanToRange :: SrcSpan -> LSP.Range - srcSpanToRange (RealSrcSpan span) = Range { + srcSpanToRange (OldRealSrcSpan span) = Range { _start = LSP.Position { _line = srcSpanStartLine span - 1 , _character = srcSpanStartCol span - 1} @@ -229,7 +246,7 @@ getIdeas nfp = do (_, contents) <- getFileContents nfp let fp = fromNormalizedFilePath nfp let contents' = T.unpack <$> contents - Just <$> (liftIO $ parseModuleEx flags' fp contents') + Just <$> liftIO (parseModuleEx flags' fp contents') setExtensions flags = do hlintExts <- getExtensions flags nfp @@ -462,7 +479,7 @@ applyHint ide nfp mhint = ideaPos = (srcSpanStartLine &&& srcSpanStartCol) . toRealSrcSpan . ideaSpan in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas - toRealSrcSpan (RealSrcSpan real) = real + toRealSrcSpan (OldRealSrcSpan real) = real toRealSrcSpan (UnhelpfulSpan x) = error $ "No real source span: " ++ show x showParseError :: Hlint.ParseError -> String 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 637fa3f02e..0348690b80 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wall -Wwarn -fno-warn-type-defaults #-} @@ -26,17 +27,13 @@ import Data.String (IsString) import qualified Data.Text as T import Development.IDE (GetParsedModule (GetParsedModule), GhcSession (GhcSession), IdeState, - List (..), NormalizedFilePath, - Position (Position), Range (Range), evalGhcEnv, hscEnvWithImportPaths, realSrcSpanToRange, runAction, - toNormalizedUri, uriToFilePath', - use, use_) -import Development.IDE.GHC.Compat (GenLocated (L), - SrcSpan (RealSrcSpan), - getSessionDynFlags, hsmodName, - importPaths, pm_parsed_source, - unLoc) + uriToFilePath', use, use_) +import Development.IDE.GHC.Compat (GenLocated (L), getSessionDynFlags, + hsmodName, importPaths, + pattern OldRealSrcSpan, + pm_parsed_source, unLoc) import Ide.Types import Language.LSP.Server import Language.LSP.Types @@ -132,7 +129,7 @@ pathModuleName state normFilePath filePath codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, T.Text)) codeModuleName state nfp = runMaybeT $ do pm <- MaybeT . runAction "ModuleName.GetParsedModule" state $ use GetParsedModule nfp - L (RealSrcSpan l) m <- MaybeT . pure . hsmodName . unLoc $ pm_parsed_source pm + L (OldRealSrcSpan l) m <- MaybeT . pure . hsmodName . unLoc $ pm_parsed_source pm pure (realSrcSpanToRange l, T.pack $ show m) -- traceAs :: Show a => String -> a -> a diff --git a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal index 2ca0e31652..ce5978af7b 100644 --- a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal +++ b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal @@ -21,6 +21,7 @@ library , directory , extra , ghc + , ghc-api-compat , ghcide >=1.2 && <1.4 , hashable , hls-plugin-api ^>=1.1 diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index 0414c7deb8..0768ca86fa 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -5,6 +5,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -64,8 +65,11 @@ import Development.IDE.GHC.Compat (GenLocated (L), GhcRn, TyClGroup (..), fun_id, mi_fixities, moduleNameString, - parseModule, rds_rules, - srcSpanFile) + parseModule, + pattern IsBoot, + pattern NotBoot, + pattern OldRealSrcSpan, + rds_rules, srcSpanFile) import GHC.Generics (Generic) import GhcPlugins (Outputable, SourceText (NoSourceText), @@ -465,8 +469,8 @@ asTextEdits :: Change -> [(Uri, TextEdit)] asTextEdits NoChange = [] asTextEdits (Change reps _imports) = [ (filePathToUri spanLoc, edit) - | Replacement {..} <- nubOrdOn replLocation reps, - (RealSrcSpan rspan) <- [replLocation], + | Replacement {..} <- nubOrdOn (realSpan . replLocation) reps, + (OldRealSrcSpan rspan) <- [replLocation], let spanLoc = unpackFS $ srcSpanFile rspan, let edit = TextEdit (realSrcSpanToRange rspan) (T.pack replReplacement) ] @@ -535,8 +539,9 @@ data ImportSpec = AddImport deriving (Eq, Show, Generic, FromJSON, ToJSON) toImportDecl :: ImportSpec -> GHC.ImportDecl GHC.GhcPs -toImportDecl AddImport {..} = GHC.ImportDecl {..} +toImportDecl AddImport {..} = GHC.ImportDecl {ideclSource = ideclSource', ..} where + ideclSource' = if ideclSource then IsBoot else NotBoot toMod = GHC.noLoc . GHC.mkModuleName ideclName = toMod ideclNameString ideclPkgQual = Nothing diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index e8f4fe7f7a..7475853df9 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -36,6 +36,8 @@ extra-deps: - data-tree-print-0.1.0.2@rev:2 - floskell-0.10.4 - fourmolu-0.3.0.0 + - ghc-api-compat-8.6 + - ghc-check-0.5.0.4 - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 @@ -53,6 +55,7 @@ extra-deps: - stylish-haskell-0.12.2.0 - semigroups-0.18.5 - temporary-1.2.1.1 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 @@ -75,6 +78,10 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + # Until the formatters support ghc-lib-9, we need this flag disabled + hls-hlint-plugin: + hlint33: false nix: packages: [icu libcxx zlib] diff --git a/stack-8.10.3.yaml b/stack-8.10.3.yaml index 1ccef204bb..c3d2ffa67c 100644 --- a/stack-8.10.3.yaml +++ b/stack-8.10.3.yaml @@ -36,6 +36,8 @@ extra-deps: - data-tree-print-0.1.0.2@rev:2 - floskell-0.10.4 - fourmolu-0.3.0.0 + - ghc-api-compat-8.6 + - ghc-check-0.5.0.4 - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 @@ -50,6 +52,7 @@ extra-deps: - stylish-haskell-0.12.2.0 - semigroups-0.18.5 - temporary-1.2.1.1 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - lsp-1.2.0.0 @@ -75,6 +78,10 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + # Until the formatters support ghc-lib-9, we need this flag disabled + hls-hlint-plugin: + hlint33: false nix: packages: [ icu libcxx zlib ] diff --git a/stack-8.10.4.yaml b/stack-8.10.4.yaml index f0c55d6ccd..7c7f25ddeb 100644 --- a/stack-8.10.4.yaml +++ b/stack-8.10.4.yaml @@ -36,6 +36,9 @@ extra-deps: - data-tree-print-0.1.0.2@rev:2 - floskell-0.10.4 - fourmolu-0.3.0.0 + - ghc-api-compat-8.6 + - ghc-check-0.5.0.4 + - ghc-exactprint-0.6.4 - heapsize-0.3.0 - implicit-hie-cradle-0.3.0.2 - implicit-hie-0.1.2.5 @@ -45,6 +48,7 @@ extra-deps: - stylish-haskell-0.12.2.0 - semigroups-0.18.5 - temporary-1.2.1.1 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - lsp-1.2.0.0 @@ -57,6 +61,12 @@ extra-deps: - some-1.0.1@sha256:26e5bab7276f48b25ea8660d3fd1166c0f20fd497dac879a40f408e23211f93e,2055 - unliftio-core-0.2.0.1@sha256:9b3e44ea9aacacbfc35b3b54015af450091916ac3618a41868ebf6546977659a,1082 + # Enable these when supported by all formatters + # - ghc-lib-9.0.1.20210324@sha256:c8b9a2541ea3424c8d0e4f80584477d0f35be03f4a47d931152042d5f446c5fc,19279 + # - ghc-lib-parser-9.0.1.20210324@sha256:fb680f78d4ab08b5d089a05bda3b84ad857e5edcc2e4ca7c188c0207d369af80 + # - ghc-lib-parser-ex-9.0.0.4@sha256:8282b11c3797fc8ba225b245e736cc9a0745d9c48d0f9fea7f9bffb5c9997709,3642 + # - hlint-3.3@sha256:4218ad6e03050f5d68aeba0e025f5f05e366c8fd49657f2a19df04ee31b2bb23,4154 + configure-options: ghcide: - --disable-library-for-ghci @@ -70,6 +80,10 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + # Until the formatters support ghc-lib-9, we need this flag disabled + hls-hlint-plugin: + hlint33: false nix: packages: [ icu libcxx zlib ] diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index df8ab95055..57f52c0428 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -43,7 +43,8 @@ extra-deps: - floskell-0.10.4 - fourmolu-0.3.0.0 - fuzzy-0.1.0.0 - - ghc-check-0.5.0.1 + - ghc-api-compat-8.6 + - ghc-check-0.5.0.4 - ghc-events-0.13.0 - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 @@ -87,6 +88,7 @@ extra-deps: - topograph-1 - uniplate-1.6.13 - th-env-0.1.0.2@sha256:d8f1f37f42a8f1a22404d7d0579528af18f5dac7232cca6bdbd5117c115a0ad5,1370 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 @@ -106,6 +108,9 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + hls-hlint-plugin: + hlint33: false configure-options: ghcide: diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 182775c979..257d5c4274 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -28,6 +28,8 @@ packages: ghc-options: "$everything": -haddock + + extra-deps: - aeson-1.5.2.0 - apply-refact-0.9.3.0 @@ -42,7 +44,8 @@ extra-deps: - floskell-0.10.4 - fourmolu-0.3.0.0 - fuzzy-0.1.0.0 - - ghc-check-0.5.0.1 + - ghc-api-compat-8.6 + - ghc-check-0.5.0.4 - ghc-events-0.13.0 - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 @@ -86,6 +89,7 @@ extra-deps: - topograph-1 - uniplate-1.6.13 - th-env-0.1.0.2@sha256:d8f1f37f42a8f1a22404d7d0579528af18f5dac7232cca6bdbd5117c115a0ad5,1370 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 @@ -113,6 +117,9 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + hls-hlint-plugin: + hlint33: false nix: packages: [icu libcxx zlib] diff --git a/stack-8.8.2.yaml b/stack-8.8.2.yaml index bcd120419b..06f346efe1 100644 --- a/stack-8.8.2.yaml +++ b/stack-8.8.2.yaml @@ -38,7 +38,8 @@ extra-deps: - constrained-dynamic-0.1.0.0 - floskell-0.10.4 - fourmolu-0.3.0.0 - - ghc-check-0.5.0.1 + - ghc-api-compat-8.6 + - ghc-check-0.5.0.4 - ghc-events-0.13.0 - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 @@ -71,6 +72,7 @@ extra-deps: - these-1.1.1.1 - uniplate-1.6.13 - th-env-0.1.0.2@sha256:d8f1f37f42a8f1a22404d7d0579528af18f5dac7232cca6bdbd5117c115a0ad5,1370 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 @@ -99,6 +101,10 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + # Until the formatters support ghc-lib-9, we need this flag disabled + hls-hlint-plugin: + hlint33: false nix: packages: [icu libcxx zlib] diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index 8e11d433a2..8f706b0099 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -38,6 +38,8 @@ extra-deps: - constrained-dynamic-0.1.0.0 - floskell-0.10.4 - fourmolu-0.3.0.0 + - ghc-api-compat-8.6 + - ghc-check-0.5.0.4 - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 @@ -64,6 +66,7 @@ extra-deps: - stylish-haskell-0.12.2.0 - temporary-1.2.1.1 - uniplate-1.6.13 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 @@ -92,6 +95,10 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + # Until the formatters support ghc-lib-9, we need this flag disabled + hls-hlint-plugin: + hlint33: false nix: packages: [icu libcxx zlib] diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 14f788d6e8..1a0fe87220 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -38,6 +38,8 @@ extra-deps: - constrained-dynamic-0.1.0.0 - floskell-0.10.4 - fourmolu-0.3.0.0 + - ghc-api-compat-8.6 + - ghc-check-0.5.0.4 - ghc-exactprint-0.6.4 - ghc-lib-8.10.4.20210206 - ghc-lib-parser-8.10.4.20210206 @@ -62,6 +64,7 @@ extra-deps: - shake-0.19.4 - stylish-haskell-0.12.2.0 - temporary-1.2.1.1 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 @@ -89,6 +92,10 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + # Until the formatters support ghc-lib-9, we need this flag disabled + hls-hlint-plugin: + hlint33: false nix: packages: [icu libcxx zlib] diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml new file mode 100644 index 0000000000..452167ea1b --- /dev/null +++ b/stack-9.0.1.yaml @@ -0,0 +1,131 @@ +resolver: nightly-2021-05-02 +compiler: ghc-9.0.1 + +packages: + - . + - ./hie-compat + - ./hls-graph + - ./ghcide/ + - ./hls-plugin-api + - ./hls-test-utils + # - ./shake-bench + # - ./plugins/hls-class-plugin + - ./plugins/hls-haddock-comments-plugin + # - ./plugins/hls-eval-plugin + - ./plugins/hls-explicit-imports-plugin + # - ./plugins/hls-refine-imports-plugin + - ./plugins/hls-hlint-plugin + - ./plugins/hls-retrie-plugin + # - ./plugins/hls-splice-plugin + # - ./plugins/hls-tactics-plugin + # - ./plugins/hls-brittany-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 + +ghc-options: + "$everything": -haddock + +extra-deps: +- apply-refact-0.9.3.0 +- base16-bytestring-0.1.1.7@sha256:0021256a9628971c08da95cb8f4d0d72192f3bb8a7b30b55c080562d17c43dd3,2231 +- bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 +# Not newest (constraints-extras doesn't support 0.13 yet) +- constraints-0.12@sha256:71c7999d7fa01d8941f08d37d4c107c6b1bcbd0306e234157557b9b096b7f1be,2217 +- constraints-extras-0.3.1.0@sha256:12016ebb91ad5ed2c82bf7e48c6bd6947d164d33c9dca5ac3965de1bb6c780c0,1777 +- dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 +- dependent-sum-0.7.1.0@sha256:0e419237f5b86da3659772afff9cab355c0f8d5b3fdb15a5b30e673d8dc83941,2147 +- ghc-lib-9.0.1.20210324@sha256:c8b9a2541ea3424c8d0e4f80584477d0f35be03f4a47d931152042d5f446c5fc,19279 +- ghc-lib-parser-9.0.1.20210324@sha256:fb680f78d4ab08b5d089a05bda3b84ad857e5edcc2e4ca7c188c0207d369af80 +- ghc-lib-parser-ex-9.0.0.4@sha256:8282b11c3797fc8ba225b245e736cc9a0745d9c48d0f9fea7f9bffb5c9997709,3642 +- haddock-library-1.10.0@sha256:2a6c239da9225951a5d837e1ce373faeeae60d1345c78dd0a0b0f29df30c4fe9,4098 +- heapsize-0.3.0.1@sha256:0b69aa97a46d819b700ac7b145f3b5493c3565cf2c5b8298682238d405d0326e,1417 +- hlint-3.3@sha256:4218ad6e03050f5d68aeba0e025f5f05e366c8fd49657f2a19df04ee31b2bb23,4154 +- implicit-hie-0.1.2.5@sha256:517a98ef72f92f0a1617495222774fed3a751a64b0c06fbfc7b858d7aa5de279,2998 +- implicit-hie-cradle-0.3.0.2@sha256:7ad0d10c475ad2b45a068aa0c1b150078ec579746df3b1754d91820354c90696,2594 +- lens-5.0.1 +- profunctors-5.6.2 +- refinery-0.3.0.0@sha256:5ec9588de8f9752b2a947a87ca6a5a0156150ed7b0197975730c007c4549e7fb,1675 +- retrie-1.0.0.0 +- some-1.0.2@sha256:3d460998df32ad7b93bf55657aeae988d97070155e71718b4bc75d0997ce9d62,2244 + +# Upstream patches for ghc-9.0.1 compatability +# Same as in cabal.project +- github: jwaldmann/blaze-textual + commit: d8ee6cf80e27f9619d621c936bb4bda4b99a183f +# https://github.com/jwaldmann/blaze-textual/commit/d8ee6cf80e27f9619d621c936bb4bda4b99a183f +# https://github.com/bos/blaze-textual/issues/13 + +- github: mithrandi/czipwith + commit: b6245884ae83e00dd2b5261762549b37390179f8 +# https://github.com/lspitzner/czipwith/pull/2 + +- github: jneira/hie-bios + commit: 9b1445ab5efcabfad54043fc9b8e50e9d8c5bbf3 +# https://github.com/mpickering/hie-bios/pull/285 + +- github: hsyl20/ghc-api-compat + commit: 6178d75772c7d923918dfffa0b1f503dfb36d0a6 + +- github: anka-213/th-extras + commit: 57a97b4df128eb7b360e8ab9c5759392de8d1659 +# https://github.com/mokus0/th-extras/pull/8 +# https://github.com/mokus0/th-extras/issues/7 + +- github: anka-213/dependent-sum + commit: 8cf4c7fbc3bfa2be475a17bb7c94a1e1e9a830b5 + subdirs: + - dependent-sum-template +# https://github.com/obsidiansystems/dependent-sum/pull/57 + +- github: anka-213/HieDb + commit: a3f7521f6c5af1b977040cce09c8f7354f8984eb +# https://github.com/wz1000/HieDb/pull/31 + +- github: anka-213/lsp + commit: e96383ab19534128f12acc70a69fbc15d4f298cc + subdirs: + - lsp-types + - lsp + - lsp-test +# https://github.com/haskell/lsp/pull/312 + +- github: diagrams/active + commit: ca23431a8dfa013992f9164ccc882a3277361f17 +# https://github.com/diagrams/active/pull/36 + +configure-options: + ghcide: + - --disable-library-for-ghci + haskell-language-server: + - --disable-library-for-ghci + heapsize: + - --disable-library-for-ghci + +flags: + haskell-language-server: + pedantic: true + eval: false + class: false + splice: false + refineImports: false + tactic: false # Dependencies fail + + floskell: false + ormolu: false + fourmolu: false + stylishHaskell: false + brittany: false + retrie: + BuildExecutable: false + # Stack doesn't support automatic flags. + hls-hlint-plugin: + hlint33: true + +nix: + packages: [ icu libcxx zlib ] + +concurrent-tests: false diff --git a/stack.yaml b/stack.yaml index 3907d6700f..45f9d7393e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -36,6 +36,7 @@ extra-deps: - data-tree-print-0.1.0.2@rev:2 - floskell-0.10.4 - fourmolu-0.3.0.0 + - ghc-api-compat-8.6 - ghc-exactprint-0.6.4 - heapsize-0.3.0 - implicit-hie-cradle-0.3.0.2 @@ -46,6 +47,7 @@ extra-deps: - stylish-haskell-0.12.2.0 - semigroups-0.18.5 - temporary-1.2.1.1 + - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - hiedb-0.3.0.1 - lsp-1.2.0.0 @@ -71,6 +73,10 @@ flags: pedantic: true retrie: BuildExecutable: false + # Stack doesn't support automatic flags. + # Until the formatters support ghc-lib-9, we need this flag disabled + hls-hlint-plugin: + hlint33: false nix: packages: [ icu libcxx zlib ] diff --git a/test/functional/Command.hs b/test/functional/Command.hs index 871a2d82ba..d937879e8e 100644 --- a/test/functional/Command.hs +++ b/test/functional/Command.hs @@ -8,6 +8,7 @@ import Language.LSP.Types as LSP import Language.LSP.Types.Lens as LSP import Test.Hls import Test.Hls.Command +import Test.Hls.Flags (requiresEvalPlugin) tests :: TestTree tests = testGroup "commands" [ @@ -19,7 +20,7 @@ tests = testGroup "commands" [ liftIO $ do all f cmds @? "All prefixed" not (null cmds) @? "Commands aren't empty" - , testCase "get de-prefixed" $ + , requiresEvalPlugin $ testCase "get de-prefixed" $ runSession hlsCommand fullCaps "test/testdata/" $ do ResponseMessage _ _ (Left err) <- request SWorkspaceExecuteCommand diff --git a/test/functional/Format.hs b/test/functional/Format.hs index a579ed9a17..4620f4fdd8 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -13,14 +13,16 @@ import Language.LSP.Types import qualified Language.LSP.Types.Lens as LSP import Test.Hls import Test.Hls.Command +import Test.Hls.Flags (requiresFloskellPlugin, + requiresOrmoluPlugin) tests :: TestTree tests = testGroup "format document" [ - goldenGitDiff "works" "test/testdata/format/Format.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + requiresOrmoluPlugin $ goldenGitDiff "works" "test/testdata/format/Format.formatted_document.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc - , goldenGitDiff "works with custom tab size" "test/testdata/format/Format.formatted_document_with_tabsize.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + , requiresOrmoluPlugin $ goldenGitDiff "works with custom tab size" "test/testdata/format/Format.formatted_document_with_tabsize.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" formatDoc doc (FormattingOptions 5 True Nothing Nothing Nothing) BS.fromStrict . T.encodeUtf8 <$> documentContents doc @@ -29,7 +31,7 @@ tests = testGroup "format document" [ ] rangeTests :: TestTree -rangeTests = testGroup "format range" [ +rangeTests = requiresOrmoluPlugin $ testGroup "format range" [ goldenGitDiff "works" "test/testdata/format/Format.formatted_range.hs" $ runSession hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" formatRange doc (FormattingOptions 2 True Nothing Nothing Nothing) (Range (Position 5 0) (Position 7 10)) @@ -47,7 +49,7 @@ providerTests = testGroup "formatting provider" [ resp <- request STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) liftIO $ resp ^. LSP.result @?= Left (ResponseError InvalidRequest "No plugin enabled for STextDocumentFormatting, available: []" Nothing) - , testCase "can change on the fly" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + , requiresOrmoluPlugin . requiresFloskellPlugin $ testCase "can change on the fly" $ runSession hlsCommand fullCaps "test/testdata/format" $ do formattedOrmolu <- liftIO $ T.readFile "test/testdata/format/Format.ormolu.formatted.hs" formattedFloskell <- liftIO $ T.readFile "test/testdata/format/Format.floskell.formatted.hs" formattedOrmoluPostFloskell <- liftIO $ T.readFile "test/testdata/format/Format.ormolu_post_floskell.formatted.hs" @@ -65,7 +67,7 @@ providerTests = testGroup "formatting provider" [ sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) formatDoc doc (FormattingOptions 2 True Nothing Nothing Nothing) documentContents doc >>= liftIO . (@?= formattedOrmoluPostFloskell) - , testCase "supports both new and old configuration sections" $ runSession hlsCommand fullCaps "test/testdata/format" $ do + , requiresOrmoluPlugin . requiresFloskellPlugin $ testCase "supports both new and old configuration sections" $ runSession hlsCommand fullCaps "test/testdata/format" $ do formattedOrmolu <- liftIO $ T.readFile "test/testdata/format/Format.ormolu.formatted.hs" formattedFloskell <- liftIO $ T.readFile "test/testdata/format/Format.floskell.formatted.hs" diff --git a/test/functional/Progress.hs b/test/functional/Progress.hs index e35e83da41..a4b9ac4fa1 100644 --- a/test/functional/Progress.hs +++ b/test/functional/Progress.hs @@ -19,6 +19,7 @@ import qualified Language.LSP.Types.Lens as L import System.FilePath (()) import Test.Hls import Test.Hls.Command +import Test.Hls.Flags tests :: TestTree tests = @@ -29,7 +30,7 @@ tests = let path = "hlint" "ApplyRefact2.hs" _ <- openDoc path "haskell" expectProgressReports [pack ("Setting up hlint (for " ++ path ++ ")"), "Processing", "Indexing"] - , testCase "eval plugin sends progress reports" $ + , requiresEvalPlugin $ testCase "eval plugin sends progress reports" $ runSession hlsCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do doc <- openDoc "T1.hs" "haskell" expectProgressReports ["Setting up testdata (for T1.hs)", "Processing", "Indexing"] @@ -37,14 +38,14 @@ tests = let cmd = evalLens ^?! L.command . _Just _ <- sendRequest SWorkspaceExecuteCommand $ ExecuteCommandParams Nothing (cmd ^. L.command) (decode $ encode $ fromJust $ cmd ^. L.arguments) expectProgressReports ["Evaluating"] - , testCase "ormolu plugin sends progress notifications" $ do + , requiresOrmoluPlugin $ testCase "ormolu plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata/format" $ do sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) doc <- openDoc "Format.hs" "haskell" expectProgressReports ["Setting up testdata (for Format.hs)", "Processing", "Indexing"] _ <- sendRequest STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) expectProgressReports ["Formatting Format.hs"] - , testCase "fourmolu plugin sends progress notifications" $ do + , requiresFourmoluPlugin $ testCase "fourmolu plugin sends progress notifications" $ do runSession hlsCommand progressCaps "test/testdata/format" $ do sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "fourmolu")) doc <- openDoc "Format.hs" "haskell" diff --git a/test/utils/Test/Hls/Flags.hs b/test/utils/Test/Hls/Flags.hs new file mode 100644 index 0000000000..84ff263f76 --- /dev/null +++ b/test/utils/Test/Hls/Flags.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +-- | Module for disabling tests if their plugins are disabled +module Test.Hls.Flags where + +import Test.Hls (TestTree, ignoreTestBecause) + +-- * Plugin dependent tests + +-- | Disable test unless the class flag is set +requiresClassPlugin :: TestTree -> TestTree +#if class +requiresClassPlugin = id +#else +requiresClassPlugin = ignoreTestBecause "Class plugin disabled" +#endif + +-- | Disable test unless the haddockComments flag is set +requiresHaddockCommentsPlugin :: TestTree -> TestTree +#if haddockComments +requiresHaddockCommentsPlugin = id +#else +requiresHaddockCommentsPlugin = ignoreTestBecause "HaddockComments plugin disabled" +#endif + +-- | Disable test unless the eval flag is set +requiresEvalPlugin :: TestTree -> TestTree +#if eval +requiresEvalPlugin = id +#else +requiresEvalPlugin = ignoreTestBecause "Eval plugin disabled" +#endif + +-- | Disable test unless the importLens flag is set +requiresImportLensPlugin :: TestTree -> TestTree +#if importLens +requiresImportLensPlugin = id +#else +requiresImportLensPlugin = ignoreTestBecause "ImportLens plugin disabled" +#endif + +-- | Disable test unless the retrie flag is set +requiresRetriePlugin :: TestTree -> TestTree +#if retrie +requiresRetriePlugin = id +#else +requiresRetriePlugin = ignoreTestBecause "Retrie plugin disabled" +#endif + +-- | Disable test unless the tactic flag is set +requiresTacticPlugin :: TestTree -> TestTree +#if tactic +requiresTacticPlugin = id +#else +requiresTacticPlugin = ignoreTestBecause "Tactic plugin disabled" +#endif + +-- | Disable test unless the hlint flag is set +requiresHlintPlugin :: TestTree -> TestTree +#if hlint +requiresHlintPlugin = id +#else +requiresHlintPlugin = ignoreTestBecause "Hlint plugin disabled" +#endif + +-- | Disable test unless the moduleName flag is set +requiresModuleNamePlugin :: TestTree -> TestTree +#if moduleName +requiresModuleNamePlugin = id +#else +requiresModuleNamePlugin = ignoreTestBecause "ModuleName plugin disabled" +#endif + +-- | Disable test unless the pragmas flag is set +requiresPragmasPlugin :: TestTree -> TestTree +#if pragmas +requiresPragmasPlugin = id +#else +requiresPragmasPlugin = ignoreTestBecause "Pragmas plugin disabled" +#endif + +-- | Disable test unless the splice flag is set +requiresSplicePlugin :: TestTree -> TestTree +#if splice +requiresSplicePlugin = id +#else +requiresSplicePlugin = ignoreTestBecause "Splice plugin disabled" +#endif + + +-- * Formatters +-- | Disable test unless the floskell flag is set +requiresFloskellPlugin :: TestTree -> TestTree +#if floskell +requiresFloskellPlugin = id +#else +requiresFloskellPlugin = ignoreTestBecause "Floskell plugin disabled" +#endif + +-- | Disable test unless the fourmolu flag is set +requiresFourmoluPlugin :: TestTree -> TestTree +#if fourmolu +requiresFourmoluPlugin = id +#else +requiresFourmoluPlugin = ignoreTestBecause "Fourmolu plugin disabled" +#endif + +-- | Disable test unless the ormolu flag is set +requiresOrmoluPlugin :: TestTree -> TestTree +#if ormolu +requiresOrmoluPlugin = id +#else +requiresOrmoluPlugin = ignoreTestBecause "Ormolu plugin disabled" +#endif + +-- | Disable test unless the stylishHaskell flag is set +requiresStylishHaskellPlugin :: TestTree -> TestTree +#if stylishHaskell +requiresStylishHaskellPlugin = id +#else +requiresStylishHaskellPlugin = ignoreTestBecause "StylishHaskell plugin disabled" +#endif + +-- | Disable test unless the brittany flag is set +requiresBrittanyPlugin :: TestTree -> TestTree +#if brittany +requiresBrittanyPlugin = id +#else +requiresBrittanyPlugin = ignoreTestBecause "Brittany plugin disabled" +#endif +