diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index c96ae6ee42..c2b1d7e87a 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -178,7 +178,7 @@ jobs: 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 && matrix.ghc }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} 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" @@ -186,7 +186,7 @@ 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 && matrix.ghc != '9.0.1' }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} 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" @@ -206,7 +206,7 @@ jobs: 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 && matrix.ghc != '9.0.1' }} + - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test }} 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 index 4ef97612d0..34331958de 100644 --- a/cabal-ghc901.project +++ b/cabal-ghc901.project @@ -6,19 +6,19 @@ packages: ./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-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-refine-imports-plugin ./plugins/hls-hlint-plugin ./plugins/hls-rename-plugin ./plugins/hls-retrie-plugin ./plugins/hls-haddock-comments-plugin - -- ./plugins/hls-splice-plugin + ./plugins/hls-splice-plugin ./plugins/hls-floskell-plugin ./plugins/hls-pragmas-plugin ./plugins/hls-module-name-plugin @@ -48,10 +48,10 @@ source-repository-package source-repository-package type: git - location: https://github.com/anka-213/dependent-sum - tag: 8cf4c7fbc3bfa2be475a17bb7c94a1e1e9a830b5 + location: https://github.com/fendor/dependent-sum + tag: 5de03c38b0de4945f4e9bce1b026110e69dc8118 subdir: dependent-sum-template --- https://github.com/obsidiansystems/dependent-sum/pull/57 +-- https://github.com/obsidiansystems/dependent-sum/pull/59 -- benchmark dependency source-repository-package @@ -64,8 +64,8 @@ write-ghc-environment-files: never index-state: 2021-09-06T12:12:22Z constraints: - -- These plugins doesn't work on GHC9 yet - haskell-language-server -brittany -class -fourmolu -splice -stylishhaskell -tactic -refineImports + -- These plugins don't work on GHC9 yet + haskell-language-server -brittany -class -fourmolu -stylishhaskell -tactic allow-newer: floskell:base, diff --git a/cabal-ghc921.project b/cabal-ghc921.project new file mode 100644 index 0000000000..10f24917de --- /dev/null +++ b/cabal-ghc921.project @@ -0,0 +1,275 @@ +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 + ./plugins/hls-call-hierarchy-plugin + +tests: true + +package * + ghc-options: -haddock + test-show-details: direct + +source-repository-package + type: git + location: https://github.com/mithrandi/czipwith.git + tag: b6245884ae83e00dd2b5261762549b37390179f8 + -- https://github.com/lspitzner/czipwith/pull/2 + +-- benchmark dependency +source-repository-package + type: git + location: https://github.com/HeinrichApfelmus/operational + tag: 16e19aaf34e286f3d27b3988c61040823ec66537 + +-- Head of hiedb +source-repository-package + type: git + location: https://github.com/wz1000/HieDb + tag: 45c4671db2da8ce5cd11e964573846cfbf3bbec8 + +-- GHC 9.2 for ghc-check +source-repository-package + type: git + location: https://github.com/fendor/ghc-check + tag: 224f3901eaa1b32a27e097968afd4a3894efa77e + -- https://github.com/pepeiborra/ghc-check/pull/14/files + +write-ghc-environment-files: never + +index-state: 2021-08-31T02:21:16Z + +constraints: + -- These plugins doesn't work on GHC9 yet + haskell-language-server -brittany -class -fourmolu -splice -stylishhaskell -tactic -refineImports -callhierarchy -retrie + + +allow-newer: + Cabal, + base, + binary, + bytestring, + ghc, + ghc-bignum, + ghc-prim, + integer-gmp, + template-haskell, + text, + time, + + diagrams-postscript:lens, + diagrams-postscript:diagrams-core, + diagrams-postscript:monoid-extras, + dependent-sum:some, + dependent-sum:constraints, + diagrams:diagrams-core, + Chart-diagrams:diagrams-core, + SVGFonts:diagrams-core + +constraints: + Agda ==2.6.1.3, + Diff ==0.4.0, + EdisonAPI ==1.3.1, + EdisonCore ==1.3.2.1, + FPretty ==1.1, + HTTP ==4000.3.16, + HUnit ==1.6.2.0, + QuickCheck ==2.14.2, + Spock-core ==0.14.0.0, + aeson ==1.5.6.0, + aivika ==5.9.1, + aivika-transformers ==5.9.1, + alex ==3.2.6, + ansi-pretty ==0.1.2.2, + arith-encode ==1.0.2, + async ==2.2.3, + async-pool ==0.9.1, + attoparsec ==0.13.2.5 || ==0.14.1, + barbies-th ==0.1.8, + base-compat ==0.11.2, + base-compat-batteries ==0.11.2, + base16-bytestring ==1.0.1.0, + basement ==0.0.12, + bits ==0.5.3, + blaze-builder ==0.4.2.1, + blaze-textual ==0.2.1.0, + boomerang ==1.4.7, + bound ==2.0.3, + box-tuples ==0.2.0.4, + byteslice ==0.2.5.2, + bytesmith ==0.3.7.0, + bytestring-strict-builder ==0.4.5.4, + cabal-doctest ==1.0.8, + cantor-pairing ==0.2.0.1, + cassava ==0.5.2.0, + cborg ==0.2.5.0, + cereal ==0.5.8.1, + charset ==0.3.8, + chaselev-deque ==0.5.0.5, + classy-prelude ==1.5.0, + combinat ==0.2.10.0, + commonmark-extensions ==0.2.1.2, + conduit ==1.3.4.1, + constraints ==0.13, + constraints-extras ==0.3.1.0, + cql ==4.0.3, + critbit ==0.2.0.0, + cryptonite ==0.29, + data-default-instances-new-base ==0.0.2, + data-dword ==0.3.2, + data-r-tree ==0.6.0, + datetime ==0.3.1, + deferred-folds ==0.9.17, + dependent-sum-template ==0.1.0.3, + deriving-compat ==0.5.10, + diagrams-lib ==1.4.4, + doctest ==0.18.1, + dom-lt ==0.2.2.1, + drinkery ==0.4, + edit-distance ==0.2.2.1, + emacs-module ==0.1.1, + endo ==0.3.0.1, + entropy ==0.4.1.6, + enumeration ==0.2.0, + extra ==1.7.9, + fgl ==5.7.0.3, + filepattern ==0.1.2, + focus ==1.0.2, + free-algebras ==0.1.0.1, + free-functors ==1.2.1, + generic-data ==0.9.2.0, + generic-deriving ==1.14, + generic-lens ==2.2.0.0, + generic-lens-core ==2.2.0.0, + generic-optics ==2.2.0.0, + generics-sop ==0.5.1.1, + geniplate-mirror ==0.7.8, + ghc-events ==0.17.0, + happy ==1.20.0, + hashtables ==1.2.4.1, + haskeline ==0.7.5.0, + haskell-src-exts ==1.23.1, + haskell-src-meta ==0.8.7, + haxl ==2.3.0.0, + heterocephalus ==1.0.5.4, + hgeometry ==0.12.0.4, + hgeometry-ipe ==0.12.0.0, + hscolour ==1.24.4, + hslogger ==1.3.1.0, + hspec-core ==2.8.3, + hspec-discover ==2.8.3, + hspec-expectations ==0.8.2, + hspec-meta ==2.7.8, + hspec-wai ==0.11.1, + http-types ==0.12.3, + http2 ==3.0.2, + hvect ==0.4.0.0, + hxt ==9.3.1.22, + inj-base ==0.2.0.0, + inspection-testing ==0.4.6.0, + invariant ==0.5.4, + io-choice ==0.0.7, + iproute ==1.7.11, + language-c ==0.9.0.1, + language-haskell-extract ==0.2.4, + language-javascript ==0.7.1.0, + lens ==5.0.1, + lens-family-th ==0.5.2.0, + list-t ==1.0.4, + lockfree-queue ==0.2.3.1, + memory ==0.16.0, + microlens-ghc ==0.4.13, + monad-validate ==1.2.0.0, + monadplus ==1.4.2, + mono-traversable ==1.0.15.1, + mono-traversable-keys ==0.1.0, + mustache ==2.3.1, + network ==3.1.2.2, + newtype-generics ==0.6, + obdd ==0.8.2, + optics-th ==0.4, + packman ==0.5.0, + pandoc ==2.14.2, + parameterized-utils ==2.1.3.0, + partial-isomorphisms ==0.2.2.1, + pem ==0.2.4, + persistent ==2.13.0.3 || ==2.13.1.1, + plots ==0.1.1.2, + pointed ==5.0.2, + posix-api ==0.3.5.0, + primitive-extras ==0.10.1.1, + primitive-sort ==0.1.0.0, + primitive-unlifted ==0.1.3.0, + proto3-wire ==1.2.2, + quickcheck-instances ==0.3.25.2, + random ==1.2.0, + relude ==1.0.0.1, + row-types ==1.0.1.0, + safe ==0.3.19, + safecopy ==0.10.4.2, + salak ==0.3.6, + securemem ==0.1.10, + semialign ==1.2, + semigroupoids ==5.3.5, + serialise ==0.2.3.0, + servant ==0.18.3, + shake ==0.19.5, + shakespeare ==2.0.25, + singletons ==3.0, + singletons-base ==3.0, + siphash ==1.0.3, + snap-core ==1.0.4.2, + streaming-commons ==0.2.2.1, + streamly ==0.8.0, + subcategories ==0.1.1.0, + test-framework ==0.8.2.0, + text-format ==0.3.2, + text-short ==0.1.3, + text-show ==3.9, + th-desugar ==1.12, + th-extras ==0.0.0.4, + threads ==0.5.1.6, + tls ==1.5.5, + tpdb ==2.2.0, + tree-diff ==0.2, + true-name ==0.1.0.3, + uniplate ==1.6.13, + unordered-containers ==0.2.14.0, + validity ==0.11.0.1, + vector-builder ==0.3.8.2, + vector-circular ==0.1.3, + vector-th-unbox ==0.2.1.9, + vinyl ==0.13.3, + vty ==5.33, + wai-app-static ==3.1.7.2, + wai-extra ==3.1.6, + wai-middleware-static ==0.9.0, + warp ==3.3.17, + winery ==1.3.2, + witherable ==0.4.1, + x509 ==1.7.5, + x509-validation ==1.6.11, + xlsx ==0.8.4, + xml-hamlet ==0.5.0.1, + yaml ==0.11.5.0, + yesod-core ==1.6.21.0 diff --git a/configuration-ghc-901.nix b/configuration-ghc-901.nix index 79a04cf0ac..f10724f125 100644 --- a/configuration-ghc-901.nix +++ b/configuration-ghc-901.nix @@ -7,9 +7,7 @@ let "hls-brittany-plugin" "hls-stylish-haskell-plugin" "hls-fourmolu-plugin" - "hls-splice-plugin" "hls-class-plugin" - "hls-refine-imports-plugin" ]; hpkgsOverride = hself: hsuper: @@ -23,23 +21,10 @@ let }; in { - # we need add ghc-api-compat to build depends, - # since its condition tree is not evaluated under ghc 9 - - ghc-api-compat = hself.callHackageDirect { - pkg = "ghc-api-compat"; - ver = "9.0.1"; - sha256 = "WCK1gu6iiCAc2s2rFEqn2CkvHkITPrmDjuiGsWOWerM="; - } {}; - - hiedb = addBuildDepend hsuper.hiedb hself.ghc-api-compat; - blaze-textual = hself.callCabal2nix "blaze-textual" - (pkgs.fetchFromGitHub { - owner = "jwaldmann"; - repo = "blaze-textual"; - rev = "d8ee6cf80e27f9619d621c936bb4bda4b99a183f"; - sha256 = "C0dIzf64fBaY8mlhMm1kCQC5Jc1wKBtNO2Y24k7YPUw="; + (builtins.fetchTarball { + url = "https://hackage.haskell.org/package/blaze-textual-0.2.2.1/blaze-textual-0.2.2.1.tar.gz"; + sha256 = "1nyhc9mrnxsl21ksnpp0ryki4wgk49r581yy504g2gjq6x3bkb59"; }) { }; czipwith = hself.callCabal2nix "czipwith" (pkgs.fetchFromGitHub { @@ -49,12 +34,11 @@ let sha256 = "2uSoGyrxT/OstRcpx55kwP4JwjPbWLxD72LajeyQV0E="; }) { }; - hie-bios = hself.callCabal2nix "hie-bios" (pkgs.fetchFromGitHub { - owner = "jneira"; - repo = "hie-bios"; - rev = "9b1445ab5efcabfad54043fc9b8e50e9d8c5bbf3"; - sha256 = "8ct7t3xIxIAoC+f8VO5e5+QKrd5L5Zu1eButSaE+1Uk="; - }) { }; + hie-bios = hself.callCabal2nix "hie-bios" + (builtins.fetchTarball { + url = "https://hackage.haskell.org/package/hie-bios-0.7.6/hie-bios-0.7.6.tar.gz"; + sha256 = "0w4rhy4b3jnci9m27l79c8n28wl56x49bmhdn7pvf88mx9srjcvq"; + }) { }; th-extras = hself.callCabal2nix "th-extras" (pkgs.fetchFromGitHub { owner = "anka-213"; @@ -100,10 +84,8 @@ let "-f-brittany" "-f-class" "-f-fourmolu" - "-f-splice" "-f-stylishhaskell" "-f-tactic" - "-f-refineImports" ]) { }; # YOLO diff --git a/flake.nix b/flake.nix index d5dc999ed1..5104b4ae33 100644 --- a/flake.nix +++ b/flake.nix @@ -70,12 +70,11 @@ # Don't use `callHackage`, it requires us to override `all-cabal-hashes` tweaks = hself: hsuper: with haskell.lib; { - - ghc-api-compat = hself.callHackageDirect { - pkg = "ghc-api-compat"; - ver = "8.10.7"; - sha256 = "g9/InDeQfiXCB9SK8mpl/8B5QEEobj9uqo4xe//telw="; - } {}; + hiedb = hself.callCabal2nix "hiedb" + (builtins.fetchTarball { + url = "https://hackage.haskell.org/package/hiedb-0.4.1.0/hiedb-0.4.1.0.tar.gz"; + sha256 = "11s7lfkd6fc3zf3kgyp3jhicbhxpn6jp0yjahl8d28hicwr2qdpi"; + }) { }; lsp = hself.lsp_1_2_0_1; diff --git a/ghcide/.ghci b/ghcide/.ghci deleted file mode 100644 index 8eb094939e..0000000000 --- a/ghcide/.ghci +++ /dev/null @@ -1,29 +0,0 @@ -:set -Wunused-binds -Wunused-imports -Worphans -Wunused-matches -Wincomplete-patterns - -:set -XBangPatterns -:set -XDeriveFunctor -:set -XDeriveGeneric -:set -XGeneralizedNewtypeDeriving -:set -XLambdaCase -:set -XNamedFieldPuns -:set -XOverloadedStrings -:set -XRecordWildCards -:set -XScopedTypeVariables -:set -XStandaloneDeriving -:set -XTupleSections -:set -XTypeApplications -:set -XViewPatterns - -:set -package=ghc -:set -ignore-package=ghc-lib-parser -:set -DGHC_STABLE -:set -Iinclude -:set -idist/build/autogen -:set -isrc -:set -isession-loader -:set -iexe - -:set -isrc-ghc88 -:set -idist-newstyle/build/x86_64-osx/ghc-8.8.3/ghcide-0.2.0/build/autogen - -:load Main diff --git a/ghcide/.gitignore b/ghcide/.gitignore index e6abe0e03c..3544e898b0 100644 --- a/ghcide/.gitignore +++ b/ghcide/.gitignore @@ -7,7 +7,9 @@ cabal.project.local /.tasty-rerun-log .vscode /.hlint-* -bench/example/ +bench/example/* +# don't ignore the example file, we need it! +!bench/example/HLS bench-results/ bench-temp/ .shake/ diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml index 2bb82f5a5a..725604f7df 100644 --- a/ghcide/.hlint.yaml +++ b/ghcide/.hlint.yaml @@ -94,6 +94,16 @@ - Development.IDE.Core.Rules - Development.IDE.Core.Tracing - Development.IDE.GHC.Compat + - Development.IDE.GHC.Compat.Core + - Development.IDE.GHC.Compat.Env + - Development.IDE.GHC.Compat.Iface + - Development.IDE.GHC.Compat.Logger + - Development.IDE.GHC.Compat.Outputable + - Development.IDE.GHC.Compat.Parser + - Development.IDE.GHC.Compat.Plugins + - Development.IDE.GHC.Compat.Units + - Development.IDE.GHC.Compat.Util + - Development.IDE.GHC.CPP - Development.IDE.GHC.ExactPrint - Development.IDE.GHC.Orphans - Development.IDE.GHC.Util @@ -112,7 +122,8 @@ - flags: - default: false - {name: [-Wno-missing-signatures, -Wno-orphans, -Wno-overlapping-patterns, -Wno-incomplete-patterns, -Wno-missing-fields, -Wno-unused-matches]} - - {name: [-Wno-dodgy-imports,-Wno-incomplete-uni-patterns], within: [Main, Development.IDE.GHC.Compat, Development.Benchmark.Rules]} + - {name: [-Wno-dodgy-imports,-Wno-incomplete-uni-patterns], within: [Main, Development.IDE.GHC.Compat, Development.IDE.GHC.Compat.Core, Development.Benchmark.Rules]} + - {name: [-Wno-unused-imports], within: [Development.IDE.GHC.Compat.Core]} - {name: [-Wno-deprecations, -Wno-unticked-promoted-constructors], within: [Main, Experiments]} # - modules: # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' diff --git a/ghcide/bench/example/HLS b/ghcide/bench/example/HLS deleted file mode 120000 index a8a4f8c212..0000000000 --- a/ghcide/bench/example/HLS +++ /dev/null @@ -1 +0,0 @@ -../../.. \ No newline at end of file diff --git a/ghcide/bench/example/HLS b/ghcide/bench/example/HLS new file mode 100644 index 0000000000..f95f775b78 --- /dev/null +++ b/ghcide/bench/example/HLS @@ -0,0 +1 @@ +../../.. diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 5a1dca79ef..66cc4166ab 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -61,7 +61,7 @@ library hie-compat ^>= 0.2.0.0, hls-plugin-api ^>= 1.2.0.0, lens, - hiedb == 0.4.0.*, + hiedb == 0.4.1.*, lsp-types >= 1.3.0.1 && < 1.4, lsp == 1.2.*, mtl, @@ -110,22 +110,6 @@ library build-depends: unix - if impl(ghc < 8.10.5) - build-depends: - ghc-api-compat ==8.6 - elif impl(ghc == 8.10.5) - build-depends: - ghc-api-compat ==8.10.5 - elif impl(ghc == 8.10.6) - build-depends: - ghc-api-compat ==8.10.6 - elif impl(ghc == 8.10.7) - build-depends: - ghc-api-compat ==8.10.7 - elif impl(ghc == 9.0.1) - build-depends: - ghc-api-compat ==9.0.1 - default-extensions: ApplicativeDo BangPatterns @@ -171,6 +155,15 @@ library Development.IDE.Core.Tracing Development.IDE.Core.UseStale Development.IDE.GHC.Compat + Development.IDE.GHC.Compat.Core + Development.IDE.GHC.Compat.Env + Development.IDE.GHC.Compat.Iface + Development.IDE.GHC.Compat.Logger + Development.IDE.GHC.Compat.Outputable + Development.IDE.GHC.Compat.Parser + Development.IDE.GHC.Compat.Plugins + Development.IDE.GHC.Compat.Units + Development.IDE.GHC.Compat.Util Development.IDE.Core.Compile Development.IDE.GHC.Error Development.IDE.GHC.ExactPrint @@ -220,6 +213,10 @@ library if flag(ghc-patched-unboxed-bytecode) cpp-options: -DGHC_PATCHED_UNBOXED_BYTECODE + if impl(ghc < 8.10) + exposed-modules: + Development.IDE.GHC.Compat.CPP + executable ghcide-test-preprocessor default-language: Haskell2010 hs-source-dirs: test/preprocessor diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index b769ed916a..edc31ed5fe 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -19,7 +19,7 @@ module Development.IDE.Session import Control.Concurrent.Async import Control.Concurrent.Strict -import Control.Exception.Safe +import Control.Exception.Safe as Safe import Control.Monad import Control.Monad.Extra import Control.Monad.IO.Class @@ -42,9 +42,13 @@ import Data.Time.Clock import Data.Version import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat hiding (Target, - TargetFile, TargetModule) -import qualified Development.IDE.GHC.Compat as GHC +import qualified Development.IDE.GHC.Compat as Compat +import Development.IDE.GHC.Compat.Core hiding (Target, + TargetFile, TargetModule, + Var) +import qualified Development.IDE.GHC.Compat.Core as GHC +import Development.IDE.GHC.Compat.Env hiding (Logger) +import Development.IDE.GHC.Compat.Units (UnitId) import Development.IDE.GHC.Util import Development.IDE.Graph (Action) import Development.IDE.Session.VersionCheck @@ -71,12 +75,6 @@ import System.Info import Control.Applicative (Alternative ((<|>))) import Control.Exception (evaluate) import Data.Void -import GHCi -import HscTypes (hsc_IC, hsc_NC, - hsc_dflags, ic_dflags) -import Linker -import Module -import NameCache import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TQueue @@ -105,7 +103,7 @@ data SessionLoadingOptions = SessionLoadingOptions , getCacheDirs :: String -> [String] -> IO CacheDirs -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags' , getInitialGhcLibDir :: FilePath -> IO (Maybe LibDir) - , fakeUid :: GHC.InstalledUnitId + , fakeUid :: UnitId -- ^ 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 @@ -118,7 +116,7 @@ instance Default SessionLoadingOptions where ,loadCradle = loadWithImplicitCradle ,getCacheDirs = getCacheDirsDefault ,getInitialGhcLibDir = getInitialGhcLibDirDefault - ,fakeUid = GHC.toInstalledUnitId (GHC.stringToUnit "main") + ,fakeUid = Compat.toUnitId (Compat.stringToUnit "main") } -- | Find the cradle for a given 'hie.yaml' configuration. @@ -173,7 +171,7 @@ runWithDb :: FilePath -> (HieDb -> IndexQueue -> IO ()) -> IO () runWithDb fp k = do -- Delete the database if it has an incompatible schema version withHieDb fp (const $ pure ()) - `catch` \IncompatibleSchemaVersion{} -> removeFile fp + `Safe.catch` \IncompatibleSchemaVersion{} -> removeFile fp withHieDb fp $ \writedb -> do initConn writedb chan <- newTQueueIO @@ -187,15 +185,15 @@ runWithDb fp k = do forever $ do k <- atomically $ readTQueue chan k db - `catch` \e@SQLError{} -> do + `Safe.catch` \e@SQLError{} -> do hPutStrLn stderr $ "SQLite error in worker, ignoring: " ++ show e - `catchAny` \e -> do + `Safe.catchAny` \e -> do hPutStrLn stderr $ "Uncaught error in database worker, ignoring: " ++ show e getHieDbLoc :: FilePath -> IO FilePath getHieDbLoc dir = do - let db = intercalate "-" [dirHash, takeBaseName dir, ghcVersionStr, hiedbDataVersion] <.> "hiedb" + let db = intercalate "-" [dirHash, takeBaseName dir, Compat.ghcVersionStr, hiedbDataVersion] <.> "hiedb" dirHash = B.unpack $ B16.encode $ H.hash $ B.pack dir cDir <- IO.getXdgDirectory IO.XdgCache cacheDir createDirectoryIfMissing True cDir @@ -297,7 +295,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do -- We will modify the unitId and DynFlags used for -- compilation but these are the true source of -- information. - new_deps = RawComponentInfo (thisInstalledUnitId df) df targets cfp opts dep_info + new_deps = RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info : maybe [] snd oldDeps -- Get all the unit-ids for things in this component inplace = map rawComponentUnitId new_deps @@ -482,7 +480,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do ncfp <- toNormalizedFilePath' <$> canonicalizePath file cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap hieYaml <- cradleLoc file - sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `catch` \e -> + sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e -> return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml) returnWithVersion $ \file -> do @@ -522,11 +520,11 @@ cradleToOptsAndLibDir cradle file = do emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv emptyHscEnv nc libDir = do env <- runGhc (Just libDir) getSession - when (ghcVersion < GHC90) $ + when (Compat.ghcVersion < Compat.GHC90) $ -- This causes ghc9 to crash with the error: -- Couldn't find a target code interpreter. Try with -fexternal-interpreter initDynLinker env - pure $ setNameCache nc env{ hsc_dflags = (hsc_dflags env){useUnicode = True } } + pure $ setNameCache nc (hscSetFlags ((hsc_dflags env){useUnicode = True }) env) data TargetDetails = TargetDetails { @@ -571,13 +569,13 @@ newComponentCache -> Maybe FilePath -- Path to cradle -> NormalizedFilePath -- Path to file that caused the creation of this component -> HscEnv - -> [(InstalledUnitId, DynFlags)] + -> [(UnitId, DynFlags)] -> ComponentInfo -> IO ( [TargetDetails], (IdeResult HscEnvEq, DependencyInfo)) newComponentCache logger exts cradlePath cfp hsc_env uids ci = do let df = componentDynFlags ci - let hscEnv' = hsc_env { hsc_dflags = df - , hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } + let hscEnv' = hscSetFlags df hsc_env + { hsc_IC = (hsc_IC hsc_env) { ic_dflags = df } } let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath henv <- newFunc hscEnv' uids @@ -676,7 +674,7 @@ type FilesMap = HM.HashMap NormalizedFilePath (Maybe FilePath) -- This is pristine information about a component data RawComponentInfo = RawComponentInfo - { rawComponentUnitId :: InstalledUnitId + { rawComponentUnitId :: UnitId -- | Unprocessed DynFlags. Contains inplace packages such as libraries. -- We do not want to use them unprocessed. , rawComponentDynFlags :: DynFlags @@ -693,14 +691,14 @@ data RawComponentInfo = RawComponentInfo -- This is processed information about the component, in particular the dynflags will be modified. data ComponentInfo = ComponentInfo - { componentUnitId :: InstalledUnitId + { componentUnitId :: UnitId -- | Processed DynFlags. Does not contain inplace packages such as local -- libraries. Can be used to actually load this Component. , componentDynFlags :: DynFlags -- | Internal units, such as local libraries, that this component -- is loaded with. These have been extracted from the original -- ComponentOptions. - , _componentInternalUnits :: [InstalledUnitId] + , _componentInternalUnits :: [UnitId] -- | All targets of this components. , componentTargets :: [GHC.Target] -- | Filepath which caused the creation of this component @@ -733,7 +731,7 @@ getDependencyInfo fs = Map.fromList <$> mapM do_one fs where tryIO :: IO a -> IO (Either IOException a) - tryIO = try + tryIO = Safe.try do_one :: FilePath -> IO (FilePath, Maybe UTCTime) do_one fp = (fp,) . eitherToMaybe <$> tryIO (getModificationTime fp) @@ -747,18 +745,14 @@ getDependencyInfo fs = Map.fromList <$> mapM do_one fs -- tcRnImports) which assume that all modules in the HPT have the same unit -- ID. Therefore we create a fake one and give them all the same unit id. removeInplacePackages - :: InstalledUnitId -- ^ fake uid to use for our internal component - -> [InstalledUnitId] + :: UnitId -- ^ fake uid to use for our internal component + -> [UnitId] -> DynFlags - -> (DynFlags, [InstalledUnitId]) -removeInplacePackages fake_uid us df = (setThisInstalledUnitId fake_uid $ + -> (DynFlags, [UnitId]) +removeInplacePackages fake_uid us df = (setHomeUnitId_ fake_uid $ df { packageFlags = ps }, uids) where - (uids, ps) = partitionEithers (map go (packageFlags df)) - go p@(ExposePackage _ (UnitIdArg u) _) = if GHC.toInstalledUnitId u `elem` us - then Left (GHC.toInstalledUnitId u) - else Right p - go p = Right p + (uids, ps) = Compat.filterInplaceUnits us (packageFlags df) -- | Memoize an IO function, with the characteristics: -- @@ -790,25 +784,16 @@ setOptions (ComponentOptions theOpts compRoot _) dflags = do -- also, it can confuse the interface stale check dontWriteHieFiles $ setIgnoreInterfacePragmas $ - setLinkerOptions $ + setBytecodeLinkerOptions $ disableOptimisation $ - setUpTypedHoles $ + Compat.setUpTypedHoles $ makeDynFlagsAbsolute compRoot dflags' -- 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 $ initUnits dflags'' - return (final_df, targets) - --- we don't want to generate object code so we compile to bytecode --- (HscInterpreted) which implies LinkInMemory --- HscInterpreted -setLinkerOptions :: DynFlags -> DynFlags -setLinkerOptions df = df { - ghcLink = LinkInMemory - , hscTarget = HscNothing - , ghcMode = CompManager - } + env <- hscSetFlags dflags'' <$> getSession + final_env' <- liftIO $ wrapPackageSetupException $ Compat.initUnits env + return (hsc_dflags final_env', targets) setIgnoreInterfacePragmas :: DynFlags -> DynFlags setIgnoreInterfacePragmas df = diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index c776ff7908..5d27facf54 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -23,17 +23,12 @@ import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat hiding (TargetFile, - TargetModule, - parseModule, - typecheckModule, - writeHieFile) +import Development.IDE.GHC.Compat hiding (writeHieFile) import Development.IDE.Graph import qualified Development.IDE.Spans.AtPoint as AtPoint import Development.IDE.Types.HscEnvEq (hscEnv) import Development.IDE.Types.Location import qualified HieDb -import HscTypes (hsc_dflags) import Language.LSP.Types (DocumentHighlight (..), SymbolInformation (..)) @@ -44,7 +39,7 @@ lookupMod :: HieDbWriter -- ^ access the database -> FilePath -- ^ The `.hie` file we got from the database -> ModuleName - -> UnitId + -> Unit -> Bool -- ^ Is this file a boot file? -> MaybeT IdeAction Uri lookupMod _dbchan _hie_f _mod _uid _boot = MaybeT $ pure Nothing @@ -64,11 +59,11 @@ getAtPoint file pos = runMaybeT $ do opts <- liftIO $ getIdeOptionsIO ide (hf, mapping) <- useE GetHieAst file - df <- hsc_dflags . hscEnv . fst <$> useE GhcSession file + env <- hscEnv . fst <$> useE GhcSession file dkMap <- lift $ maybe (DKMap mempty mempty) fst <$> runMaybeT (useE GetDocMap file) !pos' <- MaybeT (return $ fromCurrentPosition mapping pos) - MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap df pos' + MaybeT $ pure $ first (toCurrentRange mapping =<<) <$> AtPoint.atPoint opts hf dkMap env pos' toCurrentLocations :: PositionMapping -> [Location] -> [Location] toCurrentLocations mapping = mapMaybe go diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index 340b7bebd0..ce889fb7ba 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -43,19 +43,18 @@ import Development.IDE.Spans.Common import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Options -import Outputable hiding ((<>)) + +import Development.IDE.GHC.Compat hiding (loadInterface, + parseHeader, parseModule, + tcRnModule, writeHieFile) +import qualified Development.IDE.GHC.Compat as Compat +import qualified Development.IDE.GHC.Compat as GHC +import qualified Development.IDE.GHC.Compat.Util as Util import HieDb import Language.LSP.Types (DiagnosticTag (..)) -import DriverPhases -import DriverPipeline hiding (unP) -import HscTypes -import LoadIface (loadModuleInterface) - -import Lexer -import qualified Parser #if MIN_VERSION_ghc(8,10,0) import Control.DeepSeq (force, rnf) #else @@ -63,35 +62,13 @@ import Control.DeepSeq (rnf) import ErrUtils #endif -import Development.IDE.GHC.Compat hiding (parseModule, - typecheckModule, - writeHieFile) -import qualified Development.IDE.GHC.Compat as Compat -import qualified Development.IDE.GHC.Compat as GHC -import Finder -import GhcMonad -import GhcPlugins as GHC hiding (fst3, (<>)) -import Hooks -import HscMain (hscDesugar, hscGenHardCode, - hscInteractive, hscSimplify, - hscTypecheckRename, - makeSimpleDetails) -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 import Control.Exception (evaluate) import Control.Exception.Safe import Control.Lens hiding (List) @@ -108,13 +85,13 @@ import Data.Maybe import qualified Data.Text as T import Data.Time (UTCTime, getCurrentTime) import qualified GHC.LanguageExtensions as LangExt -import HeaderInfo -import Linker (unload) -import Maybes (orElse) import System.Directory import System.FilePath import System.IO.Extra (fixIO, newTempFileWithin) -import TcEnv (tcLookup) + +-- GHC API imports +import GHC (GetDocsFailure (..), + parsedSource) import Control.Concurrent.Extra import Control.Concurrent.STM hiding (orElse) @@ -124,8 +101,7 @@ import Data.Coerce import Data.Functor import qualified Data.HashMap.Strict as HashMap import Data.Tuple.Extra (dupe) -import Data.Unique -import GHC.Fingerprint +import Data.Unique as Unique import qualified Language.LSP.Server as LSP import qualified Language.LSP.Types as LSP @@ -146,11 +122,10 @@ parseModule IdeOptions{..} env filename ms = -- | Given a package identifier, what packages does it depend on computePackageDeps :: HscEnv - -> InstalledUnitId - -> IO (Either [FileDiagnostic] [InstalledUnitId]) + -> Unit + -> IO (Either [FileDiagnostic] [UnitId]) computePackageDeps env pkg = do - let dflags = hsc_dflags env - case oldLookupInstalledPackage dflags pkg of + case lookupUnit env pkg of Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $ T.pack $ "unknown package: " ++ show pkg] Just pkgInfo -> return $ Right $ unitDepends pkgInfo @@ -169,7 +144,12 @@ typecheckModule (IdeDefer defer) hsc keep_lbls pm = do modSummary' <- initPlugins hsc modSummary (warnings, tcm) <- withWarnings "typecheck" $ \tweak -> - tcRnModule hsc keep_lbls $ demoteIfDefer pm{pm_mod_summary = tweak modSummary'} + let + session = tweak (hscSetFlags dflags hsc) + -- TODO: maybe settings ms_hspp_opts is unnecessary? + mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session} + in + tcRnModule hsc keep_lbls $ demoteIfDefer pm{pm_mod_summary = mod_summary''} let errorPipeline = unDefer . hideDiag dflags . tagDiag diags = map errorPipeline warnings deferedError = any fst diags @@ -180,10 +160,10 @@ typecheckModule (IdeDefer defer) hsc keep_lbls pm = do -- | Add a Hook to the DynFlags which captures and returns the -- typechecked splices before they are run. This information -- is used for hover. -captureSplices :: DynFlags -> (DynFlags -> IO a) -> IO (a, Splices) -captureSplices dflags k = do +captureSplices :: HscEnv -> (HscEnv -> IO a) -> IO (a, Splices) +captureSplices env k = do splice_ref <- newIORef mempty - res <- k (dflags { hooks = addSpliceHook splice_ref (hooks dflags)}) + res <- k (hscSetHooks (addSpliceHook splice_ref (hsc_hooks env)) env) splices <- readIORef splice_ref return (res, splices) where @@ -217,14 +197,13 @@ captureSplices dflags k = do tcRnModule :: HscEnv -> [Linkable] -> ParsedModule -> IO TcModuleResult tcRnModule hsc_env keep_lbls pmod = do let ms = pm_mod_summary pmod - hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env unload hsc_env_tmp keep_lbls ((tc_gbl_env, mrn_info), splices) - <- liftIO $ captureSplices (ms_hspp_opts ms) $ \dflags -> - do let hsc_env_tmp = hsc_env { hsc_dflags = dflags } - hscTypecheckRename hsc_env_tmp ms $ + <- liftIO $ captureSplices (hscSetFlags (ms_hspp_opts ms) hsc_env) $ \hsc_env_tmp -> + do hscTypecheckRename hsc_env_tmp ms $ HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod, hpm_annotations = pm_annotations pmod } @@ -235,7 +214,7 @@ tcRnModule hsc_env keep_lbls pmod = do mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult mkHiFileResultNoCompile session tcm = do - let hsc_env_tmp = session { hsc_dflags = ms_hspp_opts ms } + let hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) session ms = pm_mod_summary $ tmrParsed tcm tcGblEnv = tmrTypechecked tcm details <- makeSimpleDetails hsc_env_tmp tcGblEnv @@ -255,7 +234,7 @@ mkHiFileResultCompile -> LinkableType -- ^ use object code or byte code? -> IO (IdeResult HiFileResult) mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do - let session = session' { hsc_dflags = ms_hspp_opts ms } + let session = hscSetFlags (ms_hspp_opts ms) session' ms = pm_mod_summary $ tmrParsed tcm tcGblEnv = tmrTypechecked tcm @@ -297,8 +276,8 @@ mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do initPlugins :: HscEnv -> ModSummary -> IO ModSummary initPlugins session modSummary = do - dflags <- liftIO $ initializePlugins session $ ms_hspp_opts modSummary - return modSummary{ms_hspp_opts = dflags} + session1 <- liftIO $ initializePlugins (hscSetFlags (ms_hspp_opts modSummary) session) + return modSummary{ms_hspp_opts = hsc_dflags session1} -- | Whether we should run the -O0 simplifier when generating core. -- @@ -318,9 +297,9 @@ compileModule (RunSimplifier simplify) session ms tcg = fmap (either (, Nothing) (second Just)) $ catchSrcErrors (hsc_dflags session) "compile" $ do (warnings,desugared_guts) <- withWarnings "compile" $ \tweak -> do - let ms' = tweak ms - session' = session{ hsc_dflags = ms_hspp_opts ms'} - desugar <- hscDesugar session' ms' tcg + let session' = tweak (hscSetFlags (ms_hspp_opts ms) session) + -- TODO: maybe settings ms_hspp_opts is unnecessary? + desugar <- hscDesugar session' (ms { ms_hspp_opts = hsc_dflags session' }) tcg if simplify then do plugins <- readIORef (tcg_th_coreplugins tcg) @@ -337,23 +316,20 @@ generateObjectCode session summary guts = do fp = replaceExtension dot_o "s" createDirectoryIfMissing True (takeDirectory fp) (warnings, dot_o_fp) <- - withWarnings "object" $ \_tweak -> do - let summary' = _tweak summary -#if MIN_VERSION_ghc(8,10,0) - target = defaultObjectTarget $ hsc_dflags session -#else - target = defaultObjectTarget $ targetPlatform $ hsc_dflags session -#endif - session' = session { hsc_dflags = updOptLevel 0 $ (ms_hspp_opts summary') { outputFile = Just dot_o , hscTarget = target}} + withWarnings "object" $ \tweak -> do + let env' = tweak (hscSetFlags (ms_hspp_opts summary) session) + target = platformDefaultBackend (hsc_dflags env') + newFlags = setBackend target $ updOptLevel 0 $ (hsc_dflags env') { outputFile = Just dot_o } + session' = hscSetFlags newFlags session #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') + (ms_location summary) #else - summary' + summary #endif fp compileFile session' StopLn (outputFilename, Just (As False)) @@ -370,8 +346,9 @@ generateByteCode hscEnv summary guts = do catchSrcErrors (hsc_dflags hscEnv) "bytecode" $ do (warnings, (_, bytecode, sptEntries)) <- withWarnings "bytecode" $ \_tweak -> do - let summary' = _tweak summary - session = hscEnv { hsc_dflags = ms_hspp_opts summary' } + let session = _tweak (hscSetFlags (ms_hspp_opts summary) hscEnv) + -- TODO: maybe settings ms_hspp_opts is unnecessary? + summary' = summary { ms_hspp_opts = hsc_dflags session } hscInteractive session guts #if MIN_VERSION_ghc(8,10,0) (ms_location summary') @@ -475,16 +452,16 @@ generateHieAsts hscEnv tcm = -- These varBinds use unitDataConId but it could be anything as the id name is not used -- during the hie file generation process. It's a workaround for the fact that the hie modules -- 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)) + let fake_splice_binds = Util.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 + top_ev_binds = tcg_ev_binds ts :: Util.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 + Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) top_ev_binds insts tcs #else - Just <$> GHC.enrichHie (fake_splice_binds `unionBags` real_binds) (tmrRenamed tcm) + Just <$> GHC.enrichHie (fake_splice_binds `Util.unionBags` real_binds) (tmrRenamed tcm) #endif where dflags = hsc_dflags hscEnv @@ -527,7 +504,7 @@ spliceExpresions Splices{..} = -- TVar to 0 in order to set it up for a fresh indexing session. Otherwise, we -- can just increment the 'indexCompleted' TVar and exit. -- -indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Fingerprint -> Compat.HieFile -> IO () +indexHieFile :: ShakeExtras -> ModSummary -> NormalizedFilePath -> Util.Fingerprint -> Compat.HieFile -> IO () indexHieFile se mod_summary srcPath !hash hf = do IdeOptions{optProgressStyle} <- getIdeOptionsIO se atomically $ do @@ -565,7 +542,7 @@ indexHieFile se mod_summary srcPath !hash hf = do case lspEnv se of Nothing -> pure Nothing Just env -> LSP.runLspT env $ do - u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO newUnique + u <- LSP.ProgressTextToken . T.pack . show . hashUnique <$> liftIO Unique.newUnique -- TODO: Wait for the progress create response to use the token _ <- LSP.sendRequest LSP.SWindowWorkDoneProgressCreate (LSP.WorkDoneProgressCreateParams u) (const $ pure ()) LSP.sendNotification LSP.SProgress $ LSP.ProgressParams u $ @@ -634,7 +611,7 @@ writeAndIndexHieFile hscEnv se mod_summary srcPath exports ast source = hf <- runHsc hscEnv $ GHC.mkHieFile' mod_summary exports ast source atomicFileWrite targetPath $ flip GHC.writeHieFile hf - hash <- getFileHash targetPath + hash <- Util.getFileHash targetPath indexHieFile se mod_summary srcPath hash hf where dflags = hsc_dflags hscEnv @@ -645,7 +622,7 @@ writeHiFile :: HscEnv -> HiFileResult -> IO [FileDiagnostic] writeHiFile hscEnv tc = handleGenerationErrors dflags "interface write" $ do atomicFileWrite targetPath $ \fp -> - writeIfaceFile dflags fp modIface + writeIfaceFile hscEnv fp modIface where modIface = hm_iface $ hirHomeMod tc targetPath = ml_hi_file $ ms_location $ hirModSummary tc @@ -674,7 +651,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 (homeUnitId_ $ 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 @@ -718,7 +695,7 @@ getModSummaryFromImports :: HscEnv -> FilePath -> UTCTime - -> Maybe SB.StringBuffer + -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO ModSummaryResult getModSummaryFromImports env fp modTime contents = do (contents, opts, dflags) <- preprocessor env fp contents @@ -730,7 +707,7 @@ getModSummaryFromImports env fp modTime contents = do let mb_mod = hsmodName hsmod imps = hsmodImports hsmod - mod = fmap unLoc mb_mod `orElse` mAIN_NAME + mod = fmap unLoc mb_mod `Util.orElse` mAIN_NAME (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource.unLoc) imps @@ -756,7 +733,7 @@ getModSummaryFromImports env fp modTime contents = do modLoc <- liftIO $ mkHomeModLocation dflags mod fp - let modl = mkModule (thisPackage dflags) mod + let modl = mkHomeModule (hscHomeUnit (hscSetFlags dflags env)) mod sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile msrModSummary = ModSummary @@ -785,14 +762,14 @@ getModSummaryFromImports env fp modTime contents = do -- eliding the timestamps, the preprocessed source and other non relevant fields computeFingerprint opts ModSummary{..} = do fingerPrintImports <- fingerprintFromPut $ do - put $ uniq $ moduleNameFS $ moduleName ms_mod + put $ Util.uniq $ moduleNameFS $ moduleName ms_mod forM_ (ms_srcimps ++ ms_textual_imps) $ \(mb_p, m) -> do - put $ uniq $ moduleNameFS $ unLoc m - whenJust mb_p $ put . uniq - return $! fingerprintFingerprints $ - [ fingerprintString fp + put $ Util.uniq $ moduleNameFS $ unLoc m + whenJust mb_p $ put . Util.uniq + return $! Util.fingerprintFingerprints $ + [ Util.fingerprintString fp , fingerPrintImports - ] ++ map fingerprintString opts + ] ++ map Util.fingerprintString opts -- | Parse only the module header @@ -800,15 +777,15 @@ parseHeader :: Monad m => DynFlags -- ^ flags to use -> FilePath -- ^ the filename (for source locations) - -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported) + -> Util.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 + let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1 + case unP Compat.parseHeader (initParserState (initParserOpts dflags) contents loc) of #if MIN_VERSION_ghc(8,10,0) PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags @@ -828,9 +805,9 @@ parseHeader dflags filename contents = do -- errors are those from which a parse tree just can't -- be produced. unless (null errs) $ - throwE $ diagFromErrMsgs "parser" dflags errs + throwE $ diagFromErrMsgs "parser" dflags (fmap pprError errs) - let warnings = diagFromErrMsgs "parser" dflags warns + let warnings = diagFromErrMsgs "parser" dflags (fmap pprWarning warns) return (warnings, rdr_module) -- | Given a buffer, flags, and file path, produce a @@ -843,10 +820,10 @@ parseFileContents -> ModSummary -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule) parseFileContents env customPreprocessor filename ms = do - let loc = mkRealSrcLoc (mkFastString filename) 1 1 + let loc = mkRealSrcLoc (Util.mkFastString filename) 1 1 dflags = ms_hspp_opts ms contents = fromJust $ ms_hspp_buf ms - case unP Parser.parseModule (mkPState dflags contents loc) of + case unP Compat.parseModule (initParserState (initParserOpts dflags) contents loc) of #if MIN_VERSION_ghc(8,10,0) PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags #else @@ -854,21 +831,8 @@ parseFileContents env customPreprocessor filename ms = do throwE $ diagFromErrMsg "parser" dflags $ mkPlainErrMsg dflags locErr msgErr #endif POk pst rdr_module -> - 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 + let + hpm_annotations = mkApiAnns pst (warns, errs) = getMessages pst dflags in do @@ -908,7 +872,7 @@ parseFileContents env customPreprocessor filename ms = do $ filter (/= n_hspp) $ map normalise $ filter (not . isPrefixOf "<") - $ map unpackFS + $ map Util.unpackFS $ srcfiles pst srcs1 = case ml_hs_file (ms_location ms) of Just f -> filter (/= normalise f) srcs0 @@ -919,13 +883,7 @@ parseFileContents env customPreprocessor filename ms = do -- filter them out: srcs2 <- liftIO $ filterM doesFileExist srcs1 - let pm = - ParsedModule { - pm_mod_summary = ms - , pm_parsed_source = parsed' - , pm_extra_src_files = srcs2 - , pm_annotations = hpm_annotations - } + let pm = mkParsedModule ms parsed' srcs2 hpm_annotations warnings = diagFromErrMsgs "parser" dflags warns pure (warnings ++ preproc_warnings, pm) @@ -944,7 +902,7 @@ loadInterface -> (Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface -> m ([FileDiagnostic], Maybe HiFileResult) loadInterface session ms sourceMod linkableNeeded regen = do - let sessionWithMsDynFlags = session{hsc_dflags = ms_hspp_opts ms} + let sessionWithMsDynFlags = hscSetFlags (ms_hspp_opts ms) session res <- liftIO $ checkOldIface sessionWithMsDynFlags ms sourceMod Nothing case res of (UpToDate, Just iface) @@ -1019,7 +977,7 @@ getDocsBatch hsc_env _mod _names = do UnhelpfulLoc {} -> True fakeSpan :: RealSrcSpan -fakeSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "") 1 1 +fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "") 1 1 -- | Non-interactive, batch version of 'InteractiveEval.lookupNames'. -- The interactive paths create problems in ghc-lib builds diff --git a/ghcide/src/Development/IDE/Core/Preprocessor.hs b/ghcide/src/Development/IDE/Core/Preprocessor.hs index 544a88e7d7..29fe43296e 100644 --- a/ghcide/src/Development/IDE/Core/Preprocessor.hs +++ b/ghcide/src/Development/IDE/Core/Preprocessor.hs @@ -7,13 +7,13 @@ module Development.IDE.Core.Preprocessor import Development.IDE.GHC.CPP import Development.IDE.GHC.Compat +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Orphans () -import GhcMonad -import StringBuffer as SB import Control.DeepSeq (NFData (rnf)) import Control.Exception (evaluate) import Control.Exception.Safe (catch, throw) +import Control.Monad.IO.Class import Control.Monad.Trans.Except import Data.Char import Data.IORef (IORef, modifyIORef, @@ -26,56 +26,52 @@ import Development.IDE.GHC.Error import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import qualified GHC.LanguageExtensions as LangExt -import qualified HeaderInfo as Hdr -import HscTypes (HscEnv (hsc_dflags)) -import Outputable (showSDoc) -import SysTools (Option (..), runPp, - runUnlit) import System.FilePath import System.IO.Extra - -- | Given a file and some contents, apply any necessary preprocessors, -- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies. -preprocessor :: HscEnv -> FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] IO (StringBuffer, [String], DynFlags) -preprocessor env filename mbContents = do +preprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO (Util.StringBuffer, [String], DynFlags) +preprocessor env0 filename mbContents = do -- Perform unlit (isOnDisk, contents) <- if isLiterate filename then do - let dflags = hsc_dflags env - newcontent <- liftIO $ runLhs dflags filename mbContents + newcontent <- liftIO $ runLhs env0 filename mbContents return (False, newcontent) else do - contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents + contents <- liftIO $ maybe (Util.hGetStringBuffer filename) return mbContents let isOnDisk = isNothing mbContents return (isOnDisk, contents) -- Perform cpp - (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents + (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env0 filename contents + let env1 = hscSetFlags dflags env0 + let logger = hsc_logger env1 (isOnDisk, contents, opts, dflags) <- if not $ xopt LangExt.Cpp dflags then return (isOnDisk, contents, opts, dflags) else do cppLogs <- liftIO $ newIORef [] + let newLogger = pushLogHook (const (logActionCompat $ logAction cppLogs)) logger contents <- ExceptT - $ (Right <$> (runCpp dflags {log_action = logActionCompat $ logAction cppLogs} filename + $ (Right <$> (runCpp (putLogHook newLogger env1) filename $ if isOnDisk then Nothing else Just contents)) `catch` - ( \(e :: GhcException) -> do + ( \(e :: Util.GhcException) -> do logs <- readIORef cppLogs case diagsFromCPPLogs filename (reverse logs) of [] -> throw e diags -> return $ Left diags ) - (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents + (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env1 filename contents return (False, contents, opts, dflags) -- Perform preprocessor if not $ gopt Opt_Pp dflags then return (contents, opts, dflags) else do - contents <- liftIO $ runPreprocessor dflags filename $ if isOnDisk then Nothing else Just contents - (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env filename contents + contents <- liftIO $ runPreprocessor env1 filename $ if isOnDisk then Nothing else Just contents + (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env1 filename contents return (contents, opts, dflags) where logAction :: IORef [CPPLog] -> LogActionCompat @@ -107,7 +103,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 (OldRealSrcSpan span) msg : logs) = + go acc (CPPLog sev (RealSrcSpan span _) msg : logs) = let diag = CPPDiag (realSrcSpanToRange span) (toDSeverity sev) [msg] in go (diag : acc) logs go (diag : diags) (CPPLog _sev (UnhelpfulSpan _) msg : logs) = @@ -134,22 +130,22 @@ isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"] parsePragmasIntoDynFlags :: HscEnv -> FilePath - -> SB.StringBuffer + -> Util.StringBuffer -> IO (Either [FileDiagnostic] ([String], DynFlags)) parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do - let opts = Hdr.getOptions dflags0 contents fp + let opts = getOptions dflags0 contents fp -- Force bits that might keep the dflags and stringBuffer alive unnecessarily evaluate $ rnf opts (dflags, _, _) <- parseDynamicFilePragma dflags0 opts - dflags' <- initializePlugins env dflags - return (map unLoc opts, disableWarningsAsErrors dflags') + hsc_env' <- initializePlugins (hscSetFlags dflags env) + return (map unLoc opts, disableWarningsAsErrors (hsc_dflags hsc_env')) where dflags0 = hsc_dflags env -- | Run (unlit) literate haskell preprocessor on a file, or buffer if set -runLhs :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer -runLhs dflags filename contents = withTempDir $ \dir -> do +runLhs :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer +runLhs env filename contents = withTempDir $ \dir -> do let fout = dir takeFileName filename <.> "unlit" filesrc <- case contents of Nothing -> return filename @@ -159,14 +155,17 @@ runLhs dflags filename contents = withTempDir $ \dir -> do hPutStringBuffer h cnts return fsrc unlit filesrc fout - SB.hGetStringBuffer fout + Util.hGetStringBuffer fout where - unlit filein fileout = SysTools.runUnlit dflags (args filein fileout) + logger = hsc_logger env + dflags = hsc_dflags env + + unlit filein fileout = runUnlit logger dflags (args filein fileout) args filein fileout = [ - SysTools.Option "-h" - , SysTools.Option (escape filename) -- name this file - , SysTools.FileOption "" filein -- input file - , SysTools.FileOption "" fileout ] -- output file + Option "-h" + , Option (escape filename) -- name this file + , FileOption "" filein -- input file + , FileOption "" fileout ] -- output file -- taken from ghc's DriverPipeline.hs escape ('\\':cs) = '\\':'\\': escape cs escape ('\"':cs) = '\\':'\"': escape cs @@ -175,31 +174,32 @@ runLhs dflags filename contents = withTempDir $ \dir -> do escape [] = [] -- | Run CPP on a file -runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer -runCpp dflags filename contents = withTempDir $ \dir -> do +runCpp :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer +runCpp env0 filename contents = withTempDir $ \dir -> do let out = dir takeFileName filename <.> "out" - dflags <- pure $ addOptP "-D__GHCIDE__" dflags + let dflags1 = addOptP "-D__GHCIDE__" (hsc_dflags env0) + let env1 = hscSetFlags dflags1 env0 case contents of Nothing -> do -- Happy case, file is not modified, so run CPP on it in-place -- which also makes things like relative #include files work -- and means location information is correct - doCpp dflags True filename out - liftIO $ SB.hGetStringBuffer out + doCpp env1 True filename out + liftIO $ Util.hGetStringBuffer out Just contents -> do -- Sad path, we have to create a version of the path in a temp dir -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue) -- Relative includes aren't going to work, so we fix that by adding to the include path. - dflags <- return $ addIncludePathsQuote (takeDirectory filename) dflags - + let dflags2 = addIncludePathsQuote (takeDirectory filename) dflags1 + let env2 = hscSetFlags dflags2 env0 -- Location information is wrong, so we fix that by patching it afterwards. let inp = dir "___GHCIDE_MAGIC___" withBinaryFile inp WriteMode $ \h -> hPutStringBuffer h contents - doCpp dflags True inp out + doCpp env2 True inp out -- Fix up the filename in lines like: -- # 1 "C:/Temp/extra-dir-914611385186/___GHCIDE_MAGIC___" @@ -211,12 +211,12 @@ runCpp dflags filename contents = withTempDir $ \dir -> do -- and GHC gets all confused = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\"" | otherwise = x - stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out + Util.stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out -- | Run a preprocessor on a file -runPreprocessor :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer -runPreprocessor dflags filename contents = withTempDir $ \dir -> do +runPreprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> IO Util.StringBuffer +runPreprocessor env filename contents = withTempDir $ \dir -> do let out = dir takeFileName filename <.> "out" inp <- case contents of Nothing -> return filename @@ -225,5 +225,8 @@ runPreprocessor dflags filename contents = withTempDir $ \dir -> do withBinaryFile inp WriteMode $ \h -> hPutStringBuffer h contents return inp - runPp dflags [SysTools.Option filename, SysTools.Option inp, SysTools.FileOption "" out] - SB.hGetStringBuffer out + runPp logger dflags [Option filename, Option inp, FileOption "" out] + Util.hGetStringBuffer out + where + logger = hsc_logger env + dflags = hsc_dflags env diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 0b19fc85a4..abbc7c6cf3 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs @@ -25,6 +25,7 @@ import Data.Time.Clock.POSIX import Data.Typeable import Development.IDE.GHC.Compat hiding (HieFileResult) +import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Util import Development.IDE.Graph import Development.IDE.Import.DependencyInformation @@ -32,11 +33,6 @@ import Development.IDE.Types.HscEnvEq (HscEnvEq) import Development.IDE.Types.KnownTargets import GHC.Generics (Generic) -import HscTypes (HomeModInfo, - ModGuts, - hm_iface, - hm_linkable) - import qualified Data.Binary as B import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LBS @@ -46,10 +42,8 @@ import Development.IDE.Import.FindImports (ArtifactsLocation import Development.IDE.Spans.Common import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Diagnostics -import Fingerprint import GHC.Serialized (Serialized) import Language.LSP.Types (NormalizedFilePath) -import TcRnMonad (TcGblEnv) data LinkableType = ObjectLinkable | BCOLinkable deriving (Eq,Ord,Show, Generic) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 0d4c082931..d4f4c30d81 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -58,6 +58,9 @@ module Development.IDE.Core.Rules( typeCheckRuleDefinition, ) where +#if !MIN_VERSION_ghc(8,8,0) +import Control.Applicative (liftA2) +#endif import Control.Concurrent.Async (concurrently) import Control.Concurrent.Strict import Control.Exception.Safe @@ -103,12 +106,14 @@ import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat hiding - (TargetFile, - TargetModule, - parseModule, - typecheckModule, - writeHieFile) +import Development.IDE.GHC.Compat.Env +import Development.IDE.GHC.Compat.Core hiding + (parseModule, + TargetId(..), + loadInterface, + Var) +import qualified Development.IDE.GHC.Compat as Compat +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint import Development.IDE.GHC.Util hiding @@ -125,23 +130,16 @@ import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Location import qualified Development.IDE.Types.Logger as L import Development.IDE.Types.Options -import Fingerprint import GHC.Generics (Generic) import GHC.IO.Encoding import qualified GHC.LanguageExtensions as LangExt import qualified HieDb -import HscTypes hiding - (TargetFile, - TargetModule) import Ide.Plugin.Config import qualified Language.LSP.Server as LSP import Language.LSP.Types (SMethod (SCustomMethod)) import Language.LSP.VFS -import Module import System.Directory (canonicalizePath, makeAbsolute) -import TcRnMonad (tcg_dependent_files) -import Control.Applicative import Data.Default (def) import Ide.Plugin.Properties (HasProperty, KeyNameProxy, @@ -343,7 +341,7 @@ getLocatedImportsRule = | otherwise = return Nothing (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do - diagOrImp <- locateModule dflags import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource + diagOrImp <- locateModule (hscSetFlags dflags env) import_dirs (optExtensions opt) getTargetFor modName mbPkgName isSource case diagOrImp of Left diags -> pure (diags, Just (modName, Nothing)) Right (FileImport path) -> pure ([], Just (modName, Just path)) @@ -503,8 +501,8 @@ getDependenciesRule = let allFiles = reachableModules depInfo _ <- uses_ ReportImportCycles allFiles opts <- getIdeOptions - let mbFingerprints = map (fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts - return (fingerprintToBS . fingerprintFingerprints <$> mbFingerprints, transitiveDeps depInfo file) + let mbFingerprints = map (Util.fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts + return (fingerprintToBS . Util.fingerprintFingerprints <$> mbFingerprints, transitiveDeps depInfo file) getHieAstsRule :: Rules () getHieAstsRule = @@ -523,9 +521,9 @@ persistentHieFileRule = addPersistentRule GetHieAst $ \file -> runMaybeT $ do case mvf of Nothing -> (,Nothing) . T.decode encoding <$> BS.readFile (fromNormalizedFilePath file) Just vf -> pure (Rope.toText $ _text vf, Just $ _lsp_version vf) - let refmap = generateReferencesMap . getAsts . hie_asts $ res - del = deltaFromDiff (T.decode encoding $ hie_hs_src res) currentSource - pure (HAR (hie_module res) (hie_asts res) refmap mempty (HieFromDisk res),del,ver) + let refmap = Compat.generateReferencesMap . Compat.getAsts . Compat.hie_asts $ res + del = deltaFromDiff (T.decode encoding $ Compat.hie_hs_src res) currentSource + pure (HAR (Compat.hie_module res) (Compat.hie_asts res) refmap mempty (HieFromDisk res),del,ver) getHieAstRuleDefinition :: NormalizedFilePath -> HscEnv -> TcModuleResult -> Action (IdeResult HieAstResult) getHieAstRuleDefinition f hsc tmr = do @@ -546,8 +544,8 @@ getHieAstRuleDefinition f hsc tmr = do liftIO $ writeAndIndexHieFile hsc se msum f exports asts source _ -> pure [] - let refmap = generateReferencesMap . getAsts <$> masts - typemap = AtPoint.computeTypeReferences . getAsts <$> masts + let refmap = Compat.generateReferencesMap . Compat.getAsts <$> masts + typemap = AtPoint.computeTypeReferences . Compat.getAsts <$> masts pure (diags <> diagsWrite, HAR (ms_mod $ tmrModSummary tmr) <$> masts <*> refmap <*> typemap <*> pure HieFresh) getImportMapRule :: Rules () @@ -584,7 +582,7 @@ getDocMapRule = persistentDocMapRule :: Rules () persistentDocMapRule = addPersistentRule GetDocMap $ \_ -> pure $ Just (DKMap mempty mempty, idDelta, Nothing) -readHieFileForSrcFromDisk :: NormalizedFilePath -> MaybeT IdeAction HieFile +readHieFileForSrcFromDisk :: NormalizedFilePath -> MaybeT IdeAction Compat.HieFile readHieFileForSrcFromDisk file = do db <- asks hiedb log <- asks $ L.logDebug . logger @@ -593,7 +591,7 @@ readHieFileForSrcFromDisk file = do liftIO $ log $ "LOADING HIE FILE :" <> T.pack (show file) exceptToMaybeT $ readHieFileFromDisk hie_loc -readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction HieFile +readHieFileFromDisk :: FilePath -> ExceptT SomeException IdeAction Compat.HieFile readHieFileFromDisk hie_loc = do nc <- asks ideNc log <- asks $ L.logDebug . logger @@ -754,8 +752,8 @@ getModIfaceFromDiskAndIndexRule = -- GetModIfaceFromDisk should have written a `.hie` file, must check if it matches version in db let ms = hirModSummary x - hie_loc = ml_hie_file $ ms_location ms - hash <- liftIO $ getFileHash hie_loc + hie_loc = Compat.ml_hie_file $ ms_location ms + hash <- liftIO $ Util.getFileHash hie_loc mrow <- liftIO $ HieDb.lookupHieFileFromSource hiedb (fromNormalizedFilePath f) hie_loc' <- liftIO $ traverse (canonicalizePath . HieDb.hieModuleHieFile) mrow case mrow of @@ -785,7 +783,7 @@ isHiFileStableRule :: Rules () isHiFileStableRule = defineEarlyCutoff $ RuleNoDiagnostics $ \IsHiFileStable f -> do ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps f let hiFile = toNormalizedFilePath' - $ ml_hi_file $ ms_location ms + $ Compat.ml_hi_file $ ms_location ms mbHiVersion <- use GetModificationTime_{missingFileDiagnostics=False} hiFile modVersion <- use_ GetModificationTime f sourceModified <- case mbHiVersion of @@ -811,7 +809,7 @@ getModSummaryRule = do defineEarlyCutoff $ Rule $ \GetModSummary f -> do session' <- hscEnv <$> use_ GhcSession f modify_dflags <- getModifyDynFlags dynFlagsModifyGlobal - let session = session' { hsc_dflags = modify_dflags $ hsc_dflags session' } + let session = hscSetFlags (modify_dflags $ hsc_dflags session') session' (modTime, mFileContent) <- getFileContents f let fp = fromNormalizedFilePath f modS <- liftIO $ runExceptT $ @@ -820,7 +818,7 @@ getModSummaryRule = do Right res -> do bufFingerPrint <- liftIO $ fingerprintFromStringBuffer $ fromJust $ ms_hspp_buf $ msrModSummary res - let fingerPrint = fingerprintFingerprints + let fingerPrint = Util.fingerprintFingerprints [ msrFingerprint res, bufFingerPrint ] return ( Just (fingerprintToBS fingerPrint) , ([], Just res)) Left diags -> return (Nothing, (diags, Nothing)) @@ -1047,7 +1045,7 @@ instance IsIdeGlobal CompiledLinkables writeHiFileAction :: HscEnv -> HiFileResult -> Action [FileDiagnostic] writeHiFileAction hsc hiFile = do extras <- getShakeExtras - let targetPath = ml_hi_file $ ms_location $ hirModSummary hiFile + let targetPath = Compat.ml_hi_file $ ms_location $ hirModSummary hiFile liftIO $ do resetInterfaceStore extras $ toNormalizedFilePath' targetPath writeHiFile hsc hiFile diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 37bfa9dc6a..d90cf01009 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -109,7 +109,11 @@ import Development.IDE.Core.PositionMapping import Development.IDE.Core.ProgressReporting import Development.IDE.Core.RuleTypes import Development.IDE.Core.Tracing -import Development.IDE.GHC.Compat (NameCacheUpdater (..), upNameCache) +import Development.IDE.GHC.Compat (NameCacheUpdater (..), + upNameCache, NameCache, + initNameCache, + mkSplitUniqSupply, + knownKeyNames) import Development.IDE.GHC.Orphans () import Development.IDE.Graph hiding (ShakeValue) import qualified Development.IDE.Graph as Shake @@ -137,10 +141,7 @@ import System.Time.Extra import Data.IORef import GHC.Fingerprint import Language.LSP.Types.Capabilities -import NameCache import OpenTelemetry.Eventlog -import PrelInfo -import UniqSupply import Control.Exception.Extra hiding (bracket_) import qualified Data.ByteString.Char8 as BS8 diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 1c773587bc..546b2eae44 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -21,7 +21,9 @@ import Control.Monad (forM_, forever, unless, void, import Control.Monad.Extra (whenJust) import Control.Monad.IO.Unlift import Control.Seq (r0, seqList, seqTuple2, using) +#if MIN_VERSION_ghc(8,8,0) import Data.ByteString (ByteString) +#endif import Data.Dynamic (Dynamic) import qualified Data.HashMap.Strict as HMap import Data.IORef (modifyIORef', newIORef, diff --git a/ghcide/src/Development/IDE/Core/UseStale.hs b/ghcide/src/Development/IDE/Core/UseStale.hs index df19b47a95..55b52e39be 100644 --- a/ghcide/src/Development/IDE/Core/UseStale.hs +++ b/ghcide/src/Development/IDE/Core/UseStale.hs @@ -29,6 +29,9 @@ import Data.Functor ((<&>)) import Data.Functor.Identity (Identity (Identity)) import Data.Kind (Type) import Data.String (fromString) +import Development.IDE.GHC.Compat (RealSrcSpan, + srcSpanFile) +import Development.IDE.GHC.Compat.Util (unpackFS) import Development.IDE (Action, IdeRule, NormalizedFilePath, Range, @@ -36,8 +39,6 @@ import Development.IDE (Action, IdeRule, realSrcSpanToRange) import qualified Development.IDE.Core.PositionMapping as P import qualified Development.IDE.Core.Shake as IDE -import qualified FastString as FS -import SrcLoc ------------------------------------------------------------------------------ @@ -113,7 +114,7 @@ instance MapAge Range where instance MapAge RealSrcSpan where mapAgeFrom = - invMapAge (\fs -> rangeToRealSrcSpan (fromString $ FS.unpackFS fs)) + invMapAge (\fs -> rangeToRealSrcSpan (fromString $ unpackFS fs)) (srcSpanFile &&& realSrcSpanToRange) . mapAgeFrom diff --git a/ghcide/src/Development/IDE/GHC/CPP.hs b/ghcide/src/Development/IDE/GHC/CPP.hs index 287ce61ac4..ee23fb004b 100644 --- a/ghcide/src/Development/IDE/GHC/CPP.hs +++ b/ghcide/src/Development/IDE/GHC/CPP.hs @@ -1,17 +1,8 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 --- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019 --- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944. --- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed. - -{- HLINT ignore -} -- since copied from upstream - {-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- @@ -24,148 +15,25 @@ module Development.IDE.GHC.CPP(doCpp, addOptP) where +import GHC import Development.IDE.GHC.Compat as Compat -import FileCleanup -import Packages -import Panic -import SysTools -#if MIN_VERSION_ghc(8,8,2) -import LlvmCodeGen (llvmVersionList) -#elif MIN_VERSION_ghc(8,8,0) -import LlvmCodeGen (LlvmVersion (..)) +#if !MIN_VERSION_ghc(8,10,0) +import qualified Development.IDE.GHC.Compat.CPP as CPP +#else +import Development.IDE.GHC.Compat.Util #endif + +#if MIN_VERSION_ghc(9,0,0) +import qualified GHC.Driver.Pipeline as Pipeline +import GHC.Settings +#else #if MIN_VERSION_ghc (8,10,0) -import Fingerprint +import qualified DriverPipeline as Pipeline import ToolSettings -#endif - -import Control.Monad -import Data.List (intercalate) -import Data.Maybe -import Data.Version -import System.Directory -import System.FilePath -import System.Info - - - -doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () -doCpp dflags raw input_fn output_fn = do - let hscpp_opts = picPOpts dflags - let cmdline_include_paths = includePaths dflags - - pkg_include_dirs <- getPackageIncludePath dflags [] - let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] - (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) - let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] - (includePathsQuote cmdline_include_paths) - let include_paths = include_paths_quote ++ include_paths_global - - let verbFlags = getVerbFlags dflags - - let cpp_prog args | raw = SysTools.runCpp dflags args -#if MIN_VERSION_ghc(8,10,0) - | otherwise = SysTools.runCc Nothing #else - | otherwise = SysTools.runCc +import DynFlags #endif - dflags (SysTools.Option "-E" : args) - - let target_defs = - -- NEIL: Patched to use System.Info instead of constants from CPP - [ "-D" ++ os ++ "_BUILD_OS", - "-D" ++ arch ++ "_BUILD_ARCH", - "-D" ++ os ++ "_HOST_OS", - "-D" ++ arch ++ "_HOST_ARCH" ] - -- remember, in code we *compile*, the HOST is the same our TARGET, - -- and BUILD is the same as our HOST. - - let sse_defs = - [ "-D__SSE__" | isSseEnabled dflags ] ++ - [ "-D__SSE2__" | isSse2Enabled dflags ] ++ - [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] - - let avx_defs = - [ "-D__AVX__" | isAvxEnabled dflags ] ++ - [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ - [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ - [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ - [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ - [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] - - backend_defs <- getBackendDefs dflags - - let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] - -- Default CPP defines in Haskell source - ghcVersionH <- getGhcVersionPathName dflags - let hsSourceCppOpts = [ "-include", ghcVersionH ] - - -- MIN_VERSION macros - let uids = explicitPackages (pkgState dflags) - pkgs = catMaybes (map (lookupPackage dflags) uids) - mb_macro_include <- - if not (null pkgs) && gopt Opt_VersionMacros dflags - then do macro_stub <- newTempName dflags TFL_CurrentModule "h" - writeFile macro_stub (generatePackageVersionMacros pkgs) - -- Include version macros for every *exposed* package. - -- Without -hide-all-packages and with a package database - -- size of 1000 packages, it takes cpp an estimated 2 - -- milliseconds to process this file. See #10970 - -- comment 8. - return [SysTools.FileOption "-include" macro_stub] - else return [] - - cpp_prog ( map SysTools.Option verbFlags - ++ map SysTools.Option include_paths - ++ map SysTools.Option hsSourceCppOpts - ++ map SysTools.Option target_defs - ++ map SysTools.Option backend_defs - ++ map SysTools.Option th_defs - ++ map SysTools.Option hscpp_opts - ++ map SysTools.Option sse_defs - ++ map SysTools.Option avx_defs - ++ mb_macro_include - -- Set the language mode to assembler-with-cpp when preprocessing. This - -- alleviates some of the C99 macro rules relating to whitespace and the hash - -- operator, which we tend to abuse. Clang in particular is not very happy - -- about this. - ++ [ SysTools.Option "-x" - , SysTools.Option "assembler-with-cpp" - , SysTools.Option input_fn - -- We hackily use Option instead of FileOption here, so that the file - -- name is not back-slashed on Windows. cpp is capable of - -- dealing with / in filenames, so it works fine. Furthermore - -- if we put in backslashes, cpp outputs #line directives - -- with *double* backslashes. And that in turn means that - -- our error messages get double backslashes in them. - -- In due course we should arrange that the lexer deals - -- with these \\ escapes properly. - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ]) - -getBackendDefs :: DynFlags -> IO [String] -getBackendDefs dflags | hscTarget dflags == HscLlvm = do - llvmVer <- figureLlvmVersion dflags - return $ case llvmVer of -#if MIN_VERSION_ghc(8,8,2) - Just v - | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ] - | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ] -#elif MIN_VERSION_ghc(8,8,0) - Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ] - Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] -#else - Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ] #endif - _ -> [] - where - format (major, minor) - | minor >= 100 = error "getBackendDefs: Unsupported minor version" - | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int - -getBackendDefs _ = - return [] addOptP :: String -> DynFlags -> DynFlags #if MIN_VERSION_ghc (8,10,0) @@ -183,47 +51,13 @@ addOptP opt = onSettings (onOptP (opt:)) onOptP f x = x{sOpt_P = f $ sOpt_P x} #endif --- --------------------------------------------------------------------------- --- Macros (cribbed from Cabal) - -generatePackageVersionMacros :: [Compat.PackageConfig] -> String -generatePackageVersionMacros pkgs = concat - -- Do not add any C-style comments. See #3389. - [ generateMacros "" pkgname version - | pkg <- pkgs - , let version = packageVersion pkg - pkgname = map fixchar (packageNameString pkg) - ] - -fixchar :: Char -> Char -fixchar '-' = '_' -fixchar c = c - -generateMacros :: String -> String -> Version -> String -generateMacros prefix name version = - concat - ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" - ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" - ," (major1) < ",major1," || \\\n" - ," (major1) == ",major1," && (major2) < ",major2," || \\\n" - ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" - ,"\n\n" - ] - where - (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) - - --- | Find out path to @ghcversion.h@ file -getGhcVersionPathName :: DynFlags -> IO FilePath -getGhcVersionPathName dflags = do - candidates <- case ghcVersionFile dflags of - Just path -> return [path] - Nothing -> (map ( "ghcversion.h")) <$> - (getPackageIncludePath dflags [Compat.toInstalledUnitId Compat.rtsUnit]) +doCpp :: HscEnv -> Bool -> FilePath -> FilePath -> IO () +doCpp env raw input_fn output_fn = +#if MIN_VERSION_ghc (9,2,0) + Pipeline.doCpp (hsc_logger env) (hsc_tmpfs env) (hsc_dflags env) (hsc_unit_env env) raw input_fn output_fn +#elif MIN_VERSION_ghc (8,10,0) + Pipeline.doCpp (hsc_dflags env) raw input_fn output_fn +#else + CPP.doCpp (hsc_dflags env) raw input_fn output_fn +#endif - found <- filterM doesFileExist candidates - case found of - [] -> throwGhcExceptionIO (InstallationError - ("ghcversion.h missing; tried: " - ++ intercalate ", " candidates)) - (x:_) -> return x diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index d5e8dd9e29..79840ba37f 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -4,218 +4,122 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternSynonyms #-} -{-# OPTIONS -Wno-dodgy-imports -Wno-incomplete-uni-patterns #-} -{-# OPTIONS -Wno-missing-signatures #-} -- TODO: Remove! +{-# OPTIONS -Wno-incomplete-uni-patterns -Wno-dodgy-imports #-} -- | Attempt at hiding the GHC version differences we can. module Development.IDE.GHC.Compat( - HieFileResult(..), - HieFile(..), NameCacheUpdater(..), - hieExportNames, - mkHieFile', - enrichHie, - writeHieFile, - readHieFile, - supportsHieFiles, - setHieDir, - dontWriteHieFiles, -#if !MIN_VERSION_ghc(8,8,0) - ml_hie_file, - addBootSuffixLocnOut, - getRealSrcSpan, -#endif hPutStringBuffer, addIncludePathsQuote, getModuleHash, - getPackageName, setUpTypedHoles, - GHC.ModLocation, - Module.addBootSuffix, - pattern ModLocation, - pattern ExposePackage, - HasSrcSpan, - getLoc, upNameCache, disableWarningsAsErrors, - AvailInfo, - tcg_exports, - pattern FunTy, - -#if MIN_VERSION_ghc(8,10,0) - module GHC.Hs.Extension, - module LinkerTypes, -#else - module HsExtension, - noExtField, - linkableTime, -#endif -#if MIN_VERSION_ghc(9,0,1) - -- Reexports from GHC - UnitId, - moduleUnitId, - pkgState, - thisInstalledUnitId, - -- Reexports from DynFlags - thisPackage, - writeIfaceFile, - - gcatch, -#else +#if !MIN_VERSION_ghc(9,0,1) 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, - unitString, - - LogActionCompat, - logActionCompat, - - pprSigmaType, - module GHC, - module DynFlags, - initializePlugins, - applyPluginsParsedResultAction, - module Compat.HieTypes, - module Compat.HieUtils, - dropForAll, isQualifiedImport, GhcVersion(..), ghcVersion, - ghcVersionStr + ghcVersionStr, + -- * HIE Compat + HieFileResult(..), + HieFile(..), + hieExportNames, + mkHieFile', + enrichHie, + writeHieFile, + readHieFile, + supportsHieFiles, + setHieDir, + dontWriteHieFiles, + module Compat.HieTypes, + module Compat.HieUtils, + -- * Compat modules + module Development.IDE.GHC.Compat.Core, + module Development.IDE.GHC.Compat.Env, + module Development.IDE.GHC.Compat.Iface, + module Development.IDE.GHC.Compat.Logger, + module Development.IDE.GHC.Compat.Outputable, + module Development.IDE.GHC.Compat.Parser, + module Development.IDE.GHC.Compat.Plugins, + module Development.IDE.GHC.Compat.Units, + -- * Extras that rely on compat modules + -- * SysTools + Option (..), + runUnlit, + runPp, ) where -#if MIN_VERSION_ghc(8,10,0) -import LinkerTypes -#endif +import GHC hiding (HasSrcSpan, ModLocation, getLoc, + lookupName, RealSrcSpan) +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.Env +import Development.IDE.GHC.Compat.Iface +import Development.IDE.GHC.Compat.Logger +import Development.IDE.GHC.Compat.Outputable +import Development.IDE.GHC.Compat.Parser +import Development.IDE.GHC.Compat.Plugins +import Development.IDE.GHC.Compat.Units +import Development.IDE.GHC.Compat.Util -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 Module (unitString) -import qualified SrcLoc +#if MIN_VERSION_ghc(9,0,0) +import GHC.Data.StringBuffer +import GHC.Driver.Session hiding (ExposePackage) +#if MIN_VERSION_ghc(9,2,0) +import GHC.Driver.Env as Env +import GHC.Unit.Module.ModIface #else -import Module (InstalledUnitId, - UnitId (DefiniteUnitId), - toInstalledUnitId) -import TcType (pprSigmaType) +import GHC.Driver.Types #endif -import Compat.HieAst (enrichHie) -import Compat.HieBin -import Compat.HieTypes -import Compat.HieUtils -import qualified Data.ByteString as BS -import Data.IORef -import HscTypes -import MkIface -import NameCache -import Packages -import TcRnTypes - -#if MIN_VERSION_ghc(8,10,0) -import GHC.Hs.Extension +import GHC.Iface.Env +import GHC.Iface.Make (mkIfaceExports) +import qualified GHC.SysTools.Tasks as SysTools +import qualified GHC.Types.Avail as Avail #else -import HsExtension -#endif +import DynFlags hiding (ExposePackage) +import HscTypes +import MkIface hiding (writeIfaceFile) +import qualified Avail -import Avail -import GHC hiding (HasSrcSpan, ModLocation, getLoc, - lookupName) -import qualified GHC -import qualified TyCoRep #if MIN_VERSION_ghc(8,8,0) -import Data.List (foldl') -#else -import Data.List (foldl', isSuffixOf) +import StringBuffer (hPutStringBuffer) #endif - -import qualified Data.Map as M -import DynamicLoading -import Plugins (Plugin (parsedResultAction), - withPlugins) +import qualified SysTools #if !MIN_VERSION_ghc(8,8,0) import SrcLoc (RealLocated) -import System.FilePath ((-<.>)) -#endif - -#if !MIN_VERSION_ghc(8,8,0) import qualified EnumSet import Foreign.ForeignPtr import System.IO +#endif +#endif + +import Compat.HieAst (enrichHie) +import Compat.HieBin +import Compat.HieTypes +import Compat.HieUtils +import qualified Data.ByteString as BS +import Data.IORef + +import qualified Data.Map as Map +import Data.List (foldl') +#if MIN_VERSION_ghc(9,0,0) +import qualified Data.Set as S +#endif +#if !MIN_VERSION_ghc(8,8,0) hPutStringBuffer :: Handle -> StringBuffer -> IO () hPutStringBuffer hdl (StringBuffer buf len cur) = withForeignPtr (plusForeignPtr buf cur) $ \ptr -> hPutBuf hdl ptr len - -#endif - -#if !MIN_VERSION_ghc(8,10,0) -noExtField :: NoExt -noExtField = noExt #endif supportsHieFiles :: Bool @@ -224,28 +128,20 @@ supportsHieFiles = True hieExportNames :: HieFile -> [(SrcSpan, Name)] hieExportNames = nameListFromAvails . hie_exports -#if !MIN_VERSION_ghc(8,8,0) -ml_hie_file :: GHC.ModLocation -> FilePath -ml_hie_file ml - | "boot" `isSuffixOf ` ml_hi_file ml = ml_hi_file ml -<.> ".hie-boot" - | otherwise = ml_hi_file ml -<.> ".hie" -#endif - upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c -#if !MIN_VERSION_ghc(8,8,0) +#if MIN_VERSION_ghc(8,8,0) +upNameCache = updNameCache +#else upNameCache ref upd_fn = atomicModifyIORef' ref upd_fn -#else -upNameCache = updNameCache #endif - #if !MIN_VERSION_ghc(9,0,1) -type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)] +type RefMap a = Map.Map Identifier [(Span, IdentifierDetails a)] #endif mkHieFile' :: ModSummary - -> [AvailInfo] + -> [Avail.AvailInfo] -> HieASTs Type -> BS.ByteString -> Hsc HieFile @@ -266,15 +162,6 @@ addIncludePathsQuote :: FilePath -> DynFlags -> DynFlags addIncludePathsQuote path x = x{includePaths = f $ includePaths x} where f i = i{includePathsQuote = path : includePathsQuote i} -pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation -#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 - setHieDir :: FilePath -> DynFlags -> DynFlags setHieDir _f d = #if MIN_VERSION_ghc(8,8,0) @@ -312,45 +199,10 @@ setUpTypedHoles df } -nameListFromAvails :: [AvailInfo] -> [(SrcSpan, Name)] +nameListFromAvails :: [Avail.AvailInfo] -> [(SrcSpan, Name)] nameListFromAvails as = - map (\n -> (nameSrcSpan n, n)) (concatMap availNames as) - -#if MIN_VERSION_ghc(9,0,0) --- type HasSrcSpan x a = (GenLocated SrcSpan a ~ x) --- type HasSrcSpan x = () :: Constraint + map (\n -> (nameSrcSpan n, n)) (concatMap Avail.availNames as) -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 - -#else - -class HasSrcSpan a where - getLoc :: a -> SrcSpan -instance HasSrcSpan Name where - getLoc = nameSrcSpan -instance HasSrcSpan (GenLocated SrcSpan a) where - getLoc = GHC.getLoc - --- | Add the @-boot@ suffix to all output file paths associated with the --- module, not including the input file itself -addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation -addBootSuffixLocnOut locn - = locn { ml_hi_file = Module.addBootSuffix (ml_hi_file locn) - , ml_obj_file = Module.addBootSuffix (ml_obj_file locn) - } -#endif getModuleHash :: ModIface -> Fingerprint #if MIN_VERSION_ghc(8,10,0) @@ -359,137 +211,6 @@ getModuleHash = mi_mod_hash . mi_final_exts getModuleHash = mi_mod_hash #endif --- 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 = @@ -499,40 +220,6 @@ 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 -applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do - -- Apply parsedResultAction of plugins - let applyPluginAction p opts = parsedResultAction p opts ms - fmap hpm_module $ - runHsc env $ withPlugins dflags applyPluginAction - (HsParsedModule parsed [] hpm_annotations) - -pattern ExposePackage :: String -> PackageArg -> ModRenaming -> PackageFlag --- https://github.com/facebook/fbghc -#ifdef __FACEBOOK_HASKELL__ -pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr -#else -pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr -#endif - --- | Take AST representation of type signature and drop `forall` part from it (if any), returning just type's body -dropForAll :: LHsType pass -> LHsType pass -#if MIN_VERSION_ghc(8,10,0) -dropForAll = snd . GHC.splitLHsForAllTyInvis -#else -dropForAll = snd . GHC.splitLHsForAllTy -#endif - -pattern FunTy :: Type -> Type -> Type -#if MIN_VERSION_ghc(8,10,0) -pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} -#else -pattern FunTy arg res <- TyCoRep.FunTy arg res #endif isQualifiedImport :: ImportDecl a -> Bool @@ -547,19 +234,21 @@ isQualifiedImport _ = False #if MIN_VERSION_ghc(9,0,0) -getNodeIds :: HieAST a -> M.Map Identifier (IdentifierDetails a) -getNodeIds = M.foldl' combineNodeIds M.empty . getSourcedNodeInfo . sourcedNodeInfo +getNodeIds :: HieAST a -> Map.Map Identifier (IdentifierDetails a) +getNodeIds = Map.foldl' combineNodeIds Map.empty . getSourcedNodeInfo . sourcedNodeInfo -ad `combineNodeIds` (NodeInfo _ _ bd) = M.unionWith (<>) ad bd +combineNodeIds :: Map.Map Identifier (IdentifierDetails a) + -> NodeInfo a -> Map.Map Identifier (IdentifierDetails a) +ad `combineNodeIds` (NodeInfo _ _ bd) = Map.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 +nodeInfo' = Map.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) + NodeInfo (S.union as bs) (mergeSorted ai bi) (Map.unionWith (<>) ad bd) where mergeSorted :: Ord a => [a] -> [a] -> [a] mergeSorted la@(a:as) lb@(b:bs) = case compare a b of @@ -569,10 +258,9 @@ combineNodeInfo' :: Ord a => NodeInfo a -> NodeInfo a -> NodeInfo a mergeSorted as [] = as mergeSorted [] bs = bs -stringToUnit = Module.stringToUnit -rtsUnit = Module.rtsUnit #else +getNodeIds :: HieAST a -> NodeIdentifiers a getNodeIds = nodeIdentifiers . nodeInfo -- import qualified FastString as FS @@ -580,15 +268,10 @@ getNodeIds = nodeIdentifiers . nodeInfo nodeInfo' :: Ord a => HieAST a -> NodeInfo a nodeInfo' = nodeInfo -- type Unit = UnitId -unitString :: Unit -> String -unitString = Module.unitIdString -stringToUnit :: String -> Unit -stringToUnit = Module.stringToUnitId -- moduleUnit :: Module -> Unit -- moduleUnit = moduleUnitId -- unhelpfulSpanFS :: FS.FastString -> FS.FastString -- unhelpfulSpanFS = id -rtsUnit = Module.rtsUnitId #endif data GhcVersion @@ -596,13 +279,16 @@ data GhcVersion | GHC88 | GHC810 | GHC90 + | GHC92 deriving (Eq, Ord, Show) ghcVersionStr :: String ghcVersionStr = VERSION_ghc ghcVersion :: GhcVersion -#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +#if MIN_VERSION_GLASGOW_HASKELL(9,2,0,0) +ghcVersion = GHC92 +#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) ghcVersion = GHC90 #elif MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) ghcVersion = GHC810 @@ -611,3 +297,19 @@ ghcVersion = GHC88 #elif MIN_VERSION_GLASGOW_HASKELL(8,6,0,0) ghcVersion = GHC86 #endif + +runUnlit :: Logger -> DynFlags -> [Option] -> IO () +runUnlit = +#if MIN_VERSION_ghc(9,2,0) + SysTools.runUnlit +#else + const SysTools.runUnlit +#endif + +runPp :: Logger -> DynFlags -> [Option] -> IO () +runPp = +#if MIN_VERSION_ghc(9,2,0) + SysTools.runPp +#else + const SysTools.runPp +#endif diff --git a/ghcide/src/Development/IDE/GHC/Compat/CPP.hs b/ghcide/src/Development/IDE/GHC/Compat/CPP.hs new file mode 100644 index 0000000000..855e66e5ff --- /dev/null +++ b/ghcide/src/Development/IDE/GHC/Compat/CPP.hs @@ -0,0 +1,204 @@ +-- Copyright (c) 2019 The DAML Authors. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +-- Copied from https://github.com/ghc/ghc/blob/master/compiler/main/DriverPipeline.hs on 14 May 2019 +-- Requested to be exposed at https://gitlab.haskell.org/ghc/ghc/merge_requests/944. +-- Update the above MR got merged to master on 31 May 2019. When it becomes avialable to ghc-lib, this file can be removed. + +{- HLINT ignore -} -- since copied from upstream + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +-- | Re-export 'doCpp' for GHC < 8.10. +-- +-- Later versions export what we need. +module Development.IDE.GHC.Compat.CPP ( + doCpp + ) where + +import FileCleanup +import Packages +import Panic +import SysTools +#if MIN_VERSION_ghc(8,8,2) +import LlvmCodeGen (llvmVersionList) +#elif MIN_VERSION_ghc(8,8,0) +import LlvmCodeGen (LlvmVersion (..)) +#endif +import DynFlags +import Module (toInstalledUnitId, rtsUnitId) +import Control.Monad +import Data.List (intercalate) +import Data.Maybe +import Data.Version +import System.Directory +import System.FilePath +import System.Info + +import Development.IDE.GHC.Compat as Compat + +doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () +doCpp dflags raw input_fn output_fn = do + let hscpp_opts = picPOpts dflags + let cmdline_include_paths = includePaths dflags + + pkg_include_dirs <- getPackageIncludePath dflags [] + let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] + (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs) + let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] + (includePathsQuote cmdline_include_paths) + let include_paths = include_paths_quote ++ include_paths_global + + let verbFlags = getVerbFlags dflags + + let cpp_prog args | raw = SysTools.runCpp dflags args +#if MIN_VERSION_ghc(8,10,0) + | otherwise = SysTools.runCc Nothing +#else + | otherwise = SysTools.runCc +#endif + dflags (SysTools.Option "-E" : args) + + let target_defs = + -- NEIL: Patched to use System.Info instead of constants from CPP + [ "-D" ++ os ++ "_BUILD_OS", + "-D" ++ arch ++ "_BUILD_ARCH", + "-D" ++ os ++ "_HOST_OS", + "-D" ++ arch ++ "_HOST_ARCH" ] + -- remember, in code we *compile*, the HOST is the same our TARGET, + -- and BUILD is the same as our HOST. + + let sse_defs = + [ "-D__SSE__" | isSseEnabled dflags ] ++ + [ "-D__SSE2__" | isSse2Enabled dflags ] ++ + [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] + + let avx_defs = + [ "-D__AVX__" | isAvxEnabled dflags ] ++ + [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ + [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ + [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ + [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ + [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] + + backend_defs <- getBackendDefs dflags + + let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] + -- Default CPP defines in Haskell source + ghcVersionH <- getGhcVersionPathName dflags + let hsSourceCppOpts = [ "-include", ghcVersionH ] + + -- MIN_VERSION macros + let uids = explicitPackages (pkgState dflags) + pkgs = catMaybes (map (lookupPackage dflags) uids) + mb_macro_include <- + if not (null pkgs) && gopt Opt_VersionMacros dflags + then do macro_stub <- newTempName dflags TFL_CurrentModule "h" + writeFile macro_stub (generatePackageVersionMacros pkgs) + -- Include version macros for every *exposed* package. + -- Without -hide-all-packages and with a package database + -- size of 1000 packages, it takes cpp an estimated 2 + -- milliseconds to process this file. See #10970 + -- comment 8. + return [SysTools.FileOption "-include" macro_stub] + else return [] + + cpp_prog ( map SysTools.Option verbFlags + ++ map SysTools.Option include_paths + ++ map SysTools.Option hsSourceCppOpts + ++ map SysTools.Option target_defs + ++ map SysTools.Option backend_defs + ++ map SysTools.Option th_defs + ++ map SysTools.Option hscpp_opts + ++ map SysTools.Option sse_defs + ++ map SysTools.Option avx_defs + ++ mb_macro_include + -- Set the language mode to assembler-with-cpp when preprocessing. This + -- alleviates some of the C99 macro rules relating to whitespace and the hash + -- operator, which we tend to abuse. Clang in particular is not very happy + -- about this. + ++ [ SysTools.Option "-x" + , SysTools.Option "assembler-with-cpp" + , SysTools.Option input_fn + -- We hackily use Option instead of FileOption here, so that the file + -- name is not back-slashed on Windows. cpp is capable of + -- dealing with / in filenames, so it works fine. Furthermore + -- if we put in backslashes, cpp outputs #line directives + -- with *double* backslashes. And that in turn means that + -- our error messages get double backslashes in them. + -- In due course we should arrange that the lexer deals + -- with these \\ escapes properly. + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ]) + +getBackendDefs :: DynFlags -> IO [String] +getBackendDefs dflags | hscTarget dflags == HscLlvm = do + llvmVer <- figureLlvmVersion dflags + return $ case llvmVer of +#if MIN_VERSION_ghc(8,8,2) + Just v + | [m] <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, 0) ] + | m:n:_ <- llvmVersionList v -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m, n) ] +#elif MIN_VERSION_ghc(8,8,0) + Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ] + Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] +#else + Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ] +#endif + _ -> [] + where + format (major, minor) + | minor >= 100 = error "getBackendDefs: Unsupported minor version" + | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int + +getBackendDefs _ = + return [] + +-- --------------------------------------------------------------------------- +-- Macros (cribbed from Cabal) + +generatePackageVersionMacros :: [Compat.UnitInfo] -> String +generatePackageVersionMacros pkgs = concat + -- Do not add any C-style comments. See #3389. + [ generateMacros "" pkgname version + | pkg <- pkgs + , let version = packageVersion pkg + pkgname = map fixchar (packageNameString pkg) + ] + +fixchar :: Char -> Char +fixchar '-' = '_' +fixchar c = c + +generateMacros :: String -> String -> Version -> String +generateMacros prefix name version = + concat + ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" + ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + where + (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) + + +-- | Find out path to @ghcversion.h@ file +getGhcVersionPathName :: DynFlags -> IO FilePath +getGhcVersionPathName dflags = do + candidates <- case ghcVersionFile dflags of + Just path -> return [path] + Nothing -> (map ( "ghcversion.h")) <$> + (getPackageIncludePath dflags [toInstalledUnitId rtsUnit]) + + found <- filterM doesFileExist candidates + case found of + [] -> throwGhcExceptionIO (InstallationError + ("ghcversion.h missing; tried: " + ++ intercalate ", " candidates)) + (x:_) -> return x + +rtsUnit :: UnitId +rtsUnit = Module.rtsUnitId diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs new file mode 100644 index 0000000000..b2f560e9c3 --- /dev/null +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -0,0 +1,848 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} +-- TODO: remove +{-# OPTIONS -Wno-dodgy-imports -Wno-unused-imports #-} + +-- | Compat Core module that handles the GHC module hierarchy re-organisation +-- by re-exporting everything we care about. +-- +-- This module provides no other compat mechanisms, except for simple +-- backward-compatible pattern synonyms. +module Development.IDE.GHC.Compat.Core ( + -- * Session + DynFlags, + extensions, + extensionFlags, + targetPlatform, + packageFlags, + generalFlags, + warningFlags, + topDir, + hiDir, + tmpDir, + importPaths, + useColor, + canUseColor, + useUnicode, + objectDir, + flagsForCompletion, + setImportPaths, + outputFile, + pluginModNames, + refLevelHoleFits, + maxRefHoleFits, + maxValidHoleFits, +#if MIN_VERSION_ghc(8,8,0) + CommandLineOption, +#if !MIN_VERSION_ghc(9,2,0) + staticPlugins, +#endif +#endif + sPgm_F, + settings, + gopt, + gopt_set, + gopt_unset, + wopt, + wopt_set, + xFlags, + xopt, + xopt_unset, + xopt_set, + FlagSpec(..), + WarningFlag(..), + GeneralFlag(..), + PackageFlag, + PackageArg(..), + ModRenaming(..), + pattern ExposePackage, + parseDynamicFlagsCmdLine, + parseDynamicFilePragma, + WarnReason(..), + wWarningFlags, + updOptLevel, + -- slightly unsafe + setUnsafeGlobalDynFlags, + -- * Linear Haskell + Scaled, + scaledThing, + -- * Interface Files + IfaceExport, + IfaceTyCon(..), +#if MIN_VERSION_ghc(8,10,0) + ModIface, + ModIface_(..), +#else + ModIface(..), +#endif + HscSource(..), + WhereFrom(..), + loadInterface, + SourceModified(..), + loadModuleInterface, + RecompileRequired(..), +#if MIN_VERSION_ghc(8,10,0) + mkPartialIface, + mkFullIface, +#else + mkIface, +#endif + checkOldIface, +#if MIN_VERSION_ghc(9,0,0) + IsBootInterface(..), +#else + pattern IsBoot, + pattern NotBoot, +#endif + -- * Fixity + LexicalFixity(..), + -- * ModSummary + ModSummary(..), + -- * HomeModInfo + HomeModInfo(..), + -- * ModGuts + ModGuts(..), + CgGuts(..), + -- * ModDetails + ModDetails(..), + -- * Var + Type ( + TyCoRep.TyVarTy, + TyCoRep.AppTy, + TyCoRep.TyConApp, + TyCoRep.ForAllTy, + -- Omitted on purpose + -- pattern Synonym right below it + -- TyCoRep.FunTy, + TyCoRep.LitTy, + TyCoRep.CastTy, + TyCoRep.CoercionTy + ), + pattern FunTy, + Development.IDE.GHC.Compat.Core.splitForAllTyCoVars, + Development.IDE.GHC.Compat.Core.mkVisFunTys, + Development.IDE.GHC.Compat.Core.mkInfForAllTys, + -- * Specs + ImpDeclSpec(..), + ImportSpec(..), + -- * SourceText + SourceText(..), + -- * Name + tyThingParent_maybe, + -- * Ways + Way, + wayGeneralFlags, + wayUnsetGeneralFlags, + -- * AvailInfo + Avail.AvailInfo, + pattern AvailName, + pattern AvailFL, + pattern AvailTC, + Avail.availName, + Avail.availNames, + Avail.availNamesWithSelectors, + Avail.availsToNameSet, + -- * TcGblEnv + TcGblEnv(..), + -- * Parsing and LExer types + HsParsedModule(..), + GHC.ParsedModule(..), + GHC.ParsedSource, + GHC.RenamedSource, + -- * Compilation Main + HscEnv, + GHC.runGhc, + unGhc, + Session(..), + modifySession, + getSession, + GHC.setSessionDynFlags, + getSessionDynFlags, + GhcMonad, + Ghc, + runHsc, + compileFile, + Phase(..), + hscDesugar, + hscGenHardCode, + hscInteractive, + hscSimplify, + hscTypecheckRename, + makeSimpleDetails, + -- * Typecheck utils + Development.IDE.GHC.Compat.Core.tcSplitForAllTyVars, + Development.IDE.GHC.Compat.Core.tcSplitForAllTyVarBinder_maybe, + typecheckIface, + mkIfaceTc, + ImportedModsVal(..), + importedByUser, + GHC.TypecheckedSource, + -- * Source Locations + HasSrcSpan, + SrcLoc.Located, + SrcLoc.unLoc, + getLoc, + SrcLoc.RealLocated, + SrcLoc.GenLocated(..), + SrcLoc.SrcSpan(SrcLoc.UnhelpfulSpan), + SrcLoc.RealSrcSpan, + pattern RealSrcSpan, + SrcLoc.RealSrcLoc, + SrcLoc.SrcLoc(..), + BufSpan, + SrcLoc.leftmost_smallest, + SrcLoc.containsSpan, + SrcLoc.mkGeneralSrcSpan, + SrcLoc.mkRealSrcSpan, + SrcLoc.mkRealSrcLoc, + getRealSrcSpan, + SrcLoc.realSrcLocSpan, + SrcLoc.realSrcSpanStart, + SrcLoc.realSrcSpanEnd, + SrcLoc.isSubspanOf, + SrcLoc.wiredInSrcSpan, + SrcLoc.mkSrcSpan, + SrcLoc.srcSpanStart, + SrcLoc.srcSpanStartLine, + SrcLoc.srcSpanStartCol, + SrcLoc.srcSpanEnd, + SrcLoc.srcSpanEndLine, + SrcLoc.srcSpanEndCol, + SrcLoc.srcSpanFile, + SrcLoc.srcLocCol, + SrcLoc.srcLocFile, + SrcLoc.srcLocLine, + SrcLoc.noSrcSpan, + SrcLoc.noSrcLoc, + SrcLoc.noLoc, +#if !MIN_VERSION_ghc(8,10,0) && MIN_VERSION_ghc(8,8,0) + SrcLoc.dL, +#endif + -- * Finder + FindResult(..), + mkHomeModLocation, + addBootSuffixLocnOut, + findObjectLinkableMaybe, + InstalledFindResult(..), + -- * Module and Package + ModuleOrigin(..), + PackageName(..), + -- * Linker + Unlinked(..), + Linkable(..), + unload, + initDynLinker, + -- * Hooks + Hooks, + runMetaHook, + MetaHook, + MetaRequest(..), + metaRequestE, + metaRequestP, + metaRequestT, + metaRequestD, + metaRequestAW, + -- * HPT + addToHpt, + addListToHpt, + -- * Driver-Make + Target(..), + TargetId(..), + mkModuleGraph, + -- * GHCi + initObjLinker, + loadDLL, + InteractiveImport(..), + GHC.getContext, + GHC.setContext, + GHC.parseImportDecl, + GHC.runDecls, + Warn(..), + -- * ModLocation + GHC.ModLocation, + pattern ModLocation, + Module.ml_hs_file, + Module.ml_obj_file, + Module.ml_hi_file, + Development.IDE.GHC.Compat.Core.ml_hie_file, + -- * DataCon + Development.IDE.GHC.Compat.Core.dataConExTyCoVars, + -- * Role + Role(..), + -- * Panic + PlainGhcException, + panic, + -- * Util Module re-exports +#if MIN_VERSION_ghc(9,0,0) + module GHC.Builtin.Names, + module GHC.Builtin.Types, + module GHC.Builtin.Types.Prim, + module GHC.Builtin.Utils, + module GHC.Core.Class, + module GHC.Core.Coercion, + module GHC.Core.ConLike, + module GHC.Core.DataCon, + module GHC.Core.FamInstEnv, + module GHC.Core.InstEnv, +#if !MIN_VERSION_ghc(9,2,0) + module GHC.Core.Ppr.TyThing, +#endif + module GHC.Core.PatSyn, + module GHC.Core.Predicate, + module GHC.Core.TyCon, + module GHC.Core.TyCo.Ppr, + module GHC.Core.Type, + module GHC.Core.Unify, + module GHC.Core.Utils, + + module GHC.HsToCore.Docs, + module GHC.HsToCore.Expr, + module GHC.HsToCore.Monad, + + module GHC.Iface.Tidy, + module GHC.Iface.Syntax, + +#if MIN_VERSION_ghc(9,2,0) + module Language.Haskell.Syntax.Expr, +#endif + + module GHC.Rename.Names, + module GHC.Rename.Splice, + + module GHC.Tc.Instance.Family, + module GHC.Tc.Module, + module GHC.Tc.Types, + module GHC.Tc.Types.Evidence, + module GHC.Tc.Utils.Env, + module GHC.Tc.Utils.Monad, + + module GHC.Types.Basic, + module GHC.Types.Id, + module GHC.Types.Name , + module GHC.Types.Name.Set, + + module GHC.Types.Name.Cache, + module GHC.Types.Name.Env, + module GHC.Types.Name.Reader, +#if MIN_VERSION_ghc(9,2,0) + module GHC.Types.SourceFile, + module GHC.Types.SourceText, + module GHC.Types.TyThing, + module GHC.Types.TyThing.Ppr, +#endif + module GHC.Types.Unique.Supply, + module GHC.Types.Var, + module GHC.Unit.Module, + module GHC.Utils.Error, +#else + module BasicTypes, + module Class, +#if MIN_VERSION_ghc(8,10,0) + module Coercion, + module Predicate, +#endif + module ConLike, + module CoreUtils, + module DataCon, + module DsExpr, + module DsMonad, + module ErrUtils, + module FamInst, + module FamInstEnv, + module HeaderInfo, + module Id, + module InstEnv, + module IfaceSyn, + module Module, + module Name, + module NameCache, + module NameEnv, + module NameSet, + module PatSyn, + module PprTyThing, + module PrelInfo, + module PrelNames, + module RdrName, + module RnSplice, + module RnNames, + module TcEnv, + module TcEvidence, + module TcType, + module TcRnTypes, + module TcRnDriver, + module TcRnMonad, + module TidyPgm, + module TyCon, + module TysPrim, + module TysWiredIn, + module Type, + module Unify, + module UniqSupply, + module Var, +#endif + -- * Syntax re-exports +#if MIN_VERSION_ghc(9,0,0) + module GHC.Hs, + module GHC.Parser, + module GHC.Parser.Header, + module GHC.Parser.Lexer, +#else +#if MIN_VERSION_ghc(8,10,0) + module GHC.Hs, +#else + module HsBinds, + module HsDecls, + module HsDoc, + module HsExtension, + noExtField, + module HsExpr, + module HsImpExp, + module HsLit, + module HsPat, + module HsSyn, + module HsTypes, + module HsUtils, +#endif + module ExtractDocs, + module Parser, + module Lexer, +#endif + ) where + +import qualified GHC + +#if MIN_VERSION_ghc(9,0,0) +import GHC.Builtin.Names hiding (Unique, printName) +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Builtin.Utils +import GHC.Core.Class +import GHC.Core.Coercion +import GHC.Core.ConLike +import GHC.Core.DataCon hiding (dataConExTyCoVars) +import qualified GHC.Core.DataCon as DataCon +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv +#if MIN_VERSION_ghc(9,2,0) +import GHC.Core.Multiplicity (scaledThing) +#else +import GHC.Core.Ppr.TyThing hiding (pprFamInst) +import GHC.Core.TyCo.Rep (scaledThing) +#endif +import GHC.Core.PatSyn +import GHC.Core.Predicate +import GHC.Core.TyCo.Ppr +import qualified GHC.Core.TyCo.Rep as TyCoRep +import GHC.Core.TyCon +import GHC.Core.Type hiding (mkInfForAllTys, mkVisFunTys) +import GHC.Core.Unify +import GHC.Core.Utils + +#if MIN_VERSION_ghc(9,2,0) +import GHC.Driver.Env +#else +import GHC.Driver.Finder +import GHC.Driver.Types +import GHC.Driver.Ways +#endif +import GHC.Driver.CmdLine (Warn (..)) +import GHC.Driver.Hooks +import GHC.Driver.Main +import GHC.Driver.Monad +import GHC.Driver.Phases +import GHC.Driver.Pipeline +import GHC.Driver.Plugins +import GHC.Driver.Session hiding (ExposePackage) +import qualified GHC.Driver.Session as DynFlags +#if !MIN_VERSION_ghc(9,2,0) +import GHC.Hs +#endif +import GHC.HsToCore.Docs +import GHC.HsToCore.Expr +import GHC.HsToCore.Monad +import GHC.Iface.Load +import GHC.Iface.Make (mkFullIface, mkIfaceTc, + mkPartialIface) +import GHC.Iface.Recomp +import GHC.Iface.Syntax +import GHC.Iface.Tidy +import GHC.IfaceToCore +import GHC.Parser +import GHC.Parser.Header hiding (getImports) +import GHC.Parser.Lexer +#if MIN_VERSION_ghc(9,2,0) +import GHC.Linker.Loader +import GHC.Linker.Types +import GHC.Platform.Ways +#else +import GHC.Runtime.Linker +#endif +import GHC.Rename.Names +import GHC.Rename.Splice +import GHC.Runtime.Interpreter +import GHC.Tc.Instance.Family +import GHC.Tc.Module +import GHC.Tc.Types +import GHC.Tc.Types.Evidence hiding ((<.>)) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad hiding (Applicative (..), IORef, + MonadFix (..), MonadIO (..), allM, + anyM, concatMapM, mapMaybeM, (<$>)) +import GHC.Tc.Utils.TcType as TcType +import qualified GHC.Types.Avail as Avail +#if MIN_VERSION_ghc(9,2,0) +import GHC.Types.Meta +#endif +import GHC.Types.Basic +import GHC.Types.Id +import GHC.Types.Name hiding (varName) +import GHC.Types.Name.Cache +import GHC.Types.Name.Env +import GHC.Types.Name.Reader +#if MIN_VERSION_ghc(9,2,0) +import GHC.Types.Name.Set +import GHC.Types.SourceFile (HscSource (..), + SourceModified (..)) +import GHC.Types.SourceText +import GHC.Types.TyThing +import GHC.Types.TyThing.Ppr +#else +import GHC.Types.Name.Set +#endif +import GHC.Types.SrcLoc (BufSpan, SrcSpan (UnhelpfulSpan)) +import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Unique.Supply +import GHC.Types.Var (Var (varName), setTyVarUnique, + setVarUnique) +#if MIN_VERSION_ghc(9,2,0) +import GHC.Unit.Finder +import GHC.Unit.Home.ModInfo +#endif +import GHC.Unit.Info (PackageName (..)) +import GHC.Unit.Module hiding (ModLocation (..), UnitId, + addBootSuffixLocnOut, moduleUnit, + toUnitId) +import qualified GHC.Unit.Module as Module +#if MIN_VERSION_ghc(9,2,0) +import GHC.Unit.Module.Imported +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModIface (IfaceExport) +#endif +import GHC.Unit.State (ModuleOrigin (..)) +import GHC.Utils.Error (Severity (..)) +import GHC.Utils.Panic hiding (try) +import qualified GHC.Utils.Panic.Plain as Plain +#else +import qualified Avail +import BasicTypes hiding (Version) +import Class +import CmdLineParser (Warn (..)) +import ConLike +import CoreUtils +import DataCon hiding (dataConExTyCoVars) +import qualified DataCon +import DriverPhases +import DriverPipeline +import DsExpr +import DsMonad hiding (foldrM) +import DynFlags hiding (ExposePackage) +import qualified DynFlags +import ErrUtils hiding (logInfo, mkWarnMsg) +import ExtractDocs +import FamInst +import FamInstEnv +import Finder +#if MIN_VERSION_ghc(8,10,0) +import GHC.Hs +#endif +import GHCi +import GhcMonad +import HeaderInfo hiding (getImports) +import Hooks +import HscMain +import HscTypes +#if !MIN_VERSION_ghc(8,10,0) +-- Syntax imports +import HsBinds +import HsDecls +import HsDoc +import HsExpr +import HsExtension +import HsImpExp +import HsLit +import HsPat +import HsSyn hiding (wildCardName) +import HsTypes hiding (wildCardName) +import HsUtils +#endif +import Id +import IfaceSyn +import InstEnv +import Lexer hiding (getSrcLoc) +import Linker +import LoadIface +import MkIface +import Module hiding (ModLocation (..), UnitId, + addBootSuffixLocnOut, moduleUnitId) +import qualified Module +import Name hiding (varName) +import NameCache +import NameEnv +import NameSet +import Packages +#if MIN_VERSION_ghc(8,8,0) +import Panic hiding (try) +import qualified PlainPanic as Plain +#else +import Panic hiding (GhcException, try) +import qualified Panic as Plain +#endif +import Parser +import PatSyn +#if MIN_VERSION_ghc(8,8,0) +import Plugins +#endif +import PprTyThing hiding (pprFamInst) +import PrelInfo +import PrelNames hiding (Unique, printName) +import RdrName +import RnNames +import RnSplice +import qualified SrcLoc +import TcEnv +import TcEvidence hiding ((<.>)) +import TcIface +import TcRnDriver +import TcRnMonad hiding (Applicative (..), IORef, + MonadFix (..), MonadIO (..), allM, + anyM, concatMapM, foldrM, + mapMaybeM, (<$>)) +import TcRnTypes +import TcType hiding (mkVisFunTys) +import qualified TcType +import TidyPgm +import qualified TyCoRep +import TyCon +import Type hiding (mkVisFunTys) +import TysPrim +import TysWiredIn +import Unify +import UniqSupply +import Var (Var (varName), setTyVarUnique, + setVarUnique, varType) + +#if MIN_VERSION_ghc(8,10,0) +import Coercion (coercionKind) +import Predicate +import SrcLoc (SrcSpan (UnhelpfulSpan)) +#else +import SrcLoc (RealLocated, + SrcSpan (UnhelpfulSpan)) +#endif +#endif + +#if !MIN_VERSION_ghc(8,8,0) +import Data.List (isSuffixOf) +import System.FilePath +#endif + +#if !MIN_VERSION_ghc(9,0,0) +type BufSpan = () +#endif + +pattern RealSrcSpan :: SrcLoc.RealSrcSpan -> Maybe BufSpan -> SrcLoc.SrcSpan +#if MIN_VERSION_ghc(9,0,0) +pattern RealSrcSpan x y = SrcLoc.RealSrcSpan x y +#else +pattern RealSrcSpan x y <- ((,Nothing) -> (SrcLoc.RealSrcSpan x, y)) where + RealSrcSpan x _ = SrcLoc.RealSrcSpan x +#endif +{-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} + + +pattern AvailTC :: Name -> [Name] -> [FieldLabel] -> Avail.AvailInfo +#if __GLASGOW_HASKELL__ >= 902 +pattern AvailTC n names pieces <- Avail.AvailTC n ((\gres -> foldr (\gre (names, pieces) -> case gre of + Avail.NormalGreName name -> (name: names, pieces) + Avail.FieldGreName label -> (names, label:pieces)) ([], []) gres) -> (names, pieces)) +#else +pattern AvailTC n names pieces <- Avail.AvailTC n names pieces +#endif + +pattern AvailName :: Name -> Avail.AvailInfo +#if __GLASGOW_HASKELL__ >= 902 +pattern AvailName n <- Avail.Avail (Avail.NormalGreName n) +#else +pattern AvailName n <- Avail.Avail n +#endif + +pattern AvailFL :: FieldLabel -> Avail.AvailInfo +#if __GLASGOW_HASKELL__ >= 902 +pattern AvailFL fl <- Avail.Avail (Avail.FieldGreName fl) +#else +-- pattern synonym that is never populated +pattern AvailFL x <- Avail.Avail (const (True, undefined) -> (False, x)) +#endif + +{-# COMPLETE AvailTC, AvailName, AvailFL #-} + +setImportPaths :: [FilePath] -> DynFlags -> DynFlags +setImportPaths importPaths flags = flags { importPaths = importPaths } + +pattern ExposePackage :: String -> PackageArg -> ModRenaming -> PackageFlag +-- https://github.com/facebook/fbghc +#ifdef __FACEBOOK_HASKELL__ +pattern ExposePackage s a mr <- DynFlags.ExposePackage s a _ mr +#else +pattern ExposePackage s a mr = DynFlags.ExposePackage s a mr +#endif + +pattern FunTy :: Type -> Type -> Type +#if MIN_VERSION_ghc(8,10,0) +pattern FunTy arg res <- TyCoRep.FunTy {ft_arg = arg, ft_res = res} +#else +pattern FunTy arg res <- TyCoRep.FunTy arg res +#endif + +#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 (SrcLoc.GenLocated SrcSpan a) where + getLoc = GHC.getLoc + +-- getLoc :: GenLocated l a -> l +-- getLoc = GHC.getLoc + +#elif MIN_VERSION_ghc(8,8,0) +type HasSrcSpan = SrcLoc.HasSrcSpan +getLoc :: SrcLoc.HasSrcSpan a => a -> SrcLoc.SrcSpan +getLoc = SrcLoc.getLoc + +#else + +class HasSrcSpan a where + getLoc :: a -> SrcSpan +instance HasSrcSpan Name where + getLoc = nameSrcSpan +instance HasSrcSpan (SrcLoc.GenLocated SrcSpan a) where + getLoc = SrcLoc.getLoc + +#endif + +getRealSrcSpan :: SrcLoc.RealLocated a -> SrcLoc.RealSrcSpan +#if !MIN_VERSION_ghc(8,8,0) +getRealSrcSpan = SrcLoc.getLoc +#else +getRealSrcSpan = SrcLoc.getRealSrcSpan +#endif + + +-- | Add the @-boot@ suffix to all output file paths associated with the +-- module, not including the input file itself +addBootSuffixLocnOut :: GHC.ModLocation -> GHC.ModLocation +#if !MIN_VERSION_ghc(8,8,0) +addBootSuffixLocnOut locn + = locn { Module.ml_hi_file = Module.addBootSuffix (Module.ml_hi_file locn) + , Module.ml_obj_file = Module.addBootSuffix (Module.ml_obj_file locn) + } +#else +addBootSuffixLocnOut = Module.addBootSuffixLocnOut +#endif + + +dataConExTyCoVars :: DataCon -> [TyCoVar] +#if __GLASGOW_HASKELL__ >= 808 +dataConExTyCoVars = DataCon.dataConExTyCoVars +#else +dataConExTyCoVars = DataCon.dataConExTyVars +#endif + +#if !MIN_VERSION_ghc(9,0,0) +-- Linear Haskell +type Scaled a = a +scaledThing :: Scaled a -> a +scaledThing = id +#endif + +mkVisFunTys :: [Scaled Type] -> Type -> Type +mkVisFunTys = +#if __GLASGOW_HASKELL__ <= 808 + mkFunTys +#else + TcType.mkVisFunTys +#endif + +mkInfForAllTys :: [TyVar] -> Type -> Type +mkInfForAllTys = +#if MIN_VERSION_ghc(9,0,0) + TcType.mkInfForAllTys +#else + mkInvForAllTys +#endif + +splitForAllTyCoVars :: Type -> ([TyCoVar], Type) +splitForAllTyCoVars = +#if MIN_VERSION_ghc(9,2,0) + TcType.splitForAllTyCoVars +#else + splitForAllTys +#endif + +tcSplitForAllTyVars :: Type -> ([TyVar], Type) +tcSplitForAllTyVars = +#if MIN_VERSION_ghc(9,2,0) + TcType.tcSplitForAllTyVars +#else + tcSplitForAllTys +#endif + + +tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (TyVarBinder, Type) +tcSplitForAllTyVarBinder_maybe = +#if MIN_VERSION_ghc(9,2,0) + TcType.tcSplitForAllTyVarBinder_maybe +#else + tcSplitForAllTy_maybe +#endif + +pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> GHC.ModLocation +#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 + +#if !MIN_VERSION_ghc(8,10,0) +noExtField :: GHC.NoExt +noExtField = GHC.noExt +#endif + +ml_hie_file :: GHC.ModLocation -> FilePath +#if !MIN_VERSION_ghc(8,8,0) +ml_hie_file ml + | "boot" `isSuffixOf ` Module.ml_hi_file ml = Module.ml_hi_file ml -<.> ".hie-boot" + | otherwise = Module.ml_hi_file ml -<.> ".hie" +#else +ml_hie_file = Module.ml_hie_file +#endif + +#if !MIN_VERSION_ghc(9,0,0) +pattern NotBoot, IsBoot :: IsBootInterface +pattern NotBoot = False +pattern IsBoot = True +#endif + +#if MIN_VERSION_ghc(8,8,0) +type PlainGhcException = Plain.PlainGhcException +#else +type PlainGhcException = Plain.GhcException +#endif diff --git a/ghcide/src/Development/IDE/GHC/Compat/Env.hs b/ghcide/src/Development/IDE/GHC/Compat/Env.hs new file mode 100644 index 0000000000..2def0e4121 --- /dev/null +++ b/ghcide/src/Development/IDE/GHC/Compat/Env.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE CPP #-} + +-- | Compat module for the main Driver types, such as 'HscEnv', +-- 'UnitEnv' and some DynFlags compat functions. +module Development.IDE.GHC.Compat.Env ( + Env.HscEnv(hsc_FC, hsc_NC, hsc_IC, hsc_mod_graph, hsc_HPT, hsc_type_env_var), + InteractiveContext(..), + setInteractivePrintName, + setInteractiveDynFlags, + Env.hsc_dflags, + hsc_EPS, + hsc_logger, + hsc_tmpfs, + hsc_unit_env, + hsc_hooks, + hscSetHooks, + TmpFs, + -- * HomeUnit + hscHomeUnit, + HomeUnit, + setHomeUnitId_, + Development.IDE.GHC.Compat.Env.mkHomeModule, + -- * Provide backwards Compatible + -- types and helper functions. + Logger(..), + UnitEnv, + hscSetUnitEnv, + hscSetFlags, + initTempFs, + -- * Home Unit + Development.IDE.GHC.Compat.Env.homeUnitId_, + -- * DynFlags Helper + setBytecodeLinkerOptions, + setInterpreterLinkerOptions, + -- * Ways + Ways, + Way, + hostFullWays, + setWays, + wayGeneralFlags, + wayUnsetGeneralFlags, + -- * Backend, backwards compatible + Backend, + setBackend, + Development.IDE.GHC.Compat.Env.platformDefaultBackend, + ) where + +import GHC (setInteractiveDynFlags) + +#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) +import GHC.Driver.Backend as Backend +import GHC.Driver.Env (HscEnv, hsc_EPS) +import qualified GHC.Driver.Env as Env +import qualified GHC.Driver.Session as Session +import GHC.Platform.Ways hiding (hostFullWays) +import qualified GHC.Platform.Ways as Ways +import GHC.Runtime.Context +import GHC.Unit.Env (UnitEnv) +import GHC.Unit.Home as Home +import GHC.Utils.Logger +import GHC.Utils.TmpFs +#else +import qualified GHC.Driver.Session as DynFlags +import GHC.Driver.Types (HscEnv, InteractiveContext (..), hsc_EPS, + setInteractivePrintName) +import qualified GHC.Driver.Types as Env +import GHC.Driver.Ways hiding (hostFullWays) +import qualified GHC.Driver.Ways as Ways +#endif +import GHC.Driver.Hooks (Hooks) +import GHC.Driver.Session hiding (mkHomeModule) +import GHC.Unit.Module.Name +import GHC.Unit.Types (Module, Unit, UnitId, mkModule) +#else +import DynFlags +import Hooks +import HscTypes as Env +import Module +#endif + +#if MIN_VERSION_ghc(9,0,0) +import qualified Data.Set as Set +#endif +#if !MIN_VERSION_ghc(9,2,0) +import Data.IORef +#endif + +#if !MIN_VERSION_ghc(9,2,0) +type UnitEnv = () +newtype Logger = Logger { log_action :: LogAction } +type TmpFs = () +#endif + +setHomeUnitId_ :: UnitId -> DynFlags -> DynFlags +#if MIN_VERSION_ghc(9,2,0) +setHomeUnitId_ uid df = df { Session.homeUnitId_ = uid } +#elif MIN_VERSION_ghc(9,0,0) +setHomeUnitId_ uid df = df { homeUnitId = uid } +#else +setHomeUnitId_ uid df = df { thisInstalledUnitId = toInstalledUnitId uid } +#endif + +hscSetFlags :: DynFlags -> HscEnv -> HscEnv +hscSetFlags df env = +#if MIN_VERSION_ghc(9,2,0) + hscSetFlags df env +#else + env { Env.hsc_dflags = df } +#endif + +initTempFs :: HscEnv -> IO HscEnv +initTempFs env = do +#if MIN_VERSION_ghc(9,2,0) + tmpFs <- initTmpFs + pure env { Env.hsc_tmpfs = tmpFs } +#else + filesToClean <- newIORef emptyFilesToClean + dirsToClean <- newIORef mempty + let dflags = (Env.hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True} + pure $ hscSetFlags dflags env +#endif + +hscSetUnitEnv :: UnitEnv -> HscEnv -> HscEnv +#if MIN_VERSION_ghc(9,2,0) +hscSetUnitEnv ue env = env { Env.hsc_unit_env = ue } +#else +hscSetUnitEnv _ env = env +#endif + +hsc_unit_env :: HscEnv -> UnitEnv +hsc_unit_env = +#if MIN_VERSION_ghc(9,2,0) + Env.hsc_unit_env +#else + const () +#endif + +hsc_tmpfs :: HscEnv -> TmpFs +hsc_tmpfs = +#if MIN_VERSION_ghc(9,2,0) + Env.hsc_tmpfs +#else + const () +#endif + +hsc_logger :: HscEnv -> Logger +hsc_logger = +#if MIN_VERSION_ghc(9,2,0) + Env.hsc_logger +#else + Logger . DynFlags.log_action . Env.hsc_dflags +#endif + +hsc_hooks :: HscEnv -> Hooks +hsc_hooks = +#if MIN_VERSION_ghc(9,2,0) + Env.hsc_hooks +#else + hooks . Env.hsc_dflags +#endif + +hscSetHooks :: Hooks -> HscEnv -> HscEnv +hscSetHooks hooks env = +#if MIN_VERSION_ghc(9,2,0) + env { Env.hsc_hooks = hooks } +#else + hscSetFlags ((Env.hsc_dflags env) { hooks = hooks}) env +#endif + +homeUnitId_ :: DynFlags -> UnitId +homeUnitId_ = +#if MIN_VERSION_ghc(9,2,0) + Session.homeUnitId_ +#elif MIN_VERSION_ghc(9,0,0) + homeUnitId +#else + thisPackage +#endif + + +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +type HomeUnit = Unit +#elif !MIN_VERSION_ghc(9,0,0) +type HomeUnit = UnitId +#endif + +hscHomeUnit :: HscEnv -> HomeUnit +hscHomeUnit = +#if MIN_VERSION_ghc(9,2,0) + Env.hsc_home_unit +#elif MIN_VERSION_ghc(9,0,0) + homeUnit . Env.hsc_dflags +#else + homeUnitId_ . hsc_dflags +#endif + +mkHomeModule :: HomeUnit -> ModuleName -> Module +mkHomeModule = +#if MIN_VERSION_ghc(9,2,0) + Home.mkHomeModule +#else + mkModule +#endif + +-- | We don't want to generate object code so we compile to bytecode +-- (HscInterpreted) which implies LinkInMemory +-- HscInterpreted +setBytecodeLinkerOptions :: DynFlags -> DynFlags +setBytecodeLinkerOptions df = df { + ghcLink = LinkInMemory +#if MIN_VERSION_ghc(9,2,0) + , backend = NoBackend +#else + , hscTarget = HscNothing +#endif + , ghcMode = CompManager + } + +setInterpreterLinkerOptions :: DynFlags -> DynFlags +setInterpreterLinkerOptions df = df { + ghcLink = LinkInMemory +#if MIN_VERSION_ghc(9,2,0) + , backend = Interpreter +#else + , hscTarget = HscInterpreted +#endif + , ghcMode = CompManager + } + +-- ------------------------------------------------------- +-- Ways helpers +-- ------------------------------------------------------- + +#if !MIN_VERSION_ghc(9,2,0) && MIN_VERSION_ghc(9,0,0) +type Ways = Set.Set Way +#elif !MIN_VERSION_ghc(9,0,0) +type Ways = [Way] +#endif + +hostFullWays :: Ways +hostFullWays = +#if MIN_VERSION_ghc(9,0,0) + Ways.hostFullWays +#else + interpWays +#endif + +setWays :: Ways -> DynFlags -> DynFlags +setWays ways flags = +#if MIN_VERSION_ghc(9,2,0) + flags { Session.targetWays_ = ways} +#elif MIN_VERSION_ghc(9,0,0) + flags {ways = ways} +#else + updateWays $ flags {ways = ways} +#endif + +-- ------------------------------------------------------- +-- Backend helpers +-- ------------------------------------------------------- + +#if !MIN_VERSION_ghc(9,2,0) +type Backend = HscTarget +#endif + +platformDefaultBackend :: DynFlags -> Backend +platformDefaultBackend = +#if MIN_VERSION_ghc(9,2,0) + Backend.platformDefaultBackend . targetPlatform +#elif MIN_VERSION_ghc(8,10,0) + defaultObjectTarget +#else + defaultObjectTarget . DynFlags.targetPlatform +#endif + +setBackend :: Backend -> DynFlags -> DynFlags +setBackend backend flags = +#if MIN_VERSION_ghc(9,2,0) + flags { backend = backend } +#else + flags { hscTarget = backend } +#endif + diff --git a/ghcide/src/Development/IDE/GHC/Compat/Iface.hs b/ghcide/src/Development/IDE/GHC/Compat/Iface.hs new file mode 100644 index 0000000000..36ac26a446 --- /dev/null +++ b/ghcide/src/Development/IDE/GHC/Compat/Iface.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE CPP #-} + +-- | Compat module Interface file relevant code. +module Development.IDE.GHC.Compat.Iface ( + writeIfaceFile, + cannotFindModule, + ) where + +import GHC +#if MIN_VERSION_ghc(9,2,0) +import qualified GHC.Iface.Load as Iface +import GHC.Unit.Finder.Types (FindResult) +#elif MIN_VERSION_ghc(9,0,0) +import qualified GHC.Driver.Finder as Finder +import GHC.Driver.Types (FindResult) +import qualified GHC.Iface.Load as Iface +#else +import Finder (FindResult) +import qualified Finder +import qualified MkIface +#endif + +import Development.IDE.GHC.Compat.Env +import Development.IDE.GHC.Compat.Outputable + +writeIfaceFile :: HscEnv -> FilePath -> ModIface -> IO () +#if MIN_VERSION_ghc(9,2,0) +writeIfaceFile env fp iface = Iface.writeIface (hsc_logger env) (hsc_dflags env) fp iface +#elif MIN_VERSION_ghc(9,0,0) +writeIfaceFile env = Iface.writeIface (hsc_dflags env) +#else +writeIfaceFile env = MkIface.writeIfaceFile (hsc_dflags env) +#endif + +cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc +cannotFindModule env modname fr = +#if MIN_VERSION_ghc(9,2,0) + Iface.cannotFindModule env modname fr +#else + Finder.cannotFindModule (hsc_dflags env) modname fr +#endif diff --git a/ghcide/src/Development/IDE/GHC/Compat/Logger.hs b/ghcide/src/Development/IDE/GHC/Compat/Logger.hs new file mode 100644 index 0000000000..cb94532eb7 --- /dev/null +++ b/ghcide/src/Development/IDE/GHC/Compat/Logger.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE CPP #-} +-- | Compat module for GHC 9.2 Logger infrastructure. +module Development.IDE.GHC.Compat.Logger ( + putLogHook, + Development.IDE.GHC.Compat.Logger.pushLogHook, + -- * Logging stuff + LogActionCompat, + logActionCompat, + defaultLogActionHPutStrDoc, + ) where + +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.Env as Env +import Development.IDE.GHC.Compat.Outputable + +#if MIN_VERSION_ghc(9,0,0) +import GHC.Driver.Session as DynFlags +import GHC.Utils.Outputable +#if MIN_VERSION_ghc(9,2,0) +import GHC.Driver.Env (hsc_logger) +import GHC.Utils.Logger as Logger +#endif +#else +import DynFlags +import Outputable (queryQual) +#endif + +putLogHook :: Logger -> HscEnv -> HscEnv +putLogHook logger env = +#if MIN_VERSION_ghc(9,2,0) + env { hsc_logger = logger } +#else + hscSetFlags ((hsc_dflags env) { DynFlags.log_action = Env.log_action logger }) env +#endif + +pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger +pushLogHook f logger = +#if MIN_VERSION_ghc(9,2,0) + Logger.pushLogHook f logger +#else + logger { Env.log_action = f (Env.log_action logger) } +#endif + +#if MIN_VERSION_ghc(9,0,0) +type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> 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 + +#else +type LogActionCompat = DynFlags -> WarnReason -> Severity -> SrcSpan -> PrintUnqualified -> SDoc -> IO () + +logActionCompat :: LogActionCompat -> LogAction +logActionCompat logAction dynFlags wr severity loc style = logAction dynFlags wr severity loc (queryQual style) +#endif diff --git a/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs new file mode 100644 index 0000000000..e3b6d2a453 --- /dev/null +++ b/ghcide/src/Development/IDE/GHC/Compat/Outputable.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE CPP #-} + +module Development.IDE.GHC.Compat.Outputable ( + SDoc, + Outputable, + showSDoc, + showSDocUnsafe, + showSDocForUser, + ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, + printSDocQualifiedUnsafe, + printNameWithoutUniques, + printSDocAllTheWay, + mkPrintUnqualified, + mkPrintUnqualifiedDefault, + PrintUnqualified(..), + -- * Parser errors + PsWarning, + PsError, + pprWarning, + pprError, + -- * Error infrastructure + DecoratedSDoc, + MsgEnvelope, + errMsgSpan, + errMsgSeverity, + formatErrorWithQual, + mkWarnMsg, + mkSrcErr, + srcErrorMessages, + ) where + + +#if MIN_VERSION_ghc(9,2,0) +import GHC.Driver.Ppr +import GHC.Driver.Session +import GHC.Parser.Errors +import qualified GHC.Parser.Errors.Ppr as Ppr +import qualified GHC.Types.Error as Error +import GHC.Types.Name.Ppr +import GHC.Types.SourceError +import GHC.Types.SrcLoc +import GHC.Unit.State +import GHC.Utils.Error hiding (mkWarnMsg) +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Panic +#elif MIN_VERSION_ghc(9,0,0) +import GHC.Driver.Session +import GHC.Driver.Types as HscTypes +import GHC.Types.Name.Reader (GlobalRdrEnv) +import GHC.Types.SrcLoc +import GHC.Utils.Error as Err hiding (mkWarnMsg) +import qualified GHC.Utils.Error as Err +import GHC.Utils.Outputable as Out +#else +import Development.IDE.GHC.Compat.Core (GlobalRdrEnv) +import DynFlags +import ErrUtils hiding (mkWarnMsg) +import qualified ErrUtils as Err +import HscTypes +import Outputable as Out +import SrcLoc +#endif + +printNameWithoutUniques :: Outputable a => a -> String +printNameWithoutUniques = +#if MIN_VERSION_ghc(9,2,0) + renderWithContext (defaultSDocContext { sdocSuppressUniques = True }) . ppr +#else + printSDocAllTheWay dyn . ppr + where + dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques +#endif + +printSDocQualifiedUnsafe :: PrintUnqualified -> SDoc -> String +#if MIN_VERSION_ghc(9,2,0) +printSDocQualifiedUnsafe unqual doc = + -- Taken from 'showSDocForUser' + renderWithContext (defaultSDocContext { sdocStyle = sty }) doc' + where + sty = mkUserStyle unqual AllTheWay + doc' = pprWithUnitState emptyUnitState doc +#else +printSDocQualifiedUnsafe unqual doc = + showSDocForUser unsafeGlobalDynFlags unqual doc +#endif + +printSDocAllTheWay :: DynFlags -> SDoc -> String +#if MIN_VERSION_ghc(9,2,0) +printSDocAllTheWay dflags sdoc = renderWithContext ctxt sdoc + where + ctxt = initSDocContext dflags (mkUserStyle neverQualify AllTheWay) +#else +printSDocAllTheWay dflags sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags Out.neverQualify Out.AllTheWay) + +#if MIN_VERSION_ghc(9,0,0) +oldRenderWithStyle dflags sdoc sty = Out.renderWithStyle (initSDocContext dflags sty) sdoc +oldMkUserStyle _ = Out.mkUserStyle +oldMkErrStyle _ = Out.mkErrStyle + +oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc +oldFormatErrDoc dflags = Err.formatErrDoc dummySDocContext + where dummySDocContext = initSDocContext dflags Out.defaultUserStyle + +#else +oldRenderWithStyle :: DynFlags -> Out.SDoc -> Out.PprStyle -> String +oldRenderWithStyle = Out.renderWithStyle + +oldMkUserStyle :: DynFlags -> Out.PrintUnqualified -> Out.Depth -> Out.PprStyle +oldMkUserStyle = Out.mkUserStyle + +oldMkErrStyle :: DynFlags -> Out.PrintUnqualified -> Out.PprStyle +oldMkErrStyle = Out.mkErrStyle + +oldFormatErrDoc :: DynFlags -> Err.ErrDoc -> Out.SDoc +oldFormatErrDoc = Err.formatErrDoc +#endif +#endif + +pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc +pprWarning = +#if MIN_VERSION_ghc(9,2,0) + Ppr.pprWarning +#else + id +#endif + +pprError :: PsError -> MsgEnvelope DecoratedSDoc +pprError = +#if MIN_VERSION_ghc(9,2,0) + Ppr.pprError +#else + id +#endif + +formatErrorWithQual :: DynFlags -> MsgEnvelope DecoratedSDoc -> String +formatErrorWithQual dflags e = +#if MIN_VERSION_ghc(9,2,0) + showSDoc dflags (pprLocMsgEnvelope e) +#else + Out.showSDoc dflags + $ Out.withPprStyle (oldMkErrStyle dflags $ errMsgContext e) + $ oldFormatErrDoc dflags + $ Err.errMsgDoc e +#endif + +#if !MIN_VERSION_ghc(9,2,0) +type DecoratedSDoc = () +type MsgEnvelope e = ErrMsg + +type PsWarning = ErrMsg +type PsError = ErrMsg +#endif + +mkPrintUnqualifiedDefault :: GlobalRdrEnv -> PrintUnqualified +mkPrintUnqualifiedDefault = + HscTypes.mkPrintUnqualified unsafeGlobalDynFlags + +mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc +mkWarnMsg = +#if MIN_VERSION_ghc(9,2,0) + const Error.mkWarnMsg +#else + Err.mkWarnMsg +#endif diff --git a/ghcide/src/Development/IDE/GHC/Compat/Parser.hs b/ghcide/src/Development/IDE/GHC/Compat/Parser.hs new file mode 100644 index 0000000000..450b0cf5ec --- /dev/null +++ b/ghcide/src/Development/IDE/GHC/Compat/Parser.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE CPP #-} + +-- | Parser compaibility module. +module Development.IDE.GHC.Compat.Parser ( + initParserOpts, + initParserState, +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) + -- in GHC == 9.2 the type doesn't exist + -- In GHC == 9.0 it is a data-type + -- and GHC < 9.0 it is type-def + -- + -- Export data-type here, otherwise only the simple type. + Anno.ApiAnns(..), +#else + ApiAnns, +#endif + mkHsParsedModule, + mkParsedModule, + mkApiAnns, + -- * API Annotations + Anno.AnnKeywordId(..), + Anno.AnnotationComment(..), + ) where + +#if MIN_VERSION_ghc(9,0,0) +import qualified GHC.Parser.Lexer as Lexer +#if MIN_VERSION_ghc(9,2,0) +import qualified GHC.Driver.Config as Config +import GHC.Parser.Lexer hiding (initParserState) +#else +import qualified GHC.Parser.Annotation as Anno +#endif +#else +import qualified ApiAnnotation as Anno +import Lexer +import qualified SrcLoc +#endif +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.Util + +#if !MIN_VERSION_ghc(9,2,0) +import qualified Data.Map as Map +#endif + +#if !MIN_VERSION_ghc(9,0,0) +type ParserOpts = DynFlags +#elif !MIN_VERSION_ghc(9,2,0) +type ParserOpts = Lexer.ParserFlags +#endif + +initParserOpts :: DynFlags -> ParserOpts +initParserOpts = +#if MIN_VERSION_ghc(9,2,0) + Config.initParserOpts +#elif MIN_VERSION_ghc(9,0,0) + Lexer.mkParserFlags +#else + id +#endif + +initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState +initParserState = +#if MIN_VERSION_ghc(9,2,0) + Lexer.initParserState +#elif MIN_VERSION_ghc(9,0,0) + Lexer.mkPStatePure +#else + Lexer.mkPState +#endif + +#if MIN_VERSION_ghc(9,2,0) +type ApiAnns = () +#else +type ApiAnns = Anno.ApiAnns +#endif + + +mkHsParsedModule :: ParsedSource -> [FilePath] -> ApiAnns -> HsParsedModule +mkHsParsedModule parsed fps hpm_annotations = + HsParsedModule + parsed + fps +#if !MIN_VERSION_ghc(9,2,0) + hpm_annotations +#endif + + +mkParsedModule :: ModSummary -> ParsedSource -> [FilePath] -> ApiAnns -> ParsedModule +mkParsedModule ms parsed extra_src_files _hpm_annotations = + ParsedModule { + pm_mod_summary = ms + , pm_parsed_source = parsed + , pm_extra_src_files = extra_src_files +#if !MIN_VERSION_ghc(9,2,0) + , pm_annotations = _hpm_annotations +#endif + } + +mkApiAnns :: PState -> ApiAnns +#if MIN_VERSION_ghc(9,2,0) +mkApiAnns = const () +#else +mkApiAnns pst = +#if MIN_VERSION_ghc(9,0,1) + -- Copied from GHC.Driver.Main + Anno.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 ((SrcLoc.noSrcSpan,comment_q pst) + :annotations_comments pst)) +#endif +#endif diff --git a/ghcide/src/Development/IDE/GHC/Compat/Plugins.hs b/ghcide/src/Development/IDE/GHC/Compat/Plugins.hs new file mode 100644 index 0000000000..6621b70e9c --- /dev/null +++ b/ghcide/src/Development/IDE/GHC/Compat/Plugins.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE CPP #-} + +-- | Plugin Compat utils. +module Development.IDE.GHC.Compat.Plugins ( + Plugin(..), + defaultPlugin, +#if __GLASGOW_HASKELL__ >= 808 + PluginWithArgs(..), +#endif + applyPluginsParsedResultAction, + initializePlugins, + + -- * Static plugins +#if MIN_VERSION_ghc(8,8,0) + StaticPlugin(..), + hsc_static_plugins, +#endif + ) where + +import GHC +#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) +import qualified GHC.Driver.Env as Env +#endif +import GHC.Driver.Plugins (Plugin (..), + PluginWithArgs (..), + StaticPlugin (..), + defaultPlugin, withPlugins) +import qualified GHC.Runtime.Loader as Loader +#elif MIN_VERSION_ghc(8,8,0) +import qualified DynamicLoading as Loader +import Plugins +#else +import qualified DynamicLoading as Loader +import Plugins (Plugin (..), defaultPlugin, + withPlugins) +#endif +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.Env (hscSetFlags, hsc_dflags) +import Development.IDE.GHC.Compat.Parser as Parser + +applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> Parser.ApiAnns -> ParsedSource -> IO ParsedSource +applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do + -- Apply parsedResultAction of plugins + let applyPluginAction p opts = parsedResultAction p opts ms + fmap hpm_module $ + runHsc env $ withPlugins +#if MIN_VERSION_ghc(9,2,0) + env +#else + dflags +#endif + applyPluginAction + (mkHsParsedModule parsed [] hpm_annotations) + +initializePlugins :: HscEnv -> IO HscEnv +initializePlugins env = do +#if MIN_VERSION_ghc(9,2,0) + Loader.initializePlugins env +#else + newDf <- Loader.initializePlugins env (hsc_dflags env) + pure $ hscSetFlags newDf env +#endif + + +#if MIN_VERSION_ghc(8,8,0) +hsc_static_plugins :: HscEnv -> [StaticPlugin] +#if MIN_VERSION_ghc(9,2,0) +hsc_static_plugins = Env.hsc_static_plugins +#else +hsc_static_plugins = staticPlugins . hsc_dflags +#endif +#endif diff --git a/ghcide/src/Development/IDE/GHC/Compat/Units.hs b/ghcide/src/Development/IDE/GHC/Compat/Units.hs new file mode 100644 index 0000000000..9f69100559 --- /dev/null +++ b/ghcide/src/Development/IDE/GHC/Compat/Units.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Compat module for 'UnitState' and 'UnitInfo'. +module Development.IDE.GHC.Compat.Units ( + -- * UnitState + UnitState, + initUnits, + unitState, + getUnitName, + explicitUnits, + preloadClosureUs, + listVisibleModuleNames, + LookupResult(..), + lookupModuleWithSuggestions, + -- * UnitInfoMap + UnitInfoMap, + getUnitInfoMap, + lookupUnit, + lookupUnit', + -- * UnitInfo + UnitInfo, + unitExposedModules, + unitDepends, + unitHaddockInterfaces, + unitInfoId, + unitPackageNameString, + unitPackageVersion, + -- * UnitId helpers + UnitId, + Unit, + unitString, + stringToUnit, +#if !MIN_VERSION_ghc(9,0,0) + pattern RealUnit, +#endif + definiteUnitId, + defUnitId, + installedModule, + -- * Module + toUnitId, + moduleUnitId, + moduleUnit, + -- * ExternalPackageState + ExternalPackageState(..), + -- * Utils + filterInplaceUnits, + ) where + +#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) +import qualified GHC.Data.ShortText as ST +import GHC.Driver.Env (hsc_unit_dbs) +import GHC.Unit.Env +import GHC.Unit.External +#else +import GHC.Driver.Types +#endif +import GHC.Data.FastString +import GHC.Driver.Session (PackageArg (..), + PackageFlag (..)) +import qualified GHC.Driver.Session as DynFlags +import GHC.Types.Unique.Set +import qualified GHC.Unit.Info as UnitInfo +import GHC.Unit.Module.Name (ModuleName) +import GHC.Unit.State (LookupResult, PackageName, + UnitInfo, + UnitState (unitInfoMap)) +import qualified GHC.Unit.State as State +import GHC.Unit.Types hiding (moduleUnit, toUnitId) +import qualified GHC.Unit.Types as Unit +#else +import DynFlags (PackageArg (..), + PackageFlag (..)) +import qualified DynFlags +import FastString +import HscTypes +import Module hiding (moduleUnitId) +import qualified Module +import Packages (InstalledPackageInfo (haddockInterfaces, packageName), + LookupResult, PackageConfig, + PackageConfigMap, PackageName, + PackageState, + getPackageConfigMap, + lookupPackage') +import qualified Packages +#endif + +import Development.IDE.GHC.Compat.Env +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,2,0) +import Data.Map (Map) +#endif +import Data.Either +import Data.Version + +#if MIN_VERSION_ghc(9,0,0) +type PreloadUnitClosure = UniqSet UnitId +#if MIN_VERSION_ghc(9,2,0) +type UnitInfoMap = State.UnitInfoMap +#else +type UnitInfoMap = Map UnitId UnitInfo +#endif +#else +type UnitState = PackageState +type UnitInfo = PackageConfig +type UnitInfoMap = PackageConfigMap +type PreloadUnitClosure = () +type Unit = UnitId +#endif + + +#if !MIN_VERSION_ghc(9,0,0) +unitString :: Unit -> String +unitString = Module.unitIdString + +stringToUnit :: String -> Unit +stringToUnit = Module.stringToUnitId +#endif + +unitState :: HscEnv -> UnitState +#if MIN_VERSION_ghc(9,2,0) +unitState = ue_units . hsc_unit_env +#elif MIN_VERSION_ghc(9,0,0) +unitState = DynFlags.unitState . hsc_dflags +#else +unitState = DynFlags.pkgState . hsc_dflags +#endif + +initUnits :: HscEnv -> IO HscEnv +initUnits env = do +#if MIN_VERSION_ghc(9,2,0) + let dflags1 = hsc_dflags env + -- Copied from GHC.setSessionDynFlags + let cached_unit_dbs = hsc_unit_dbs env + (dbs,unit_state,home_unit,mconstants) <- State.initUnits (hsc_logger env) dflags1 cached_unit_dbs + + dflags <- updatePlatformConstants dflags1 mconstants + + + let unit_env = UnitEnv + { ue_platform = targetPlatform dflags + , ue_namever = ghcNameVersion dflags + , ue_home_unit = home_unit + , ue_units = unit_state + } + pure $ hscSetFlags dflags $ hscSetUnitEnv unit_env env + { hsc_unit_dbs = Just dbs + } +#elif MIN_VERSION_ghc(9,0,0) + newFlags <- State.initUnits $ hsc_dflags env + pure $ hscSetFlags newFlags env +#else + newFlags <- fmap fst . Packages.initPackages $ hsc_dflags env + pure $ hscSetFlags newFlags env +#endif + +explicitUnits :: UnitState -> [Unit] +explicitUnits ue = +#if MIN_VERSION_ghc(9,0,0) + State.explicitUnits ue +#else + Packages.explicitPackages ue +#endif + +listVisibleModuleNames :: HscEnv -> [ModuleName] +listVisibleModuleNames env = +#if MIN_VERSION_ghc(9,0,0) + State.listVisibleModuleNames $ unitState env +#else + Packages.listVisibleModuleNames $ hsc_dflags env +#endif + +getUnitName :: HscEnv -> UnitId -> Maybe PackageName +getUnitName env i = +#if MIN_VERSION_ghc(9,0,0) + State.unitPackageName <$> State.lookupUnitId (unitState env) i +#else + packageName <$> Packages.lookupPackage (hsc_dflags env) (definiteUnitId (defUnitId i)) +#endif + +lookupModuleWithSuggestions :: HscEnv -> ModuleName -> Maybe FastString -> LookupResult +lookupModuleWithSuggestions env modname mpkg = +#if MIN_VERSION_ghc(9,0,0) + State.lookupModuleWithSuggestions (unitState env) modname mpkg +#else + Packages.lookupModuleWithSuggestions (hsc_dflags env) modname mpkg +#endif + +getUnitInfoMap :: HscEnv -> UnitInfoMap +getUnitInfoMap = +#if MIN_VERSION_ghc(9,2,0) + unitInfoMap . ue_units . hsc_unit_env +#elif MIN_VERSION_ghc(9,0,0) + unitInfoMap . unitState +#else + Packages.getPackageConfigMap . hsc_dflags +#endif + +lookupUnit :: HscEnv -> Unit -> Maybe UnitInfo +#if MIN_VERSION_ghc(9,0,0) +lookupUnit env pid = State.lookupUnit (unitState env) pid +#else +lookupUnit env pid = Packages.lookupPackage (hsc_dflags env) pid +#endif + +lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo +#if MIN_VERSION_ghc(9,0,0) +lookupUnit' = State.lookupUnit' +#else +lookupUnit' b pcm _ u = Packages.lookupPackage' b pcm u +#endif + +preloadClosureUs :: HscEnv -> PreloadUnitClosure +#if MIN_VERSION_ghc(9,2,0) +preloadClosureUs = State.preloadClosure . unitState +#elif MIN_VERSION_ghc(9,0,0) +preloadClosureUs = State.preloadClosure . unitState +#else +preloadClosureUs = const () +#endif + +unitExposedModules :: UnitInfo -> [(ModuleName, Maybe Module)] +unitExposedModules ue = +#if MIN_VERSION_ghc(9,0,0) + UnitInfo.unitExposedModules ue +#else + Packages.exposedModules ue +#endif + +unitDepends :: UnitInfo -> [UnitId] +#if MIN_VERSION_ghc(9,0,0) +unitDepends = State.unitDepends +#else +unitDepends = fmap (Module.DefiniteUnitId. defUnitId') . Packages.depends +#endif + +unitPackageNameString :: UnitInfo -> String +unitPackageNameString = +#if MIN_VERSION_ghc(9,0,0) + UnitInfo.unitPackageNameString +#else + Packages.packageNameString +#endif + +unitPackageVersion :: UnitInfo -> Version +unitPackageVersion = +#if MIN_VERSION_ghc(9,0,0) + UnitInfo.unitPackageVersion +#else + Packages.packageVersion +#endif + +unitInfoId :: UnitInfo -> Unit +unitInfoId = +#if MIN_VERSION_ghc(9,0,0) + UnitInfo.mkUnit +#else + Packages.packageConfigId +#endif + +unitHaddockInterfaces :: UnitInfo -> [FilePath] +unitHaddockInterfaces = +#if MIN_VERSION_ghc(9,2,0) + fmap ST.unpack . UnitInfo.unitHaddockInterfaces +#elif MIN_VERSION_ghc(9,0,0) + UnitInfo.unitHaddockInterfaces +#else + haddockInterfaces +#endif + +-- ------------------------------------------------------------------ +-- Backwards Compatible UnitState +-- ------------------------------------------------------------------ + +-- ------------------------------------------------------------------ +-- Patterns and helpful definitions +-- ------------------------------------------------------------------ + +#if MIN_VERSION_ghc(9,2,0) +definiteUnitId = RealUnit +defUnitId = Definite +installedModule = Module + +#elif MIN_VERSION_ghc(9,0,0) +definiteUnitId = RealUnit +defUnitId = Definite +installedModule = Module + +#else +pattern RealUnit :: Module.DefUnitId -> UnitId +pattern RealUnit x = Module.DefiniteUnitId x + +definiteUnitId :: Module.DefUnitId -> UnitId +definiteUnitId = Module.DefiniteUnitId + +defUnitId :: UnitId -> Module.DefUnitId +defUnitId = Module.DefUnitId . Module.toInstalledUnitId + +defUnitId' :: Module.InstalledUnitId -> Module.DefUnitId +defUnitId' = Module.DefUnitId + +installedModule :: UnitId -> ModuleName -> Module.InstalledModule +installedModule uid modname = Module.InstalledModule (Module.toInstalledUnitId uid) modname +#endif + +toUnitId :: Unit -> UnitId +toUnitId = +#if MIN_VERSION_ghc(9,0,0) + Unit.toUnitId +#else + id +#endif + +moduleUnitId :: Module -> UnitId +moduleUnitId = +#if MIN_VERSION_ghc(9,0,0) + Unit.toUnitId . Unit.moduleUnit +#else + Module.moduleUnitId +#endif + +moduleUnit :: Module -> Unit +moduleUnit = +#if MIN_VERSION_ghc(9,0,0) + Unit.moduleUnit +#else + Module.moduleUnitId +#endif + +filterInplaceUnits :: [UnitId] -> [PackageFlag] -> ([UnitId], [PackageFlag]) +filterInplaceUnits us packageFlags = + partitionEithers (map isInplace packageFlags) + where + isInplace :: PackageFlag -> Either UnitId PackageFlag + isInplace p@(ExposePackage _ (UnitIdArg u) _) = +#if MIN_VERSION_ghc(9,0,0) + if toUnitId u `elem` us + then Left $ toUnitId u + else Right p +#else + if u `elem` us + then Left u + else Right p +#endif + isInplace p = Right p diff --git a/ghcide/src/Development/IDE/GHC/Compat/Util.hs b/ghcide/src/Development/IDE/GHC/Compat/Util.hs new file mode 100644 index 0000000000..198a94c03b --- /dev/null +++ b/ghcide/src/Development/IDE/GHC/Compat/Util.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +-- | GHC Utils and Datastructures re-exports. +-- +-- Mainly handles module hierarchy re-organisation of GHC +-- from version < 9.0 to >= 9.0. +-- +-- Some Functions, such as 'toList' shadow other function-names. +-- This way this module can be imported qualified more naturally. +module Development.IDE.GHC.Compat.Util ( + -- * Exception handling + MonadCatch, + GhcException, + handleGhcException, + catch, + try, + -- * Bags + Bag, + bagToList, + listToBag, + unionBags, + isEmptyBag, + -- * Boolean Formula + LBooleanFormula, + BooleanFormula(..), + -- * OverridingBool + OverridingBool(..), + -- * Maybes + MaybeErr(..), + orElse, +#if MIN_VERSION_ghc(8,10,0) + -- * Pair + Pair(..), +#endif + -- * EnumSet + EnumSet, + toList, + -- * FastString exports + FastString, +#if MIN_VERSION_ghc(9,2,0) + -- Export here, so we can coerce safely on consumer sites + LexicalFastString(..), +#endif + uniq, + unpackFS, + mkFastString, + fsLit, + pprHsString, + -- * Fingerprint + Fingerprint(..), + getFileHash, + fingerprintData, + fingerprintString, + fingerprintFingerprints, + -- * Unique + Uniquable, + nonDetCmpUnique, + getUnique, + Unique, + mkUnique, + newTagUnique, + -- * String Buffer + StringBuffer(..), + hGetStringBuffer, + stringToStringBuffer, + ) where + +#if MIN_VERSION_ghc(9,0,0) +import Control.Exception.Safe (MonadCatch, catch, try) +import GHC.Data.Bag +import GHC.Data.BooleanFormula +import GHC.Data.EnumSet + +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Data.Pair +import GHC.Data.StringBuffer +import GHC.Types.Unique +import GHC.Utils.Fingerprint +import GHC.Utils.Misc +import GHC.Utils.Outputable (pprHsString) +import GHC.Utils.Panic hiding (try) +#else +import Bag +import BooleanFormula +import EnumSet +import qualified Exception +import FastString +import Fingerprint +import Maybes +#if MIN_VERSION_ghc(8,10,0) +import Pair +#endif +import Outputable (pprHsString) +import Panic hiding (try) +import StringBuffer +import Unique +import Util +#endif + +#if !MIN_VERSION_ghc(9,0,0) +type MonadCatch = Exception.ExceptionMonad + +-- We are using Safe here, which is not equivalent, but probably what we want. +catch :: (Exception.ExceptionMonad m, Exception e) => m a -> (e -> m a) -> m a +catch = Exception.gcatch + +try :: (Exception.ExceptionMonad m, Exception e) => m a -> m (Either e a) +try = Exception.gtry +#endif diff --git a/ghcide/src/Development/IDE/GHC/Error.hs b/ghcide/src/Development/IDE/GHC/Error.hs index f025957e8d..6abb3917a4 100644 --- a/ghcide/src/Development/IDE/GHC/Error.hs +++ b/ghcide/src/Development/IDE/GHC/Error.hs @@ -29,22 +29,19 @@ module Development.IDE.GHC.Error , toDSeverity ) where -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.Compat (DecoratedSDoc, MsgEnvelope, + errMsgSeverity, errMsgSpan, + formatErrorWithQual, + srcErrorMessages) +import qualified Development.IDE.GHC.Compat as Compat +import qualified Development.IDE.GHC.Compat.Util as Compat import Development.IDE.GHC.Orphans () import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location -import ErrUtils -import qualified FastString as FS import GHC -import HscTypes -import qualified Outputable as Out -import Panic -import SrcLoc - diagFromText :: T.Text -> D.DiagnosticSeverity -> SrcSpan -> T.Text -> FileDiagnostic @@ -60,32 +57,25 @@ diagFromText diagSource sev loc msg = (toNormalizedFilePath' $ fromMaybe noFileP } -- | Produce a GHC-style error from a source span and a message. -diagFromErrMsg :: T.Text -> DynFlags -> ErrMsg -> [FileDiagnostic] +diagFromErrMsg :: T.Text -> DynFlags -> MsgEnvelope DecoratedSDoc -> [FileDiagnostic] diagFromErrMsg diagSource dflags e = [ diagFromText diagSource sev (errMsgSpan e) $ T.pack $ formatErrorWithQual dflags e | Just sev <- [toDSeverity $ errMsgSeverity e]] -formatErrorWithQual :: DynFlags -> ErrMsg -> String -formatErrorWithQual dflags e = - Out.showSDoc dflags - $ Out.withPprStyle (GHC.oldMkErrStyle dflags $ errMsgContext e) - $ GHC.oldFormatErrDoc dflags - $ ErrUtils.errMsgDoc e - -diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic] -diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList +diagFromErrMsgs :: T.Text -> DynFlags -> Compat.Bag (MsgEnvelope DecoratedSDoc) -> [FileDiagnostic] +diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . Compat.bagToList -- | Convert a GHC SrcSpan to a DAML compiler Range srcSpanToRange :: SrcSpan -> Maybe Range -srcSpanToRange (UnhelpfulSpan _) = Nothing -srcSpanToRange (GHC.OldRealSrcSpan real) = Just $ realSrcSpanToRange real +srcSpanToRange (UnhelpfulSpan _) = Nothing +srcSpanToRange (Compat.RealSrcSpan real _) = Just $ realSrcSpanToRange real -- srcSpanToRange = fmap realSrcSpanToRange . realSpan realSrcSpanToRange :: RealSrcSpan -> Range realSrcSpanToRange real = - Range (realSrcLocToPosition $ realSrcSpanStart real) - (realSrcLocToPosition $ realSrcSpanEnd real) + Range (realSrcLocToPosition $ Compat.realSrcSpanStart real) + (realSrcLocToPosition $ Compat.realSrcSpanEnd real) realSrcLocToPosition :: RealSrcLoc -> Position realSrcLocToPosition real = @@ -95,12 +85,12 @@ realSrcLocToPosition real = -- FIXME This may not be an _absolute_ file name, needs fixing. srcSpanToFilename :: SrcSpan -> Maybe FilePath srcSpanToFilename (UnhelpfulSpan _) = Nothing -srcSpanToFilename (GHC.OldRealSrcSpan real) = Just $ FS.unpackFS $ srcSpanFile real +srcSpanToFilename (Compat.RealSrcSpan real _) = Just $ Compat.unpackFS $ srcSpanFile real -- srcSpanToFilename = fmap (FS.unpackFS . srcSpanFile) . realSpan realSrcSpanToLocation :: RealSrcSpan -> Location realSrcSpanToLocation real = Location file (realSrcSpanToRange real) - where file = fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ FS.unpackFS $ srcSpanFile real + where file = fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' $ Compat.unpackFS $ srcSpanFile real srcSpanToLocation :: SrcSpan -> Maybe Location srcSpanToLocation src = do @@ -110,18 +100,18 @@ srcSpanToLocation src = do pure $ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath' fs) rng rangeToSrcSpan :: NormalizedFilePath -> Range -> SrcSpan -rangeToSrcSpan = fmap GHC.OldRealSrcSpan . rangeToRealSrcSpan +rangeToSrcSpan = fmap (\x -> Compat.RealSrcSpan x Nothing) . rangeToRealSrcSpan rangeToRealSrcSpan :: NormalizedFilePath -> Range -> RealSrcSpan rangeToRealSrcSpan nfp = - mkRealSrcSpan + Compat.mkRealSrcSpan <$> positionToRealSrcLoc nfp . _start <*> positionToRealSrcLoc nfp . _end positionToRealSrcLoc :: NormalizedFilePath -> Position -> RealSrcLoc positionToRealSrcLoc nfp (Position l c)= - mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (l + 1) (c + 1) + Compat.mkRealSrcLoc (fromString $ fromNormalizedFilePath nfp) (l + 1) (c + 1) isInsideSrcSpan :: Position -> SrcSpan -> Bool p `isInsideSrcSpan` r = case srcSpanToRange r of @@ -152,19 +142,19 @@ 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 = GHC.oldUnhelpfulSpan . FS.fsLit +noSpan = Compat.mkGeneralSrcSpan . Compat.fsLit -- | creates a span with zero length in the filename of the argument passed -zeroSpan :: FS.FastString -- ^ file path of span +zeroSpan :: Compat.FastString -- ^ file path of span -> RealSrcSpan -zeroSpan file = realSrcLocSpan (mkRealSrcLoc file 1 1) +zeroSpan file = Compat.realSrcLocSpan (Compat.mkRealSrcLoc file 1 1) realSpan :: SrcSpan -> Maybe RealSrcSpan realSpan = \case - GHC.OldRealSrcSpan r -> Just r - UnhelpfulSpan _ -> Nothing + Compat.RealSrcSpan r _ -> Just r + UnhelpfulSpan _ -> Nothing -- | Catch the errors thrown by GHC (SourceErrors and @@ -172,7 +162,7 @@ realSpan = \case -- diagnostics catchSrcErrors :: DynFlags -> T.Text -> IO a -> IO (Either [FileDiagnostic] a) catchSrcErrors dflags fromWhere ghcM = do - handleGhcException (ghcExceptionToDiagnostics dflags) $ + Compat.handleGhcException (ghcExceptionToDiagnostics dflags) $ handleSourceError (sourceErrorToDiagnostics dflags) $ Right <$> ghcM where @@ -192,14 +182,14 @@ showGHCE dflags exc = case exc of -> unwords ["Compilation Issue:", s, "\n", requestReport] PprPanic s sdoc -> unlines ["Compilation Issue", s,"" - , Out.showSDoc dflags sdoc + , Compat.showSDoc dflags sdoc , requestReport ] Sorry s -> "Unsupported feature: " <> s PprSorry s sdoc -> unlines ["Unsupported feature: ", s,"" - , Out.showSDoc dflags sdoc] + , Compat.showSDoc dflags sdoc] ---------- errors below should not happen at all -------- @@ -216,6 +206,6 @@ showGHCE dflags exc = case exc of -> "Program error: " <> str PprProgramError str sdoc -> unlines ["Program error:", str,"" - , Out.showSDoc dflags sdoc] + , Compat.showSDoc dflags sdoc] where requestReport = "Please report this bug to the compiler authors." diff --git a/ghcide/src/Development/IDE/GHC/ExactPrint.hs b/ghcide/src/Development/IDE/GHC/ExactPrint.hs index bf564452d4..8ce27a9f3b 100644 --- a/ghcide/src/Development/IDE/GHC/ExactPrint.hs +++ b/ghcide/src/Development/IDE/GHC/ExactPrint.hs @@ -29,10 +29,11 @@ module Development.IDE.GHC.ExactPrint Anns, Annotate, setPrecedingLinesT, + -- * Helper function + eqSrcSpan, ) where -import BasicTypes (appPrec) import Control.Applicative (Alternative) import Control.Arrow import Control.Monad @@ -53,7 +54,9 @@ import Data.Traversable (for) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service (runAction) import Development.IDE.Core.Shake -import Development.IDE.GHC.Compat hiding (parseExpr) +import Development.IDE.GHC.Compat hiding (parseImport, + parsePattern, + parseType) import Development.IDE.Graph (RuleResult, Rules) import Development.IDE.Graph.Classes import Development.IDE.Types.Location @@ -65,9 +68,6 @@ import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers import Language.LSP.Types import Language.LSP.Types.Capabilities (ClientCapabilities) -import Outputable (Outputable, ppr, - showSDoc) -import Parser (parseIdentifier) import Retrie.ExactPrint hiding (parseDecl, parseExpr, parsePattern, @@ -233,8 +233,9 @@ graft' needs_space dst val = Graft $ \dflags a -> do everywhere' ( mkT $ \case - (L src _ :: Located ast) | src == dst -> val' - l -> l + (L src _ :: Located ast) + | src `eqSrcSpan` dst -> val' + l -> l ) a @@ -267,7 +268,7 @@ getNeedsSpaceAndParenthesize dst a = let (needs_parens, needs_space) = everythingWithContext (Nothing, Nothing) (<>) ( mkQ (mempty, ) $ \x s -> case x of - (L src _ :: LHsExpr GhcPs) | src == dst -> + (L src _ :: LHsExpr GhcPs) | src `eqSrcSpan` dst -> (s, s) L _ x' -> (mempty, Just *** Just $ needsParensSpace x') ) a @@ -291,7 +292,7 @@ graftExprWithM dst trans = Graft $ \dflags a -> do ( mkM $ \case val@(L src _ :: LHsExpr GhcPs) - | src == dst -> do + | src `eqSrcSpan` dst -> do mval <- trans val case mval of Just val' -> do @@ -316,7 +317,7 @@ graftWithM dst trans = Graft $ \dflags a -> do ( mkM $ \case val@(L src _ :: Located ast) - | src == dst -> do + | src `eqSrcSpan` dst -> do mval <- trans val case mval of Just val' -> do @@ -368,7 +369,7 @@ graftDecls dst decs0 = Graft $ \dflags a -> do annotateDecl dflags decl let go [] = DL.empty go (L src e : rest) - | src == dst = DL.fromList decs <> DL.fromList rest + | src `eqSrcSpan` dst = DL.fromList decs <> DL.fromList rest | otherwise = DL.singleton (L src e) <> go rest modifyDeclsT (pure . DL.toList . go) a @@ -399,7 +400,7 @@ graftDeclsWithM :: graftDeclsWithM dst toDecls = Graft $ \dflags a -> do let go [] = pure DL.empty go (e@(L src _) : rest) - | src == dst = toDecls e >>= \case + | src `eqSrcSpan` dst = toDecls e >>= \case Just decs0 -> do decs <- forM decs0 $ \decl -> hoistTransform (either Fail.fail pure) $ @@ -519,3 +520,9 @@ render dflags = showSDoc dflags . ppr parenthesize :: LHsExpr GhcPs -> LHsExpr GhcPs parenthesize = parenthesizeHsExpr appPrec +------------------------------------------------------------------------------ + +-- | Equality on SrcSpan's. +-- Ignores the (Maybe BufSpan) field of SrcSpan's. +eqSrcSpan :: SrcSpan -> SrcSpan -> Bool +eqSrcSpan l r = leftmost_smallest l r == EQ diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index 97c38b1d58..a04fd1e86d 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -9,20 +9,34 @@ -- Note that the 'NFData' instances may not be law abiding. module Development.IDE.GHC.Orphans() where +#if MIN_VERSION_ghc(9,0,0) +import GHC.Data.Bag +import GHC.Data.FastString +import qualified GHC.Data.StringBuffer as SB +import GHC.Types.Name.Occurrence +import GHC.Types.SrcLoc +import GHC.Types.Unique (getKey) +import GHC.Unit.Info +import GHC.Utils.Outputable +#else import Bag +import GhcPlugins +import qualified StringBuffer as SB +import Unique (getKey) +#endif + +import GHC + +import Retrie.ExactPrint (Annotated) + +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Util + import Control.DeepSeq import Data.Aeson import Data.Hashable import Data.String (IsString (fromString)) import Data.Text (Text) -import Development.IDE.GHC.Compat -import Development.IDE.GHC.Util -import GHC () -import GhcPlugins -import Retrie.ExactPrint (Annotated) -import qualified StringBuffer as SB -import Unique (getKey) - -- Orphan instances for types from the GHC API. instance Show CoreModule where show = prettyPrint @@ -50,7 +64,7 @@ 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 +instance Show UnitId where show = prettyPrint deriving instance Ord SrcSpan deriving instance Ord UnhelpfulSpanReason #endif @@ -93,8 +107,10 @@ deriving instance Show SourceModified instance NFData SourceModified where rnf = rwhnf +#if !MIN_VERSION_ghc(9,2,0) instance Show ModuleName where show = moduleNameString +#endif instance Hashable ModuleName where hashWithSalt salt = hashWithSalt salt . show diff --git a/ghcide/src/Development/IDE/GHC/Util.hs b/ghcide/src/Development/IDE/GHC/Util.hs index fd13dd8f27..1e3568086b 100644 --- a/ghcide/src/Development/IDE/GHC/Util.hs +++ b/ghcide/src/Development/IDE/GHC/Util.hs @@ -10,7 +10,7 @@ module Development.IDE.GHC.Util( prettyPrint, unsafePrintSDoc, printRdrName, - printName, + Development.IDE.GHC.Util.printName, ParseResult(..), runParser, lookupPackageConfig, textToStringBuffer, @@ -30,48 +30,78 @@ module Development.IDE.GHC.Util( disableWarningsAsErrors, ) where +#if MIN_VERSION_ghc(9,2,0) +import GHC +import GHC.Core.Multiplicity +import qualified GHC.Core.TyCo.Rep as TyCoRep +import GHC.Data.FastString +import GHC.Data.StringBuffer +import GHC.Driver.Env +import GHC.Driver.Env.Types +import GHC.Driver.Monad +import GHC.Driver.Session hiding (ExposePackage) +import qualified GHC.Driver.Session as DynFlags +import GHC.Hs.Extension +import qualified GHC.Hs.Type as GHC +import GHC.Iface.Env (updNameCache) +import GHC.Iface.Make (mkIfaceExports) +import qualified GHC.Linker.Types as LinkerTypes +import GHC.Parser.Lexer +import GHC.Runtime.Context +import GHC.Tc.Types (TcGblEnv (tcg_exports)) +import GHC.Tc.Utils.TcType (pprSigmaType) +import GHC.Types.Avail +import GHC.Types.Name.Cache +import GHC.Types.Name.Occurrence +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc +import qualified GHC.Types.SrcLoc as SrcLoc +import GHC.Unit.Env +import GHC.Unit.Info (PackageName) +import qualified GHC.Unit.Info as Packages +import qualified GHC.Unit.Module.Location as Module +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModIface (mi_mod_hash) +import GHC.Unit.Module.Name (moduleNameSlashes) +import qualified GHC.Unit.State as Packages +import GHC.Unit.Types (IsBootInterface (..), + unitString) +import qualified GHC.Unit.Types as Module +import GHC.Utils.Fingerprint +import GHC.Utils.Outputable +import qualified GHC.Utils.Outputable as Outputable +#endif import Control.Concurrent -import Control.Exception -import Data.Binary.Put (Put, runPut) -import qualified Data.ByteString as BS -import Data.ByteString.Internal (ByteString (..)) -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Lazy as LBS +import Control.Exception as E +import Data.Binary.Put (Put, runPut) +import qualified Data.ByteString as BS +import Data.ByteString.Internal (ByteString (..)) +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Lazy as LBS import Data.IORef import Data.List.Extra import Data.Maybe -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T import Data.Typeable -import Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Compat as GHC +import qualified Development.IDE.GHC.Compat.Parser as Compat +import qualified Development.IDE.GHC.Compat.Units as Compat +import Development.IDE.GHC.Compat.Util import Development.IDE.Types.Location -import FastString (mkFastString) -import FileCleanup -import Fingerprint import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable -import GHC.IO.BufferedIO (BufferedIO) -import GHC.IO.Device as IODevice +import GHC +import GHC.IO.BufferedIO (BufferedIO) +import GHC.IO.Device as IODevice import GHC.IO.Encoding import GHC.IO.Exception import GHC.IO.Handle.Internals import GHC.IO.Handle.Types -import GhcMonad -import HscTypes (CgGuts, HscEnv (hsc_dflags), - ModDetails, cg_binds, - cg_module, hsc_IC, ic_dflags, - md_types) -import Lexer -import Module (moduleNameSlashes) -import OccName (parenSymOcc) -import Outputable (Depth (..), Outputable, SDoc, - neverQualify, ppr, - showSDocUnsafe) -import RdrName (nameRdrName, rdrNameOcc) -import SrcLoc (mkRealSrcLoc) -import StringBuffer + import System.FilePath @@ -86,19 +116,15 @@ modifyDynFlags f = do -- We do not use setSessionDynFlags here since we handle package -- initialization separately. modifySession $ \h -> - h { hsc_dflags = newFlags, hsc_IC = (hsc_IC h) {ic_dflags = newFlags} } + hscSetFlags newFlags h { hsc_IC = (hsc_IC h) {ic_dflags = newFlags} } -- | Given a 'Unit' try and find the associated 'PackageConfig' in the environment. -lookupPackageConfig :: Unit -> HscEnv -> Maybe GHC.PackageConfig +lookupPackageConfig :: Unit -> HscEnv -> Maybe GHC.UnitInfo lookupPackageConfig unit env = - -- GHC.lookupPackage' False pkgConfigMap unit - GHC.lookupUnit' False pkgConfigMap prClsre unit + Compat.lookupUnit' False unitState 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 + unitState = Compat.getUnitInfoMap env + prClsre = preloadClosureUs env -- | Convert from the @text@ package to the @GHC@ 'StringBuffer'. @@ -112,7 +138,7 @@ runParser flags str parser = unP parser parseState filename = "" location = mkRealSrcLoc (mkFastString filename) 1 1 buffer = stringToStringBuffer str - parseState = mkPState flags buffer location + parseState = Compat.initParserState (Compat.initParserOpts flags) buffer location stringBufferToByteString :: StringBuffer -> ByteString stringBufferToByteString StringBuffer{..} = PS buf cur len @@ -125,9 +151,7 @@ prettyPrint :: Outputable a => a -> String prettyPrint = unsafePrintSDoc . ppr unsafePrintSDoc :: SDoc -> String -unsafePrintSDoc sdoc = oldRenderWithStyle dflags sdoc (oldMkUserStyle dflags neverQualify AllTheWay) - where - dflags = unsafeGlobalDynFlags +unsafePrintSDoc sdoc = showSDocUnsafe sdoc -- | Pretty print a 'RdrName' wrapping operators in parens printRdrName :: RdrName -> String @@ -148,13 +172,9 @@ evalGhcEnv env act = snd <$> runGhcEnv env act -- pieces, but designed to be more efficient than a standard 'runGhc'. runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a) runGhcEnv env act = do - filesToClean <- newIORef emptyFilesToClean - dirsToClean <- newIORef mempty - let dflags = (hsc_dflags env){filesToClean=filesToClean, dirsToClean=dirsToClean, useUnicode=True} - ref <- newIORef env{hsc_dflags=dflags} - res <- unGhc act (Session ref) `finally` do - cleanTempFiles dflags - cleanTempDirs dflags + hsc_env <- initTempFs env + ref <- newIORef hsc_env + res <- unGhc (withCleanupSession act) (Session ref) (,res) <$> readIORef ref -- | Given a module location, and its parse tree, figure out what is the include directory implied by it. @@ -218,7 +238,7 @@ hDuplicateTo' h1@(FileHandle path m1) h2@(FileHandle _ m2) = do -- _ <- hClose_help h2_ -- hClose_help does two things: -- 1. It flushes the buffer, we replicate this here - _ <- flushWriteBuffer h2_ `catch` \(_ :: IOException) -> pure () + _ <- flushWriteBuffer h2_ `E.catch` \(_ :: IOException) -> pure () -- 2. It closes the handle. This is redundant since dup2 takes care of that -- but even worse it is actively harmful! Once the handle has been closed -- another thread is free to reallocate it. This leads to dup2 failing with EBUSY diff --git a/ghcide/src/Development/IDE/GHC/Warnings.hs b/ghcide/src/Development/IDE/GHC/Warnings.hs index df7ef0fb39..720828fef3 100644 --- a/ghcide/src/Development/IDE/GHC/Warnings.hs +++ b/ghcide/src/Development/IDE/GHC/Warnings.hs @@ -4,15 +4,11 @@ module Development.IDE.GHC.Warnings(withWarnings) where -import Data.List -import ErrUtils -import GhcPlugins as GHC hiding (Var, (<>)) - import Control.Concurrent.Strict +import Data.List import qualified Data.Text as T -import Development.IDE.GHC.Compat (LogActionCompat, - logActionCompat) +import Development.IDE.GHC.Compat import Development.IDE.GHC.Error import Development.IDE.Types.Diagnostics import Language.LSP.Types (type (|?) (..)) @@ -27,16 +23,20 @@ import Language.LSP.Types (type (|?) (..)) -- https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640 -- which basically says that log_action is taken from the ModSummary when GHC feels like it. -- The given argument lets you refresh a ModSummary log_action -withWarnings :: T.Text -> ((ModSummary -> ModSummary) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) +withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a) withWarnings diagSource action = do warnings <- newVar [] 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 = logActionCompat newAction}} + newLogger env = pushLogHook (const (logActionCompat newAction)) (hsc_logger env) + res <- action $ \env -> putLogHook (newLogger env) env warns <- readVar warnings return (reverse $ concat warns, res) + where + third3 :: (c -> d) -> (a, b, c) -> (a, b, d) + third3 f (a, b, c) = (a, b, f c) attachReason :: WarnReason -> Diagnostic -> Diagnostic attachReason wr d = d{_code = InR <$> showReason wr} diff --git a/ghcide/src/Development/IDE/Import/FindImports.hs b/ghcide/src/Development/IDE/Import/FindImports.hs index 572a17c569..101e21fe32 100644 --- a/ghcide/src/Development/IDE/Import/FindImports.hs +++ b/ghcide/src/Development/IDE/Import/FindImports.hs @@ -13,25 +13,19 @@ module Development.IDE.Import.FindImports , mkImportDirs ) where +import Control.DeepSeq import Development.IDE.GHC.Compat as Compat +import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error as ErrUtils import Development.IDE.GHC.Orphans () import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location --- GHC imports -import Control.DeepSeq -import FastString -import Finder -import qualified Module as M -import Outputable (ppr, pprPanic, showSDoc) -import Packages -- standard imports import Control.Monad.Extra import Control.Monad.IO.Class import Data.List (isSuffixOf) import Data.Maybe -import DriverPhases import System.FilePath data Import @@ -75,7 +69,7 @@ locateModuleFile :: MonadIO m -> m (Maybe NormalizedFilePath) locateModuleFile import_dirss exts targetFor isSource modName = do let candidates import_dirs = - [ toNormalizedFilePath' (prefix M.moduleNameSlashes modName <.> maybeBoot ext) + [ toNormalizedFilePath' (prefix moduleNameSlashes modName <.> maybeBoot ext) | prefix <- import_dirs , ext <- exts] firstJustM (targetFor modName) (concatMap candidates import_dirss) where @@ -87,22 +81,22 @@ locateModuleFile import_dirss exts targetFor 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 -> (Compat.InstalledUnitId, DynFlags) -> Maybe (PackageName, [FilePath]) -mkImportDirs df (i, DynFlags{importPaths}) = (, importPaths) <$> getPackageName df i +mkImportDirs :: HscEnv -> (UnitId, DynFlags) -> Maybe (PackageName, [FilePath]) +mkImportDirs env (i, flags) = (, importPaths flags) <$> getUnitName env i -- | locate a module in either the file system or the package database. Where we go from *daml to -- Haskell locateModule :: MonadIO m - => DynFlags - -> [(Compat.InstalledUnitId, DynFlags)] -- ^ Import directories + => HscEnv + -> [(UnitId, DynFlags)] -- ^ Import directories -> [String] -- ^ File extensions -> (ModuleName -> NormalizedFilePath -> m (Maybe NormalizedFilePath)) -- ^ does file exist predicate -> Located ModuleName -- ^ Module name -> Maybe FastString -- ^ Package name -> Bool -- ^ Is boot module -> m (Either [FileDiagnostic] Import) -locateModule dflags comp_info exts targetFor modName mbPkgName isSource = do +locateModule env comp_info exts targetFor modName mbPkgName isSource = do case mbPkgName of -- "this" means that we should only look in the current package Just "this" -> do @@ -111,7 +105,7 @@ locateModule dflags comp_info exts targetFor modName mbPkgName isSource = do Just pkgName | Just dirs <- lookup (PackageName pkgName) import_paths -> lookupLocal [dirs] - | otherwise -> lookupInPackageDB dflags + | otherwise -> lookupInPackageDB env Nothing -> do -- first try to find the module as a file. If we can't find it try to find it in the package -- database. @@ -120,10 +114,11 @@ locateModule dflags comp_info exts targetFor modName mbPkgName isSource = do -- each component will end up being found in the wrong place and cause a multi-cradle match failure. mbFile <- locateModuleFile (importPaths dflags : map snd import_paths) exts targetFor isSource $ unLoc modName case mbFile of - Nothing -> lookupInPackageDB dflags + Nothing -> lookupInPackageDB env Just file -> toModLocation file where - import_paths = mapMaybe (mkImportDirs dflags) comp_info + dflags = hsc_dflags env + import_paths = mapMaybe (mkImportDirs env) comp_info toModLocation file = liftIO $ do loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file) return $ Right $ FileImport $ ArtifactsLocation file (Just loc) (not isSource) @@ -131,20 +126,21 @@ locateModule dflags comp_info exts targetFor modName mbPkgName isSource = do lookupLocal dirs = do mbFile <- locateModuleFile dirs exts targetFor isSource $ unLoc modName case mbFile of - Nothing -> return $ Left $ notFoundErr dflags modName $ LookupNotFound [] + Nothing -> return $ Left $ notFoundErr env modName $ LookupNotFound [] Just file -> toModLocation file - lookupInPackageDB dfs = - case oldLookupModuleWithSuggestions dfs (unLoc modName) mbPkgName of + lookupInPackageDB env = + case Compat.lookupModuleWithSuggestions env (unLoc modName) mbPkgName of LookupFound _m _pkgConfig -> return $ Right PackageImport - reason -> return $ Left $ notFoundErr dfs modName reason + reason -> return $ Left $ notFoundErr env modName reason -- | Don't call this on a found module. -notFoundErr :: DynFlags -> Located M.ModuleName -> LookupResult -> [FileDiagnostic] -notFoundErr dfs modName reason = - mkError' $ ppr' $ cannotFindModule dfs modName0 $ lookupToFindResult reason +notFoundErr :: HscEnv -> Located ModuleName -> LookupResult -> [FileDiagnostic] +notFoundErr env modName reason = + mkError' $ ppr' $ cannotFindModule env modName0 $ lookupToFindResult reason where - mkError' = diagFromString "not found" DsError (getLoc modName) + dfs = hsc_dflags env + mkError' = diagFromString "not found" DsError (Compat.getLoc modName) modName0 = unLoc modName ppr' = showSDoc dfs -- We convert the lookup result to a find result to reuse GHC's cannotFindMoudle pretty printer. @@ -155,12 +151,12 @@ notFoundErr dfs modName reason = LookupMultiple rs -> FoundMultiple rs LookupHidden pkg_hiddens mod_hiddens -> notFound - { fr_pkgs_hidden = map (moduleUnitId . fst) pkg_hiddens - , fr_mods_hidden = map (moduleUnitId . fst) mod_hiddens + { fr_pkgs_hidden = map (moduleUnit . fst) pkg_hiddens + , fr_mods_hidden = map (moduleUnit . fst) mod_hiddens } LookupUnusable unusable -> let unusables' = map get_unusable unusable - get_unusable (m, ModUnusable r) = (moduleUnitId m, r) + get_unusable (m, ModUnusable r) = (moduleUnit m, r) get_unusable (_, r) = pprPanic "findLookupResult: unexpected origin" (ppr r) in notFound {fr_unusables = unusables'} diff --git a/ghcide/src/Development/IDE/LSP/Outline.hs b/ghcide/src/Development/IDE/LSP/Outline.hs index 44714f23d7..82bdc573cd 100644 --- a/ghcide/src/Development/IDE/LSP/Outline.hs +++ b/ghcide/src/Development/IDE/LSP/Outline.hs @@ -29,8 +29,6 @@ import Language.LSP.Types (DocumentSymbol (..), SymbolKind (SkConstructor, SkField, SkFile, SkFunction, SkInterface, SkMethod, SkModule, SkObject, SkStruct, SkTypeParameter, SkUnknown), TextDocumentIdentifier (TextDocumentIdentifier), type (|?) (InL), uriToFilePath) -import Outputable (Outputable, ppr, - showSDocUnsafe) moduleOutline :: IdeState -> DocumentSymbolParams -> LspM c (Either ResponseError (List DocumentSymbol |? List SymbolInformation)) @@ -44,7 +42,7 @@ moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentif -> let declSymbols = mapMaybe documentSymbolForDecl hsmodDecls moduleSymbol = hsmodName >>= \case - (L (OldRealSrcSpan l) m) -> Just $ + (L (RealSrcSpan l _) m) -> Just $ (defDocumentSymbol l :: DocumentSymbol) { _name = pprText m , _kind = SkFile @@ -73,7 +71,7 @@ moduleOutline ideState DocumentSymbolParams{ _textDocument = TextDocumentIdentif Nothing -> pure $ Right $ InL (List []) documentSymbolForDecl :: Located (HsDecl GhcPs) -> Maybe DocumentSymbol -documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) +documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n <> (case pprText fdTyVars of @@ -83,7 +81,7 @@ documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ FamDecl { tcdFam = FamilyDe , _detail = Just $ pprText fdInfo , _kind = SkFunction } -documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) +documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name <> (case pprText tcdTyVars of @@ -99,11 +97,11 @@ documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ ClassDecl { tcdLName = L _ , _kind = SkMethod , _selectionRange = realSrcSpanToRange l' } - | L (OldRealSrcSpan l) (ClassOpSig _ False names _) <- tcdSigs - , L (OldRealSrcSpan l') n <- names + | L (RealSrcSpan l _) (ClassOpSig _ False names _) <- tcdSigs + , L (RealSrcSpan l' _) n <- names ] } -documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) +documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name , _kind = SkStruct @@ -115,8 +113,8 @@ documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ n , _selectionRange = realSrcSpanToRange l' , _children = conArgRecordFields (con_args x) } - | L (OldRealSrcSpan l ) x <- dd_cons - , L (OldRealSrcSpan l') n <- getConNames' x + | L (RealSrcSpan l _ ) x <- dd_cons + , L (RealSrcSpan l' _) n <- getConNames' x ] } where @@ -127,48 +125,48 @@ documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ DataDecl { tcdLName = L _ n , _kind = SkField } | L _ cdf <- lcdfs - , L (OldRealSrcSpan l) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf + , L (RealSrcSpan l _) n <- rdrNameFieldOcc . unLoc <$> cd_fld_names cdf ] conArgRecordFields _ = Nothing -documentSymbolForDecl (L (OldRealSrcSpan l) (TyClD _ SynDecl { tcdLName = L (OldRealSrcSpan l') n })) = Just +documentSymbolForDecl (L (RealSrcSpan l _) (TyClD _ SynDecl { tcdLName = L (RealSrcSpan l' _) n })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName n , _kind = SkTypeParameter , _selectionRange = realSrcSpanToRange l' } -documentSymbolForDecl (L (OldRealSrcSpan l) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) +documentSymbolForDecl (L (RealSrcSpan l _) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText cid_poly_ty , _kind = SkInterface } -documentSymbolForDecl (L (OldRealSrcSpan l) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) +documentSymbolForDecl (L (RealSrcSpan 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 (OldRealSrcSpan l) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl HsIB { hsib_body = FamEqn { feqn_tycon, feqn_pats } } })) +documentSymbolForDecl (L (RealSrcSpan 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 (OldRealSrcSpan l) (DerivD _ DerivDecl { deriv_type })) = +documentSymbolForDecl (L (RealSrcSpan l _) (DerivD _ DerivDecl { deriv_type })) = gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) -> (defDocumentSymbol l :: DocumentSymbol) { _name = pprText @(HsType GhcPs) name , _kind = SkInterface } -documentSymbolForDecl (L (OldRealSrcSpan l) (ValD _ FunBind{fun_id = L _ name})) = Just +documentSymbolForDecl (L (RealSrcSpan l _) (ValD _ FunBind{fun_id = L _ name})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = showRdrName name , _kind = SkFunction } -documentSymbolForDecl (L (OldRealSrcSpan l) (ValD _ PatBind{pat_lhs})) = Just +documentSymbolForDecl (L (RealSrcSpan l _) (ValD _ PatBind{pat_lhs})) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = pprText pat_lhs , _kind = SkFunction } -documentSymbolForDecl (L (OldRealSrcSpan l) (ForD _ x)) = Just +documentSymbolForDecl (L (RealSrcSpan l _) (ForD _ x)) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = case x of ForeignImport{} -> name @@ -202,7 +200,7 @@ documentSymbolForImportSummary importSymbols = } documentSymbolForImport :: Located (ImportDecl GhcPs) -> Maybe DocumentSymbol -documentSymbolForImport (L (OldRealSrcSpan l) ImportDecl { ideclName, ideclQualified }) = Just +documentSymbolForImport (L (RealSrcSpan l _) ImportDecl { ideclName, ideclQualified }) = Just (defDocumentSymbol l :: DocumentSymbol) { _name = "import " <> pprText ideclName , _kind = SkModule diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 43354a11e9..edabeab3dd 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -18,8 +18,6 @@ module Development.IDE.Plugin.CodeAction , matchRegExMultipleImports ) where -import Bag (bagToList, - isEmptyBag) import Control.Applicative ((<|>)) import Control.Arrow (second, (>>>)) @@ -44,6 +42,7 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Rules import Development.IDE.Core.Service import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error import Development.IDE.GHC.Util (prettyPrint, printRdrName, @@ -57,8 +56,6 @@ import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Options import qualified GHC.LanguageExtensions as Lang -import HscTypes (ImportedModsVal (..), - importedByUser) import Ide.PluginUtils (subRange) import Ide.Types import qualified Language.LSP.Server as LSP @@ -77,18 +74,6 @@ import Language.LSP.Types (CodeAction ( type (|?) (InR), uriToFilePath) import Language.LSP.VFS -import Module (moduleEnvElts) -import OccName -import Outputable (Outputable, - ppr, - showSDoc, - showSDocUnsafe) -import RdrName (GlobalRdrElt (..), - lookupGlobalRdrEnv) -import SrcLoc (realSrcSpanEnd, - realSrcSpanStart) -import TcRnTypes (ImportAvails (..), - TcGblEnv (..)) import Text.Regex.TDFA (mrAfter, (=~), (=~~)) @@ -256,7 +241,7 @@ suggestHideShadow ps@(L _ HsModule {hsmodImports}) fileContents mTcM mHar Diagno | Just tcM <- mTcM, Just har <- mHar, [s'] <- [x | (x, "") <- readSrcSpan $ T.unpack s], - isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (OldRealSrcSpan s'), + isUnusedImportedId tcM har (T.unpack identifier) (T.unpack modName) (RealSrcSpan s' Nothing), mDecl <- findImportDeclByModuleName hsmodImports $ T.unpack modName, title <- "Hide " <> identifier <> " from " <> modName = if modName == "Prelude" && null mDecl @@ -440,10 +425,10 @@ suggestDeleteUnusedBinding findRelatedSpans indexedContent name - (L (OldRealSrcSpan l) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = + (L (RealSrcSpan l _) (ValD _ (extractNameAndMatchesFromFunBind -> Just (lname, matches)))) = case lname of (L nLoc _name) | isTheBinding nLoc -> - let findSig (L (OldRealSrcSpan l) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig + let findSig (L (RealSrcSpan l _) (SigD _ sig)) = findRelatedSigSpan indexedContent name l sig findSig _ = [] in extendForSpaces indexedContent (toRange l) : @@ -466,7 +451,7 @@ suggestDeleteUnusedBinding let maybeSpan = findRelatedSigSpan1 name sig in case maybeSpan of Just (_span, True) -> pure $ extendForSpaces indexedContent $ toRange l -- a :: Int - Just (OldRealSrcSpan span, False) -> pure $ toRange span -- a, b :: Int, a is unused + Just (RealSrcSpan span _, False) -> pure $ toRange span -- a, b :: Int, a is unused _ -> [] -- Second of the tuple means there is only one match @@ -517,10 +502,10 @@ suggestDeleteUnusedBinding indexedContent name lsigs - (L (OldRealSrcSpan l) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = + (L (RealSrcSpan l _) (extractNameAndMatchesFromFunBind -> Just (lname, matches))) = if isTheBinding (getLoc lname) then - let findSig (L (OldRealSrcSpan l) sig) = findRelatedSigSpan indexedContent name l sig + let findSig (L (RealSrcSpan l _) sig) = findRelatedSigSpan indexedContent name l sig findSig _ = [] in extendForSpaces indexedContent (toRange l) : concatMap findSig lsigs else concatMap (findRelatedSpanForMatch indexedContent name) matches @@ -562,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 (OldRealSrcSpan l) exports) = + needsComma source (L (RealSrcSpan l _) exports) = let closeParan = _end $ realSrcSpanToRange l lastExport = fmap _end . getLocatedRange $ last exports in case lastExport of @@ -690,7 +675,7 @@ newDefinitionAction :: IdeOptions -> ParsedModule -> Range -> T.Text -> T.Text - newDefinitionAction IdeOptions{..} parsedModule Range{_start} name typ | Range _ lastLineP : _ <- [ realSrcSpanToRange sp - | (L l@(OldRealSrcSpan sp) _) <- hsmodDecls + | (L l@(RealSrcSpan sp _) _) <- hsmodDecls , _start `isInsideSrcSpan` l] , nextLineP <- Position{ _line = _line lastLineP + 1, _character = 0} = [ ("Define " <> sig @@ -1015,10 +1000,10 @@ disambiguateSymbol pm fileContents Diagnostic {..} (T.unpack -> symbol) = \case liftParseAST @(HsExpr GhcPs) df $ prettyPrint $ HsVar @GhcPs noExtField $ - L (oldUnhelpfulSpan "") rdr + L (mkGeneralSrcSpan "") rdr else Rewrite (rangeToSrcSpan "" _range) $ \df -> liftParseAST @RdrName df $ - prettyPrint $ L (oldUnhelpfulSpan "") rdr + prettyPrint $ L (mkGeneralSrcSpan "") rdr ] findImportDeclByRange :: [LImportDecl GhcPs] -> Range -> Maybe (LImportDecl GhcPs) @@ -1316,7 +1301,7 @@ findPositionNoImports (Just hsmodName) _ _ = findPositionFromImportsOrModuleDecl findPositionFromImportsOrModuleDecl :: HasSrcSpan a => t -> (t -> a) -> Bool -> Maybe ((Int, Int), Int) findPositionFromImportsOrModuleDecl hsField f hasImports = case getLoc (f hsField) of - OldRealSrcSpan s -> + RealSrcSpan s _ -> let col = calcCol s in Just ((srcLocLine (realSrcSpanEnd s), col), col) _ -> Nothing diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs index 2f552e782f..b79775c8c4 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs @@ -29,21 +29,17 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromJust, isNothing, mapMaybe) import qualified Data.Text as T -import Development.IDE.GHC.Compat hiding (parseExpr) +import Development.IDE.GHC.Compat +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Error import Development.IDE.GHC.ExactPrint (ASTElement (parseAST), Annotate) import Development.IDE.Spans.Common -import FieldLabel (flLabel) import GHC.Exts (IsList (fromList)) -import GhcPlugins (mkRdrUnqual, sigPrec) import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types (DeltaPos (DP), KeywordId (G), mkAnnKey) import Language.LSP.Types -import OccName -import Outputable (ppr, showSDocUnsafe) -import Retrie.GHC (rdrNameOcc, unpackFS) ------------------------------------------------------------------------------ @@ -453,5 +449,5 @@ deleteFromImport (T.pack -> symbol) (L l idecl) llies@(L lieLoc lies) _ = do ty wild (filter ((/= symbol) . unqualIEWrapName . unLoc) cons) - (filter ((/= symbol) . T.pack . unpackFS . flLabel . unLoc) flds) + (filter ((/= symbol) . T.pack . Util.unpackFS . flLabel . unLoc) flds) killLie v = Just v diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 9b1b203262..7a52d0a0ba 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} @@ -31,7 +30,6 @@ import Development.IDE.GHC.ExactPrint (Annotated (annsA) import Development.IDE.GHC.Util (prettyPrint) import Development.IDE.Graph import Development.IDE.Graph.Classes -import Development.IDE.Import.FindImports import Development.IDE.Plugin.CodeAction (newImport, newImportToEdit) import Development.IDE.Plugin.CodeAction.ExactPrint @@ -48,11 +46,6 @@ 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 c3f1de1a4a..fbf66ab366 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -26,27 +26,17 @@ import Data.Maybe (fromMaybe, isJust, import qualified Data.Text as T import qualified Text.Fuzzy as Fuzzy -import HscTypes -import Name -import RdrName -import Type -#if MIN_VERSION_ghc(8,10,0) -import Coercion -import Pair -import Predicate (isDictTy) -#endif - -import ConLike import Control.Monad import Data.Aeson (ToJSON (toJSON)) import Data.Either (fromRight) import Data.Functor import qualified Data.HashMap.Strict as HM -import qualified Data.Set as Set import qualified Data.HashSet as HashSet +import qualified Data.Set as Set import Development.IDE.Core.Compile import Development.IDE.Core.PositionMapping -import Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Compat as GHC hiding (ppr) +import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error import Development.IDE.GHC.Util import Development.IDE.Plugin.Completions.Types @@ -56,15 +46,12 @@ import Development.IDE.Spans.LocalBindings import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Options -import GhcPlugins (flLabel, unpackFS) import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), PluginId) import Language.LSP.Types import Language.LSP.Types.Capabilities import qualified Language.LSP.VFS as VFS -import Outputable (Outputable) -import TyCoRep -- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs @@ -266,7 +253,7 @@ mkNameCompItem doc thingParent origName origMod thingType isInfix docs !imp = CI getArgs t | isPredTy t = [] | isDictTy t = [] - | isForAllTy t = getArgs $ snd (splitForAllTys t) + | isForAllTy t = getArgs $ snd (splitForAllTyCoVars t) | isFunTy t = let (args, ret) = splitFunTys t in if isForAllTy ret @@ -334,7 +321,7 @@ cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do packageState = hscEnv env curModName = moduleName curMod - importMap = Map.fromList [ (l, imp) | imp@(L (OldRealSrcSpan l) _) <- limports ] + importMap = Map.fromList [ (l, imp) | imp@(L (RealSrcSpan l _) _) <- limports ] iDeclToModName :: ImportDecl name -> ModuleName iDeclToModName = unLoc . ideclName @@ -611,8 +598,8 @@ getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qu | otherwise = [] if - -- TODO: handle multiline imports - | "import " `T.isPrefixOf` fullLine + -- TODO: handle multiline imports + | "import " `T.isPrefixOf` fullLine && (List.length (words (T.unpack fullLine)) >= 2) && "(" `isInfixOf` T.unpack fullLine -> do diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs index b8660887b6..3eea61d146 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs @@ -9,11 +9,11 @@ module Development.IDE.Plugin.Completions.Types ( import Control.DeepSeq import qualified Data.Map as Map import qualified Data.Text as T -import SrcLoc import Data.Aeson (FromJSON, ToJSON) import Data.Text (Text) import Development.IDE.Spans.Common +import Development.IDE.GHC.Compat import GHC.Generics (Generic) import Ide.Plugin.Config (Config) import Ide.Plugin.Properties diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs index 1dbe0b2a38..7a1a9469ac 100644 --- a/ghcide/src/Development/IDE/Plugin/Test.hs +++ b/ghcide/src/Development/IDE/Plugin/Test.hs @@ -28,13 +28,11 @@ import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.Graph (Action) import Development.IDE.LSP.Server -import Development.IDE.Plugin import qualified Development.IDE.Plugin as P import Development.IDE.Types.Action import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) import Development.IDE.Types.Location (fromUri) import GHC.Generics (Generic) -import GhcPlugins (HscEnv (hsc_dflags)) import Ide.Types import qualified Language.LSP.Server as LSP import Language.LSP.Types @@ -52,7 +50,7 @@ data TestRequest newtype WaitForIdeRuleResult = WaitForIdeRuleResult { ideResultSuccess::Bool} deriving newtype (FromJSON, ToJSON) -plugin :: Plugin c +plugin :: P.Plugin c plugin = def { P.pluginRules = return (), P.pluginHandlers = requestHandler (SCustomMethod "test") testRequestHandler' diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 327ac65513..6ce6001fa3 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -12,7 +12,6 @@ module Development.IDE.Plugin.TypeLenses ( GlobalBindingTypeSigsResult (..), ) where -import Avail (availsToNameSet) import Control.DeepSeq (rwhnf) import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) @@ -42,13 +41,6 @@ import Development.IDE.Types.Location (Position (Position, _chara toNormalizedFilePath', uriToFilePath') import GHC.Generics (Generic) -import GhcPlugins (GlobalRdrEnv, - HscEnv (hsc_dflags), SDoc, - elemNameSet, getSrcSpan, - idName, mkRealSrcLoc, - realSrcLocSpan, - tidyOpenType) -import HscTypes (mkPrintUnqualified) import Ide.Plugin.Config (Config) import Ide.Plugin.Properties import Ide.PluginUtils (mkLspCommand, @@ -73,16 +65,6 @@ import Language.LSP.Types (ApplyWorkspaceEditParams ( TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), WorkspaceEdit (WorkspaceEdit)) -import Outputable (showSDocForUser) -import PatSyn (PatSyn, mkPatSyn, - patSynBuilder, - patSynFieldLabels, - patSynIsInfix, - patSynMatcher, patSynName, - patSynSig, pprPatSynType) -import TcEnv (tcInitTidyEnv) -import TcRnMonad (initTcWithGbl) -import TcRnTypes (TcGblEnv (..)) import Text.Regex.TDFA ((=~), (=~~)) typeLensCommandId :: T.Text @@ -185,7 +167,7 @@ suggestLocalSignature isQuickFix mTmr mBindings Diagnostic{_message, _range = _r , Just TcModuleResult{tmrTypechecked = TcGblEnv{tcg_rdr_env, tcg_sigs}} <- mTmr , -- not a top-level thing, to avoid duplication not $ name `elemNameSet` tcg_sigs - , tyMsg <- showSDocForUser unsafeGlobalDynFlags (mkPrintUnqualified unsafeGlobalDynFlags tcg_rdr_env) $ pprSigmaType ty + , tyMsg <- printSDocQualifiedUnsafe (mkPrintUnqualifiedDefault tcg_rdr_env) $ pprSigmaType ty , signature <- T.pack $ printName name <> " :: " <> tyMsg , startCharacter <- _character _start , startOfLine <- Position (_line _start) startCharacter @@ -229,8 +211,8 @@ instance A.FromJSON Mode where -------------------------------------------------------------------------------- -showDocRdrEnv :: DynFlags -> GlobalRdrEnv -> SDoc -> String -showDocRdrEnv dflags rdrEnv = showSDocForUser dflags (mkPrintUnqualified dflags rdrEnv) +showDocRdrEnv :: HscEnv -> GlobalRdrEnv -> SDoc -> String +showDocRdrEnv env rdrEnv = showSDocForUser (hsc_dflags env) (mkPrintUnqualified (hsc_dflags env) rdrEnv) data GetGlobalBindingTypeSigs = GetGlobalBindingTypeSigs deriving (Generic, Show, Eq, Ord, Hashable, NFData, Binary) @@ -269,9 +251,8 @@ gblBindingType (Just hsc) (Just gblEnv) = do sigs = tcg_sigs gblEnv binds = collectHsBindsBinders $ tcg_binds gblEnv patSyns = tcg_patsyns gblEnv - dflags = hsc_dflags hsc rdrEnv = tcg_rdr_env gblEnv - showDoc = showDocRdrEnv dflags rdrEnv + showDoc = showDocRdrEnv hsc rdrEnv hasSig :: (Monad m) => Name -> m a -> m (Maybe a) hasSig name f = whenMaybe (name `elemNameSet` sigs) f bindToSig id = do diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 2c878ebe1b..36bdd58303 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -30,25 +30,16 @@ import Language.LSP.Types import Development.IDE.Core.PositionMapping import Development.IDE.Core.RuleTypes import Development.IDE.GHC.Compat +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.Spans.Common import Development.IDE.Types.Options --- GHC API imports -import FastString (unpackFS) -import IfaceType -import Name -import NameEnv -import Outputable hiding ((<>)) -import SrcLoc -import TyCoRep hiding (FunTy) -import TyCon -import qualified Var - import Control.Applicative import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe +import Data.Coerce (coerce) import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as M import Data.Maybe @@ -130,12 +121,12 @@ referencesAtPoint hiedb nfp pos refs = do Just mod -> do -- Look for references (strictly in project files, not dependencies), -- excluding the files in the FOIs (since those are in foiRefs) - rows <- liftIO $ findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude + rows <- liftIO $ findReferences hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude pure $ mapMaybe rowToLoc rows typeRefs <- forM names $ \name -> case nameModule_maybe name of Just mod | isTcClsNameSpace (occNameSpace $ nameOccName name) -> do - refs <- liftIO $ findTypeRefs hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) exclude + refs <- liftIO $ findTypeRefs hiedb True (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) exclude pure $ mapMaybe typeRowToLoc refs _ -> pure [] pure $ nubOrd $ foiRefs ++ concat nonFOIRefs ++ concat typeRefs @@ -208,10 +199,10 @@ atPoint :: IdeOptions -> HieAstResult -> DocAndKindMap - -> DynFlags + -> HscEnv -> Position -> Maybe (Maybe Range, [T.Text]) -atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) df pos = listToMaybe $ pointCommand hf pos hoverInfo +atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ pointCommand hf pos hoverInfo where -- Hover info for values/data hoverInfo ast = (Just range, prettyNames ++ pTypes) @@ -240,10 +231,10 @@ atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) df pos = listToMaybe $ po prettyPackageName n = do m <- nameModule_maybe n - let pid = moduleUnitId m - conf <- lookupPackage df pid - let pkgName = T.pack $ packageNameString conf - version = T.pack $ showVersion (packageVersion conf) + let pid = moduleUnit m + conf <- lookupUnit env pid + let pkgName = T.pack $ unitPackageNameString conf + version = T.pack $ showVersion (unitPackageVersion conf) pure $ " *(" <> pkgName <> "-" <> version <> ")*" prettyTypes = map (("_ :: "<>) . prettyType) types @@ -300,10 +291,10 @@ typeLocationsAtPoint hiedb lookupModule _ideOptions pos (HAR _ ast _ _ hieKind) in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) namesInType :: Type -> [Name] -namesInType (TyVarTy n) = [Var.varName n] +namesInType (TyVarTy n) = [varName n] namesInType (AppTy a b) = getTypes [a,b] namesInType (TyConApp tc ts) = tyConName tc : getTypes ts -namesInType (ForAllTy b t) = Var.varName (binderVar b) : namesInType t +namesInType (ForAllTy b t) = varName (binderVar b) : namesInType t namesInType (FunTy a b) = getTypes [a,b] namesInType (CastTy t _) = namesInType t namesInType (LitTy _) = [] @@ -333,9 +324,9 @@ 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@(OldRealSrcSpan rsp) + sp@(RealSrcSpan rsp _) -- Lookup in the db if we got a location in a boot file - | fs <- unpackFS (srcSpanFile rsp) + | fs <- Util.unpackFS (srcSpanFile rsp) , not $ "boot" `isSuffixOf` fs -> do itExists <- liftIO $ doesFileExist fs @@ -353,7 +344,7 @@ nameToLocation hiedb lookupModule name = runMaybeT $ -- In this case the interface files contain garbage source spans -- so we instead read the .hie files to get useful source spans. mod <- MaybeT $ return $ nameModule_maybe name - erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnitId mod) + erow <- liftIO $ findDef hiedb (nameOccName name) (Just $ moduleName mod) (Just $ moduleUnit mod) case erow of [] -> do -- If the lookup failed, try again without specifying a unit-id. @@ -398,7 +389,17 @@ defRowToSymbolInfo _ = Nothing pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a] pointCommand hf pos k = catMaybes $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> - case selectSmallestContaining (sp fs) ast of + -- Since GHC 9.2: + -- getAsts :: Map HiePath (HieAst a) + -- type HiePath = LexialFastString + -- + -- but before: + -- getAsts :: Map HiePath (HieAst a) + -- type HiePath = FastString + -- + -- 'coerce' here to avoid an additional function for maintaining + -- backwards compatibility. + case selectSmallestContaining (sp $ coerce fs) ast of Nothing -> Nothing Just ast' -> Just $ k ast' where diff --git a/ghcide/src/Development/IDE/Spans/Common.hs b/ghcide/src/Development/IDE/Spans/Common.hs index 895379e89a..0a60120138 100644 --- a/ghcide/src/Development/IDE/Spans/Common.hs +++ b/ghcide/src/Development/IDE/Spans/Common.hs @@ -23,20 +23,13 @@ import Data.Maybe import qualified Data.Text as T import GHC.Generics -import ConLike -import DynFlags import GHC -import NameEnv -import Outputable hiding ((<>)) -import Var -import Development.IDE.GHC.Compat (oldMkUserStyle, - oldRenderWithStyle) +import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util import qualified Documentation.Haddock.Parser as H import qualified Documentation.Haddock.Types as H -import RdrName (rdrNameOcc) type DocMap = NameEnv SpanDoc type KindMap = NameEnv TyThing @@ -48,11 +41,7 @@ showSD :: SDoc -> T.Text showSD = T.pack . unsafePrintSDoc showNameWithoutUniques :: Outputable a => a -> T.Text -showNameWithoutUniques = T.pack . prettyprint - where - dyn = unsafeGlobalDynFlags `gopt_set` Opt_SuppressUniques - prettyprint x = oldRenderWithStyle dyn (ppr x) style - style = oldMkUserStyle dyn neverQualify AllTheWay +showNameWithoutUniques = T.pack . printNameWithoutUniques -- | Shows IEWrappedName, without any modifier, qualifier or unique identifier. unqualIEWrapName :: IEWrappedName RdrName -> T.Text @@ -66,9 +55,9 @@ safeTyThingType (ATyCon tycon) = Just (tyConKind tycon) safeTyThingType _ = Nothing safeTyThingId :: TyThing -> Maybe Id -safeTyThingId (AnId i) = Just i -safeTyThingId (AConLike conLike) = conLikeWrapId_maybe conLike -safeTyThingId _ = Nothing +safeTyThingId (AnId i) = Just i +safeTyThingId (AConLike (RealDataCon dataCon)) = Just (dataConWrapId dataCon) +safeTyThingId _ = Nothing -- Possible documentation for an element in the code data SpanDoc diff --git a/ghcide/src/Development/IDE/Spans/Documentation.hs b/ghcide/src/Development/IDE/Spans/Documentation.hs index 95cc889d40..8afe4f72fe 100644 --- a/ghcide/src/Development/IDE/Spans/Documentation.hs +++ b/ghcide/src/Development/IDE/Spans/Documentation.hs @@ -13,6 +13,7 @@ module Development.IDE.Spans.Documentation ( ) where import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Extra (findM) import Data.Either import Data.Foldable @@ -24,20 +25,13 @@ import qualified Data.Text as T import Development.IDE.Core.Compile import Development.IDE.Core.RuleTypes import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util import Development.IDE.GHC.Error import Development.IDE.Spans.Common import System.Directory import System.FilePath -import ExtractDocs -import FastString -import GhcMonad -import HscTypes (HscEnv (hsc_dflags)) import Language.LSP.Types (filePathToUri, getUri) -import Name -import NameEnv -import SrcLoc (RealLocated) -import TcRnTypes mkDocMap :: HscEnv @@ -86,12 +80,11 @@ getDocumentationsTryGhc env mod names = do -- Get the uris to the documentation and source html pages if they exist getUris name = do - let df = hsc_dflags env (docFu, srcFu) <- case nameModule_maybe name of Just mod -> liftIO $ do - doc <- toFileUriText $ lookupDocHtmlForModule df mod - src <- toFileUriText $ lookupSrcHtmlForModule df mod + doc <- toFileUriText $ lookupDocHtmlForModule env mod + src <- toFileUriText $ lookupSrcHtmlForModule env mod return (doc, src) Nothing -> pure (Nothing, Nothing) let docUri = (<> "#" <> selector <> showNameWithoutUniques name) <$> docFu @@ -183,28 +176,28 @@ docHeaders = mapMaybe (\(L _ x) -> wrk x) -- | Given a module finds the local @doc/html/Foo-Bar-Baz.html@ page. -- An example for a cabal installed module: -- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/Data-Vector-Primitive.html@ -lookupDocHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath) +lookupDocHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath) lookupDocHtmlForModule = lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir modDocName <.> "html") -- | Given a module finds the hyperlinked source @doc/html/src/Foo.Bar.Baz.html@ page. -- An example for a cabal installed module: -- @~/.cabal/store/ghc-8.10.1/vctr-0.12.1.2-98e2e861/share/doc/html/src/Data.Vector.Primitive.html@ -lookupSrcHtmlForModule :: DynFlags -> Module -> IO (Maybe FilePath) +lookupSrcHtmlForModule :: HscEnv -> Module -> IO (Maybe FilePath) lookupSrcHtmlForModule = lookupHtmlForModule (\pkgDocDir modDocName -> pkgDocDir "src" modDocName <.> "html") -lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> DynFlags -> Module -> IO (Maybe FilePath) -lookupHtmlForModule mkDocPath df m = do +lookupHtmlForModule :: (FilePath -> FilePath -> FilePath) -> HscEnv -> Module -> IO (Maybe FilePath) +lookupHtmlForModule mkDocPath hscEnv m = do -- try all directories - let mfs = fmap (concatMap go) (lookupHtmls df ui) + let mfs = fmap (concatMap go) (lookupHtmls hscEnv ui) html <- findM doesFileExist (concat . maybeToList $ mfs) -- canonicalize located html to remove /../ indirection which can break some clients -- (vscode on Windows at least) traverse canonicalizePath html where go pkgDocDir = map (mkDocPath pkgDocDir) mns - ui = moduleUnitId m + ui = moduleUnit m -- try to locate html file from most to least specific name e.g. -- first Language.LSP.Types.Uri.html and Language-Haskell-LSP-Types-Uri.html -- then Language.LSP.Types.html and Language-Haskell-LSP-Types.html etc. @@ -213,8 +206,8 @@ lookupHtmlForModule mkDocPath df m = do -- The file might use "." or "-" as separator map (`intercalate` chunks) [".", "-"] -lookupHtmls :: DynFlags -> Unit -> Maybe [FilePath] +lookupHtmls :: HscEnv -> 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 - map takeDirectory . haddockInterfaces <$> lookupPackage df ui + map takeDirectory . unitHaddockInterfaces <$> lookupUnit df ui diff --git a/ghcide/src/Development/IDE/Spans/LocalBindings.hs b/ghcide/src/Development/IDE/Spans/LocalBindings.hs index cf23e37040..deb1668cfd 100644 --- a/ghcide/src/Development/IDE/Spans/LocalBindings.hs +++ b/ghcide/src/Development/IDE/Spans/LocalBindings.hs @@ -20,12 +20,13 @@ import qualified Data.Set as S import Development.IDE.GHC.Compat (Name, RefMap, Scope (..), Type, getBindSiteFromContext, getScopeFromContext, identInfo, - identType) + identType, NameEnv, nameEnvElts, + unitNameEnv, isSystemName, + RealSrcSpan, realSrcSpanStart, + realSrcSpanEnd) + import Development.IDE.GHC.Error import Development.IDE.Types.Location -import Name (isSystemName) -import NameEnv -import SrcLoc ------------------------------------------------------------------------------ -- | Turn a 'RealSrcSpan' into an 'Interval'. diff --git a/ghcide/src/Development/IDE/Types/Exports.hs b/ghcide/src/Development/IDE/Types/Exports.hs index 58603efb1b..cee3024105 100644 --- a/ghcide/src/Development/IDE/Types/Exports.hs +++ b/ghcide/src/Development/IDE/Types/Exports.hs @@ -7,10 +7,11 @@ module Development.IDE.Types.Exports createExportsMap, createExportsMapMg, createExportsMapTc, - buildModuleExportMapFrom -,createExportsMapHieDb,size) where + buildModuleExportMapFrom, + createExportsMapHieDb, + size, + ) where -import Avail (AvailInfo (..)) import Control.DeepSeq (NFData (..)) import Control.Monad import Data.Bifunctor (Bifunctor (second)) @@ -24,12 +25,8 @@ import Data.Text (Text, pack) import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util -import FieldLabel (flSelector) import GHC.Generics (Generic) -import GhcPlugins (IfaceExport, ModGuts (..)) import HieDb -import Name -import TcRnTypes (TcGblEnv (..)) data ExportsMap = ExportsMap @@ -81,8 +78,12 @@ renderIEWrapped n occ = occName n mkIdentInfos :: Text -> AvailInfo -> [IdentInfo] -mkIdentInfos mod (Avail n) = +mkIdentInfos mod (AvailName n) = [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] +mkIdentInfos mod (AvailFL fl) = + [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] + where + n = flSelector fl mkIdentInfos mod (AvailTC parent (n:nn) flds) -- Following the GHC convention that parent == n if parent is exported | n == parent diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index bca62f96f4..efda6b23b9 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -11,37 +11,33 @@ module Development.IDE.Types.HscEnvEq ) where -import Control.Concurrent.Async (Async, async, waitCatch) -import Control.Concurrent.Strict (modifyVar, newVar) -import Control.DeepSeq (force) -import Control.Exception (evaluate, mask, throwIO) -import Control.Monad.Extra (eitherM, join, mapMaybeM) +import Control.Concurrent.Async (Async, async, waitCatch) +import Control.Concurrent.Strict (modifyVar, newVar) +import Control.DeepSeq (force) +import Control.Exception (evaluate, mask, throwIO) +import Control.Monad.Extra (eitherM, join, mapMaybeM) import Control.Monad.IO.Class -import Data.Either (fromRight) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Unique +import Data.Either (fromRight) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Unique (Unique) +import qualified Data.Unique as Unique import Development.IDE.GHC.Compat -import Development.IDE.GHC.Error (catchSrcErrors) -import Development.IDE.GHC.Util (lookupPackageConfig) +import qualified Development.IDE.GHC.Compat.Util as Maybes +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)) -import LoadIface (loadInterface) -import qualified Maybes --- import Module (InstalledUnitId) -import OpenTelemetry.Eventlog (withSpan) -import System.Directory (canonicalizePath) +import Development.IDE.Types.Exports (ExportsMap, createExportsMap) +import OpenTelemetry.Eventlog (withSpan) +import System.Directory (canonicalizePath) import System.FilePath -import TcRnMonad (WhereFrom (ImportByUser), - initIfaceLoad) -- | An 'HscEnv' with equality. Two values are considered equal -- if they are created with the same call to 'newHscEnvEq'. data HscEnvEq = HscEnvEq { envUnique :: !Unique , hscEnv :: !HscEnv - , deps :: [(InstalledUnitId, DynFlags)] + , deps :: [(UnitId, DynFlags)] -- ^ In memory components for this HscEnv -- This is only used at the moment for the import dirs in -- the DynFlags @@ -57,7 +53,7 @@ data HscEnvEq = HscEnvEq } -- | Wrap an 'HscEnv' into an 'HscEnvEq'. -newHscEnvEq :: FilePath -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEq :: FilePath -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq newHscEnvEq cradlePath hscEnv0 deps = do let relativeToCradle = (takeDirectory cradlePath ) hscEnv = removeImportPaths hscEnv0 @@ -68,29 +64,29 @@ newHscEnvEq cradlePath hscEnv0 deps = do newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps -newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq +newHscEnvEqWithImportPaths :: Maybe (Set FilePath) -> HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do let dflags = hsc_dflags hscEnv - envUnique <- newUnique + envUnique <- Unique.newUnique -- it's very important to delay the package exports computation envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do -- compute the package imports - let pkgst = pkgState dflags - depends = explicitPackages pkgst + let pkgst = unitState hscEnv + depends = explicitUnits pkgst targets = [ (pkg, mn) | d <- depends , Just pkg <- [lookupPackageConfig d hscEnv] - , (mn, _) <- exposedModules pkg + , (mn, _) <- unitExposedModules pkg ] doOne (pkg, mn) = do modIface <- liftIO $ initIfaceLoad hscEnv $ loadInterface "" - (mkModule (packageConfigId pkg) mn) + (mkModule (unitInfoId pkg) mn) (ImportByUser NotBoot) return $ case modIface of Maybes.Failed _r -> Nothing @@ -104,13 +100,13 @@ newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do <$> catchSrcErrors dflags "listVisibleModuleNames" - (evaluate . force . Just $ oldListVisibleModuleNames dflags) + (evaluate . force . Just $ listVisibleModuleNames hscEnv) return HscEnvEq{..} -- | Wrap an 'HscEnv' into an 'HscEnvEq'. newHscEnvEqPreserveImportPaths - :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq + :: HscEnv -> [(UnitId, DynFlags)] -> IO HscEnvEq newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing -- | Unwrap the 'HscEnv' with the original import paths. @@ -118,15 +114,15 @@ newHscEnvEqPreserveImportPaths = newHscEnvEqWithImportPaths Nothing hscEnvWithImportPaths :: HscEnvEq -> HscEnv hscEnvWithImportPaths HscEnvEq{..} | Just imps <- envImportPaths - = hscEnv{hsc_dflags = (hsc_dflags hscEnv){importPaths = Set.toList imps}} + = hscSetFlags (setImportPaths (Set.toList imps) (hsc_dflags hscEnv)) hscEnv | otherwise = hscEnv removeImportPaths :: HscEnv -> HscEnv -removeImportPaths hsc = hsc{hsc_dflags = (hsc_dflags hsc){importPaths = []}} +removeImportPaths hsc = hscSetFlags (setImportPaths [] (hsc_dflags hsc)) hsc instance Show HscEnvEq where - show HscEnvEq{envUnique} = "HscEnvEq " ++ show (hashUnique envUnique) + show HscEnvEq{envUnique} = "HscEnvEq " ++ show (Unique.hashUnique envUnique) instance Eq HscEnvEq where a == b = envUnique a == envUnique b @@ -134,7 +130,7 @@ instance Eq HscEnvEq where instance NFData HscEnvEq where rnf (HscEnvEq a b c d _ _) = -- deliberately skip the package exports map and visible module names - rnf (hashUnique a) `seq` b `seq` c `seq` rnf d + rnf (Unique.hashUnique a) `seq` b `seq` c `seq` rnf d instance Hashable HscEnvEq where hashWithSalt s = hashWithSalt s . envUnique diff --git a/ghcide/src/Development/IDE/Types/Location.hs b/ghcide/src/Development/IDE/Types/Location.hs index 7176499ced..24a61d8a27 100644 --- a/ghcide/src/Development/IDE/Types/Location.hs +++ b/ghcide/src/Development/IDE/Types/Location.hs @@ -31,11 +31,17 @@ import Control.Monad import Data.Hashable (Hashable (hash)) import Data.Maybe (fromMaybe) import Data.String + +#if MIN_VERSION_ghc(9,0,0) +import GHC.Data.FastString +import GHC.Types.SrcLoc as GHC +#else import FastString +import SrcLoc as GHC +#endif import Language.LSP.Types (Location (..), Position (..), Range (..)) import qualified Language.LSP.Types as LSP -import SrcLoc as GHC import Text.ParserCombinators.ReadP as ReadP toNormalizedFilePath' :: FilePath -> LSP.NormalizedFilePath diff --git a/ghcide/src/Development/IDE/Types/Options.hs b/ghcide/src/Development/IDE/Types/Options.hs index 2968e54abf..7cd2ea7a3a 100644 --- a/ghcide/src/Development/IDE/Types/Options.hs +++ b/ghcide/src/Development/IDE/Types/Options.hs @@ -160,10 +160,10 @@ defaultSkipProgress key = case () of -- | The set of options used to locate files belonging to external packages. data IdePkgLocationOptions = IdePkgLocationOptions - { optLocateHieFile :: PackageConfig -> Module -> IO (Maybe FilePath) + { optLocateHieFile :: UnitState -> Module -> IO (Maybe FilePath) -- ^ Locate the HIE file for the given module. The PackageConfig can be -- used to lookup settings like importDirs. - , optLocateSrcFile :: PackageConfig -> Module -> IO (Maybe FilePath) + , optLocateSrcFile :: UnitState -> Module -> IO (Maybe FilePath) -- ^ Locate the source file for the given module. The PackageConfig can be -- used to lookup settings like importDirs. For DAML, we place them in the package DB. -- For cabal this could point somewhere in ~/.cabal/packages. diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 9ed034eb94..8b0f109744 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -360,22 +360,6 @@ executable haskell-language-server , transformers , unordered-containers - if impl(ghc < 8.10.5) - build-depends: - ghc-api-compat ==8.6 - elif impl(ghc == 8.10.5) - build-depends: - ghc-api-compat ==8.10.5 - elif impl(ghc == 8.10.6) - build-depends: - ghc-api-compat ==8.10.6 - elif impl(ghc == 8.10.7) - build-depends: - ghc-api-compat ==8.10.7 - elif impl(ghc == 9.0.1) - build-depends: - ghc-api-compat ==9.0.1 - default-language: Haskell2010 default-extensions: DataKinds, TypeOperators diff --git a/hls-plugin-api/hls-plugin-api.cabal b/hls-plugin-api/hls-plugin-api.cabal index fee9ceed11..feaece622f 100644 --- a/hls-plugin-api/hls-plugin-api.cabal +++ b/hls-plugin-api/hls-plugin-api.cabal @@ -56,22 +56,6 @@ library , text , unordered-containers - if impl(ghc < 8.10.5) - build-depends: - ghc-api-compat ==8.6 - elif impl(ghc == 8.10.5) - build-depends: - ghc-api-compat ==8.10.5 - elif impl(ghc == 8.10.6) - build-depends: - ghc-api-compat ==8.10.6 - elif impl(ghc == 8.10.7) - build-depends: - ghc-api-compat ==8.10.7 - elif impl(ghc == 9.0.1) - build-depends: - ghc-api-compat ==9.0.1 - if os(windows) build-depends: Win32 diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index ae3253f6f5..c83d2c6e89 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -41,7 +41,7 @@ import Data.String import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Development.IDE.Graph -import DynFlags (DynFlags) +import GHC (DynFlags) import GHC.Generics import Ide.Plugin.Config import Ide.Plugin.Properties diff --git a/plugins/hls-brittany-plugin/src/Ide/Plugin/Brittany.hs b/plugins/hls-brittany-plugin/src/Ide/Plugin/Brittany.hs index c4d4d7aa1b..91d46d844b 100644 --- a/plugins/hls-brittany-plugin/src/Ide/Plugin/Brittany.hs +++ b/plugins/hls-brittany-plugin/src/Ide/Plugin/Brittany.hs @@ -13,7 +13,7 @@ import Data.Semigroup import Data.Text (Text) import qualified Data.Text as T import Development.IDE hiding (pluginHandlers) -import Development.IDE.GHC.Compat (ModSummary (ms_hspp_opts), topDir) +import qualified Development.IDE.GHC.Compat as GHC hiding (Cpp) import qualified DynFlags as D import qualified EnumSet as S import GHC.LanguageExtensions.Type @@ -41,7 +41,6 @@ import qualified Data.Text as Text import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Data.Text.Lazy as TextL -import qualified DynFlags as GHC import qualified GHC import qualified GHC.LanguageExtensions.Type as GHC @@ -61,8 +60,8 @@ provider ide typ contents nfp opts = liftIO $ do FormatText -> (fullRange contents, contents) FormatRange r -> (normalize r, extractRange r contents) modsum <- fmap msrModSummary $ runAction "brittany" ide $ use_ GetModSummaryWithoutTimestamps nfp - let dflags = ms_hspp_opts modsum - let withRuntimeLibdir = bracket_ (setEnv key $ topDir dflags) (unsetEnv key) + let dflags = GHC.ms_hspp_opts modsum + let withRuntimeLibdir = bracket_ (setEnv key $ GHC.topDir dflags) (unsetEnv key) where key = "GHC_EXACTPRINT_GHC_LIBDIR" res <- withRuntimeLibdir $ formatText dflags confFile opts selectedContents case res of diff --git a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal index 85a8cbb59b..d54d0d5677 100644 --- a/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal +++ b/plugins/hls-call-hierarchy-plugin/hls-call-hierarchy-plugin.cabal @@ -42,22 +42,6 @@ library default-language: Haskell2010 default-extensions: DataKinds - if impl(ghc < 8.10.5) - build-depends: - ghc-api-compat ==8.6 - elif impl(ghc == 8.10.5) - build-depends: - ghc-api-compat ==8.10.5 - elif impl(ghc == 8.10.6) - build-depends: - ghc-api-compat ==8.10.6 - elif impl(ghc == 8.10.7) - build-depends: - ghc-api-compat ==8.10.7 - elif impl(ghc == 9.0.1) - build-depends: - ghc-api-compat ==9.0.1 - test-suite tests type: exitcode-stdio-1.0 default-language: Haskell2010 diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index 602fb328f8..e54c7721ab 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -37,7 +37,6 @@ import Ide.Plugin.CallHierarchy.Types import Ide.Types import Language.LSP.Types import qualified Language.LSP.Types.Lens as L -import Name import Text.Read (readMaybe) -- | Render prepare call hierarchy request. diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs index 1ba3a793f8..9a855958c1 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Query.hs @@ -14,7 +14,6 @@ import Development.IDE.GHC.Compat import HieDb (HieDb (getConn), Symbol (..), toNsChar) import Ide.Plugin.CallHierarchy.Types -import Name incomingCalls :: HieDb -> Symbol -> IO [Vertex] incomingCalls (getConn -> conn) symbol = do @@ -78,5 +77,5 @@ parseSymbol :: Symbol -> (String, String, String) parseSymbol Symbol{..} = let o = toNsChar (occNameSpace symName) : occNameString symName m = moduleNameString $ moduleName symModule - u = unitString $ moduleUnitId symModule + u = unitString $ moduleUnit symModule in (o, m, u) diff --git a/plugins/hls-class-plugin/hls-class-plugin.cabal b/plugins/hls-class-plugin/hls-class-plugin.cabal index 76e0c31a17..766965e1a9 100644 --- a/plugins/hls-class-plugin/hls-class-plugin.cabal +++ b/plugins/hls-class-plugin/hls-class-plugin.cabal @@ -36,22 +36,6 @@ library , text , transformers - if impl(ghc < 8.10.5) - build-depends: - ghc-api-compat ==8.6 - elif impl(ghc == 8.10.5) - build-depends: - ghc-api-compat ==8.10.5 - elif impl(ghc == 8.10.6) - build-depends: - ghc-api-compat ==8.10.6 - elif impl(ghc == 8.10.7) - build-depends: - ghc-api-compat ==8.10.7 - elif impl(ghc == 9.0.1) - build-depends: - ghc-api-compat ==9.0.1 - default-language: Haskell2010 default-extensions: DataKinds diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index 6ec932e4a5..fa81a76c07 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs @@ -8,12 +8,10 @@ module Ide.Plugin.Class ( descriptor ) where -import BooleanFormula -import Class -import ConLike import Control.Applicative import Control.Lens hiding (List, use) import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Data.Aeson @@ -26,10 +24,9 @@ import Development.IDE hiding (pluginHandlers) import Development.IDE.Core.PositionMapping (fromCurrentRange, toCurrentRange) import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util import Development.IDE.Spans.AtPoint import qualified GHC.Generics as Generics -import GhcPlugins hiding (Var, getLoc, - (<>)) import Ide.PluginUtils import Ide.Types import Language.Haskell.GHC.ExactPrint @@ -38,8 +35,6 @@ import Language.Haskell.GHC.ExactPrint.Types hiding (GhcPs, Parens) import Language.LSP.Server import Language.LSP.Types import qualified Language.LSP.Types.Lens as J -import TcEnv -import TcRnMonad descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal index c9ba87be6f..16232b61cc 100644 --- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal +++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal @@ -82,22 +82,6 @@ library , unliftio , unordered-containers - if impl(ghc < 8.10.5) - build-depends: - ghc-api-compat ==8.6 - elif impl(ghc == 8.10.5) - build-depends: - ghc-api-compat ==8.10.5 - elif impl(ghc == 8.10.6) - build-depends: - ghc-api-compat ==8.10.6 - elif impl(ghc == 8.10.7) - build-depends: - ghc-api-compat ==8.10.7 - elif impl(ghc == 9.0.1) - build-depends: - ghc-api-compat ==9.0.1 - ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs index 7497ae783a..be013e2dc2 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs @@ -6,22 +6,20 @@ module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalSetup, propSetup, testCheck, asStatements,myExecStmt) where import Control.Lens ((^.)) +import Control.Monad.IO.Class import Data.Algorithm.Diff (Diff, PolyDiff (..), getDiff) import qualified Data.List.NonEmpty as NE import Data.String (IsString) import qualified Data.Text as T +import Development.IDE.GHC.Compat import Development.IDE.Types.Location (Position (..), Range (..)) import GHC (ExecOptions, ExecResult (..), execStmt) -import GhcMonad (Ghc, liftIO, modifySession) -import HscTypes import Ide.Plugin.Eval.Types (Language (Plain), Loc, Located (..), Section (sectionLanguage), Test (..), Txt, locate, locate0) -import InteractiveEval (getContext, parseImportDecl, - runDecls, setContext) import Language.LSP.Types.Lens (line, start) import System.IO.Extra (newTempFile, readFile') 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 c7ef62b912..10b82027a5 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -25,7 +25,6 @@ module Ide.Plugin.Eval.CodeLens ( evalCommand, ) where -import CmdLineParser import Control.Applicative (Alternative ((<|>))) import Control.Arrow (second, (>>>)) import Control.Exception (try) @@ -72,59 +71,30 @@ import Development.IDE.Core.Compile (loadModulesHome, setupFinderCache) import Development.IDE.Core.PositionMapping (toCurrentRange) import Development.IDE.Core.Rules (TransitiveDependencies (transitiveModuleDeps)) -import Development.IDE.GHC.Compat (AnnotationComment (AnnBlockComment, AnnLineComment), - GenLocated (L), - GhcException, HscEnv, - ParsedModule (..), - SrcSpan (UnhelpfulSpan), - moduleName, - setInteractiveDynFlags, - srcSpanFile) +import Development.IDE.GHC.Compat hiding (typeKind, + unitState) +import qualified Development.IDE.GHC.Compat as Compat import qualified Development.IDE.GHC.Compat as SrcLoc +import Development.IDE.GHC.Compat.Util (GhcException, + OverridingBool (..)) +import qualified Development.IDE.GHC.Compat.Util as FastString import Development.IDE.Types.Options -import DynamicLoading (initializePlugins) -import FastString (unpackFS) import GHC (ClsInst, ExecOptions (execLineNumber, execSourceFile), - FamInst, Fixity, - GeneralFlag (..), Ghc, - GhcLink (LinkInMemory), - GhcMode (CompManager), - GhcMonad (getSession), - HscTarget (HscInterpreted), + FamInst, GhcMonad, LoadHowMuch (LoadAllTargets), - ModSummary (ms_hspp_opts), - NamedThing (getName, getOccName), - SuccessFlag (Failed, Succeeded), - TcRnExprMode (..), - TyThing, defaultFixity, + NamedThing (getName), + defaultFixity, execOptions, exprType, getInfo, getInteractiveDynFlags, - getSessionDynFlags, isImport, isStmt, load, parseName, pprFamInst, - pprInstance, runDecls, - setContext, setLogAction, - setSessionDynFlags, - setTargets, typeKind) + pprInstance, + setLogAction, setTargets, + typeKind) import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) -import GhcPlugins (DynFlags (..), - defaultLogActionHPutStrDoc, - elemNameSet, gopt_set, - gopt_unset, hsc_dflags, - isSymOcc, mkNameSet, - parseDynamicFlagsCmdLine, - pprDefinedAt, - pprInfixName, - targetPlatform, - tyThingParent_maybe, - xopt_set, xopt_unset) - -import HscTypes (InteractiveImport (IIModule), - ModSummary (ms_mod), - Target (Target), - TargetId (TargetFile)) + import Ide.Plugin.Eval.Code (Statement, asStatements, evalSetup, myExecStmt, propSetup, resultRange, @@ -146,28 +116,15 @@ import Language.LSP.Types hiding SemanticTokenRelative (length)) import Language.LSP.Types.Lens (end, line) import Language.LSP.VFS (virtualFileText) -import Outputable (SDoc, empty, hang, nest, - ppr, showSDoc, text, - vcat, ($$), (<+>)) import System.FilePath (takeFileName) import System.IO (hClose) import UnliftIO.Temporary (withSystemTempFile) -import Util (OverridingBool (Never)) -import IfaceSyn (showToHeader) -import PprTyThing (pprTyThingInContext, - pprTypeForUser) #if MIN_VERSION_ghc(9,0,0) -import GHC.Driver.Ways (hostFullWays, - wayGeneralFlags, - wayUnsetGeneralFlags) -import GHC.Parser.Annotation (ApiAnns (apiAnnRogueComments)) -import GHC.Parser.Lexer (mkParserFlags) +import GHC.Driver.Session (unitDatabases, unitState) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) #else -import GhcPlugins (interpWays, updateWays, - wayGeneralFlags, - wayUnsetGeneralFlags) +import DynFlags #endif #if MIN_VERSION_ghc(9,0,0) @@ -180,7 +137,7 @@ apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.Located AnnotationComment] apiAnnComments' = concat . Map.elems . snd pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan -pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x +pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing #endif @@ -203,7 +160,7 @@ codeLens st plId CodeLensParams{_textDocument} = let comments = foldMap (\case L (RealSrcSpanAlready real) bdy - | unpackFS (srcSpanFile real) == + | FastString.unpackFS (srcSpanFile real) == fromNormalizedFilePath nfp , let ran0 = realSrcSpanToRange real , Just curRan <- toCurrentRange posMap ran0 @@ -387,7 +344,7 @@ runEvalCmd st EvalParams{..} = return $ Left err Succeeded -> do -- Evaluation takes place 'inside' the module - setContext [IIModule modName] + setContext [Compat.IIModule modName] Right <$> getSession edits <- @@ -601,11 +558,10 @@ evals (st, fp) df stmts = do dbg "{DECL " stmt void $ runDecls stmt return Nothing + pf = initParserOpts df #if !MIN_VERSION_ghc(9,0,0) - pf = df unhelpfulReason = "" #else - pf = mkParserFlags df unhelpfulReason = UnhelpfulInteractive #endif exec stmt l = @@ -766,7 +722,7 @@ doKindCmd True df arg = do doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text) doTypeCmd dflags arg = do let (emod, expr) = parseExprMode arg - ty <- exprType emod $ T.unpack expr + ty <- GHC.exprType emod $ T.unpack expr let rawType = T.strip $ T.pack $ showSDoc dflags $ pprTypeForUser ty broken = T.any (\c -> c == '\r' || c == '\n') rawType pure $ @@ -812,29 +768,20 @@ parseGhciLikeCmd input = do setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags setupDynFlagsForGHCiLike env dflags = do - let dflags3 = - dflags - { hscTarget = HscInterpreted - , ghcMode = CompManager - , ghcLink = LinkInMemory - } + let dflags3 = setInterpreterLinkerOptions dflags platform = targetPlatform dflags3 -#if MIN_VERSION_ghc(9,0,0) - evalWays = hostFullWays -#else - evalWays = interpWays -#endif - dflags3a = dflags3{ways = evalWays} + evalWays = Compat.hostFullWays + dflags3a = setWays evalWays dflags3 dflags3b = foldl gopt_set dflags3a $ - concatMap (wayGeneralFlags platform) evalWays + concatMap (Compat.wayGeneralFlags platform) evalWays dflags3c = foldl gopt_unset dflags3b $ - concatMap (wayUnsetGeneralFlags platform) evalWays + concatMap (Compat.wayUnsetGeneralFlags platform) evalWays dflags4 = dflags3c `gopt_set` Opt_ImplicitImportQualified `gopt_set` Opt_IgnoreOptimChanges `gopt_set` Opt_IgnoreHpcChanges `gopt_unset` Opt_DiagnosticsShowCaret - initializePlugins env dflags4 + Compat.hsc_dflags <$> Compat.initializePlugins (Compat.hscSetFlags dflags4 env) 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 ae3c26150c..e5232759ce 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/GHC.hs @@ -13,22 +13,15 @@ module Ide.Plugin.Eval.GHC ( showDynFlags, ) where -import Data.List (isPrefixOf) -import Data.Maybe (mapMaybe) -import Data.String (fromString) +import Data.List (isPrefixOf) +import Data.Maybe (mapMaybe) +import Data.String (fromString) import Development.IDE.GHC.Compat -import qualified EnumSet -import GHC.LanguageExtensions.Type (Extension (..)) -import GhcMonad (modifySession) -import GhcPlugins (fsLit, hsc_IC, pprHsString) -import HscTypes (InteractiveContext (ic_dflags)) -import Ide.Plugin.Eval.Util (asS, gStrictTry) -import qualified Lexer -import Outputable (Outputable (ppr), SDoc, - showSDocUnsafe, text, vcat, (<+>)) -import qualified Parser -import SrcLoc (mkRealSrcLoc) -import StringBuffer (stringToStringBuffer) +import Development.IDE.GHC.Compat.Util +import qualified Development.IDE.GHC.Compat.Util as EnumSet + +import GHC.LanguageExtensions.Type (Extension (..)) +import Ide.Plugin.Eval.Util (asS, gStrictTry) {- $setup >>> import GHC @@ -72,9 +65,9 @@ pkgNames_ :: [PackageFlag] -> [String] pkgNames_ = mapMaybe ( \case - ExposePackage _ (PackageArg n) _ -> Just n - ExposePackage _ (UnitIdArg (DefiniteUnitId n)) _ -> Just $ asS n - _ -> Nothing + ExposePackage _ (PackageArg n) _ -> Just n + ExposePackage _ (UnitIdArg uid) _ -> Just $ asS uid + _ -> Nothing ) {- | Expose a list of packages. 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 1c0a6822d0..a249aa1214 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs @@ -15,30 +15,30 @@ module Ide.Plugin.Eval.Util ( logWith, ) where -import Control.Monad.Extra (maybeM) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE) -import Data.Aeson (Value (Null)) -import Data.Bifunctor (first) -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) -import GHC.Exts (toList) -import GHC.Stack (HasCallStack, callStack, - srcLocFile, srcLocStartCol, - srcLocStartLine) +import Control.Exception (SomeException, evaluate) +import Control.Monad.Extra (maybeM) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT, + throwE) +import Data.Aeson (Value (Null)) +import Data.Bifunctor (first) +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import Development.IDE (IdeState, Priority (..), + ideLogger, logPriority) +import Development.IDE.GHC.Compat (Outputable, ppr, + showSDocUnsafe) +import Development.IDE.GHC.Compat.Util (MonadCatch, catch) +import GHC.Exts (toList) +import GHC.Stack (HasCallStack, callStack, + srcLocFile, srcLocStartCol, + srcLocStartLine) import Language.LSP.Server import Language.LSP.Types -import Outputable (Outputable (ppr), ppr, - showSDocUnsafe) -import System.FilePath (takeExtension) -import System.Time.Extra (duration, showDuration) -import UnliftIO.Exception (catchAny) +import System.FilePath (takeExtension) +import System.Time.Extra (duration, showDuration) +import UnliftIO.Exception (catchAny) asS :: Outputable a => a -> String asS = showSDocUnsafe . ppr @@ -93,9 +93,9 @@ response' act = do _ <- sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing a) (\_ -> pure ()) return $ Right Null -gStrictTry :: ExceptionMonad m => m b -> m (Either String b) +gStrictTry :: (MonadIO m, MonadCatch m) => m b -> m (Either String b) gStrictTry op = - gcatch + catch (op >>= fmap Right . gevaluate) showErr 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 276c8b567d..f4b8fd0641 100644 --- a/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal +++ b/plugins/hls-explicit-imports-plugin/hls-explicit-imports-plugin.cabal @@ -28,22 +28,6 @@ library , text , unordered-containers - if impl(ghc < 8.10.5) - build-depends: - ghc-api-compat ==8.6 - elif impl(ghc == 8.10.5) - build-depends: - ghc-api-compat ==8.10.5 - elif impl(ghc == 8.10.6) - build-depends: - ghc-api-compat ==8.10.6 - elif impl(ghc == 8.10.7) - build-depends: - ghc-api-compat ==8.10.7 - elif impl(ghc == 9.0.1) - build-depends: - ghc-api-compat ==9.0.1 - default-language: Haskell2010 default-extensions: DataKinds 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 4194a79e27..d094c197d0 100644 --- a/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs +++ b/plugins/hls-explicit-imports-plugin/src/Ide/Plugin/ExplicitImports.hs @@ -35,16 +35,6 @@ 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)) importCommandId :: CommandId importCommandId = "ImportLensCommand" @@ -197,13 +187,13 @@ minimalImportsRule = define $ \MinimalImports nfp -> do (imports, mbMinImports) <- liftIO $ extractMinimalImports hsc tmr let importsMap = Map.fromList - [ (SrcLoc.realSrcSpanStart l, T.pack (prettyPrint i)) - | L (OldRealSrcSpan l) i <- fromMaybe [] mbMinImports + [ (realSrcSpanStart l, T.pack (prettyPrint i)) + | L (RealSrcSpan l _) i <- fromMaybe [] mbMinImports ] res = - [ (i, Map.lookup (SrcLoc.realSrcSpanStart l) importsMap) + [ (i, Map.lookup (realSrcSpanStart l) importsMap) | i <- imports - , OldRealSrcSpan l <- [getLoc i] + , RealSrcSpan l _ <- [getLoc i] ] return ([], MinimalImportsResult res <$ mbMinImports) @@ -240,7 +230,7 @@ mkExplicitEdit pred posMapping (L src imp) explicit | ImportDecl {ideclHiding = Just (False, _)} <- imp = Nothing | not (isQualifiedImport imp), - OldRealSrcSpan l <- src, + RealSrcSpan 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-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs index 5b443dfd9b..b65405a802 100644 --- a/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs +++ b/plugins/hls-fourmolu-plugin/src/Ide/Plugin/Fourmolu.hs @@ -14,9 +14,8 @@ import Control.Monad.IO.Class import Data.Bifunctor (first) import qualified Data.Text as T import Development.IDE hiding (pluginHandlers) -import Development.IDE.GHC.Compat (moduleNameString) -import qualified DynFlags as D -import qualified EnumSet as S +import Development.IDE.GHC.Compat as Compat hiding (Cpp) +import qualified Development.IDE.GHC.Compat.Util as S import GHC.LanguageExtensions.Type (Extension (Cpp)) import GhcPlugins (HscEnv (hsc_dflags)) import Ide.PluginUtils (makeDiffTextEdit) @@ -88,12 +87,12 @@ provider ideState typ contents fp fo = withIndefiniteProgress title Cancellable FormatRange (Range (Position sl _) (Position el _)) -> RegionIndices (Just $ sl + 1) (Just $ el + 1) -convertDynFlags :: D.DynFlags -> IO [DynOption] +convertDynFlags :: DynFlags -> IO [DynOption] convertDynFlags df = let pp = ["-pgmF=" <> p | not (null p)] - p = D.sPgm_F $ D.settings df - pm = map (("-fplugin=" <>) . moduleNameString) $ D.pluginModNames df - ex = map showExtension $ S.toList $ D.extensionFlags df + p = sPgm_F $ Compat.settings df + pm = map (("-fplugin=" <>) . moduleNameString) $ pluginModNames df + ex = map showExtension $ S.toList $ extensionFlags df showExtension = \case Cpp -> "-XCPP" x -> "-X" ++ show x 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 554dea0836..fa32279b3e 100644 --- a/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs +++ b/plugins/hls-haddock-comments-plugin/src/Ide/Plugin/HaddockComments.hs @@ -91,7 +91,9 @@ genForSig = GenComments {..} isFresh Ann {annsDP} = null [() | (AnnComment _, _) <- annsDP] collectKeys = keyFromTyVar 0 -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) + comment = mkComment "-- ^ " (spanAsAnchor noSrcSpan) +#elif MIN_VERSION_ghc(9,0,0) comment = mkComment "-- ^ " badRealSrcSpan #else comment = mkComment "-- ^ " noSrcSpan @@ -114,7 +116,9 @@ genForRecord = GenComments {..} collectKeys = keyFromCon -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) + comment = mkComment "-- | " (spanAsAnchor noSrcSpan) +#elif MIN_VERSION_ghc(9,0,0) comment = mkComment "-- | " badRealSrcSpan #else comment = mkComment "-- | " noSrcSpan @@ -140,7 +144,7 @@ toAction title uri edit = CodeAction {..} toRange :: SrcSpan -> Maybe Range toRange src - | (OldRealSrcSpan s) <- src, + | (RealSrcSpan s _) <- src, range' <- realSrcSpanToRange s = Just range' | otherwise = Nothing diff --git a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs index 9c775c846e..182f5700c3 100644 --- a/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs +++ b/plugins/hls-hlint-plugin/src/Ide/Plugin/Hlint.hs @@ -9,7 +9,9 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} #ifdef HLINT_ON_GHC_LIB @@ -51,15 +53,18 @@ import Refact.Apply #ifdef HLINT_ON_GHC_LIB import Data.List (nub) -import "ghc" DynFlags as RealGHC.DynFlags (topDir) -import qualified "ghc" EnumSet as EnumSet -import "ghc" GHC as RealGHC (DynFlags (..)) +import Development.IDE.GHC.Compat.Core (BufSpan, + DynFlags, + extensionFlags, + ms_hspp_opts, + topDir) +import qualified Development.IDE.GHC.Compat.Util as EnumSet import "ghc-lib" GHC hiding (DynFlags (..), + RealSrcSpan, ms_hspp_opts) +import qualified "ghc-lib" GHC import "ghc-lib-parser" GHC.LanguageExtensions (Extension) -import "ghc" HscTypes as RealGHC.HscTypes (hsc_dflags, - ms_hspp_opts) import Language.Haskell.GhclibParserEx.GHC.Driver.Session as GhclibParserEx (readExtension) import System.FilePath (takeFileName) import System.IO (IOMode (WriteMode), @@ -72,9 +77,8 @@ import System.IO (IOMode (Wri withFile) import System.IO.Temp #else -import Development.IDE.GHC.Compat hiding - (DynFlags (..), - OldRealSrcSpan) +import Development.IDE.GHC.Compat.Core hiding + (setEnv) import Language.Haskell.GHC.ExactPrint.Delta (deltaOptions) import Language.Haskell.GHC.ExactPrint.Parsers (postParseTransform) import Language.Haskell.GHC.ExactPrint.Types (Rigidity (..)) @@ -105,14 +109,16 @@ import System.Environment (setEnv, unsetEnv) -- --------------------------------------------------------------------- +#ifdef HLINT_ON_GHC_LIB -- 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 _ +pattern RealSrcSpan :: GHC.RealSrcSpan -> Maybe BufSpan -> GHC.SrcSpan +#if MIN_VERSION_ghc(9,0,0) +pattern RealSrcSpan x y = GHC.RealSrcSpan x y #else -pattern OldRealSrcSpan span <- RealSrcSpan span +pattern RealSrcSpan x y <- ((,Nothing) -> (GHC.RealSrcSpan x, y)) +#endif +{-# COMPLETE RealSrcSpan, UnhelpfulSpan #-} #endif -{-# COMPLETE OldRealSrcSpan, UnhelpfulSpan #-} descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = (defaultPluginDescriptor plId) @@ -209,7 +215,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 (OldRealSrcSpan span) = Range { + srcSpanToRange (RealSrcSpan span _) = Range { _start = LSP.Position { _line = srcSpanStartLine span - 1 , _character = srcSpanStartCol span - 1} @@ -482,7 +488,7 @@ applyHint ide nfp mhint = ideaPos = (srcSpanStartLine &&& srcSpanStartCol) . toRealSrcSpan . ideaSpan in filter (\i -> ideaHint i == title' && ideaPos i == (l+1, c+1)) ideas - toRealSrcSpan (OldRealSrcSpan real) = real + toRealSrcSpan (RealSrcSpan 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 48bf577fbf..9635538101 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -32,7 +32,7 @@ import Development.IDE (GetParsedModule (GetParsedModule), uriToFilePath', use, use_) import Development.IDE.GHC.Compat (GenLocated (L), getSessionDynFlags, hsmodName, importPaths, - pattern OldRealSrcSpan, + pattern RealSrcSpan, pm_parsed_source, unLoc) import Ide.Types import Language.LSP.Server @@ -132,7 +132,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 (OldRealSrcSpan l) m <- MaybeT . pure . hsmodName . unLoc $ pm_parsed_source pm + L (RealSrcSpan 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-ormolu-plugin/hls-ormolu-plugin.cabal b/plugins/hls-ormolu-plugin/hls-ormolu-plugin.cabal index 89cd715fab..c1f03546c1 100644 --- a/plugins/hls-ormolu-plugin/hls-ormolu-plugin.cabal +++ b/plugins/hls-ormolu-plugin/hls-ormolu-plugin.cabal @@ -33,22 +33,6 @@ library default-language: Haskell2010 - if impl(ghc < 8.10.5) - build-depends: - ghc-api-compat ==8.6 - elif impl(ghc == 8.10.5) - build-depends: - ghc-api-compat ==8.10.5 - elif impl(ghc == 8.10.6) - build-depends: - ghc-api-compat ==8.10.6 - elif impl(ghc == 8.10.7) - build-depends: - ghc-api-compat ==8.10.7 - elif impl(ghc == 9.0.1) - build-depends: - ghc-api-compat ==9.0.1 - test-suite tests type: exitcode-stdio-1.0 default-language: Haskell2010 diff --git a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs index 4a19566f87..d1a465eb64 100644 --- a/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs +++ b/plugins/hls-ormolu-plugin/src/Ide/Plugin/Ormolu.hs @@ -7,21 +7,20 @@ module Ide.Plugin.Ormolu ) where -import Control.Exception (try) -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text as T -import Development.IDE hiding (pluginHandlers) -import Development.IDE.GHC.Compat (moduleNameString) -import qualified DynFlags as D -import qualified EnumSet as S +import Control.Exception (try) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import Development.IDE hiding (pluginHandlers) +import Development.IDE.GHC.Compat (moduleNameString, hsc_dflags) +import qualified Development.IDE.GHC.Compat as D +import qualified Development.IDE.GHC.Compat.Util as S import GHC.LanguageExtensions.Type -import GhcPlugins (HscEnv (hsc_dflags)) import Ide.PluginUtils import Ide.Types -import Language.LSP.Server hiding (defaultConfig) +import Language.LSP.Server hiding (defaultConfig) import Language.LSP.Types import Ormolu -import System.FilePath (takeFileName) +import System.FilePath (takeFileName) -- --------------------------------------------------------------------- diff --git a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs index 283f569fdb..c91b61634f 100644 --- a/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs +++ b/plugins/hls-refine-imports-plugin/src/Ide/Plugin/RefineImports.hs @@ -9,9 +9,6 @@ module Ide.Plugin.RefineImports (descriptor) where -import Avail (AvailInfo (Avail), - availName, availNames, - availNamesWithSelectors) import Control.Arrow (Arrow (second)) import Control.DeepSeq (rwhnf) import Control.Monad (join) @@ -27,7 +24,8 @@ import qualified Data.Text as T import Data.Traversable (forM) import Development.IDE import Development.IDE.Core.PositionMapping -import Development.IDE.GHC.Compat (AvailInfo, +import Development.IDE.GHC.Compat + {- (AvailInfo, GenLocated (L), GhcRn, HsModule (hsmodImports), ImportDecl (ImportDecl, ideclHiding, ideclName), @@ -35,9 +33,10 @@ import Development.IDE.GHC.Compat (AvailInfo, Module (moduleName), ModuleName, ParsedModule (ParsedModule, pm_parsed_source), - SrcSpan (RealSrcSpan), + SrcSpan(..), + RealSrcSpan(..), getLoc, ieName, noLoc, - tcg_exports, unLoc) + tcg_exports, unLoc) -} import Development.IDE.Graph.Classes import GHC.Generics (Generic) import Ide.Plugin.ExplicitImports (extractMinimalImports, @@ -46,12 +45,6 @@ import Ide.PluginUtils (mkLspCommand) import Ide.Types import Language.LSP.Server import Language.LSP.Types -import PrelNames (pRELUDE) -import RnNames (findImportUsage, - getMinimalImports) -import TcRnMonad (initTcWithGbl, - tcg_rn_exports, - tcg_used_gres) -- | plugin declaration descriptor :: PluginId -> PluginDescriptor IdeState @@ -257,7 +250,7 @@ refineImportsRule = define $ \RefineImports nfp -> do mkExplicitEdit :: PositionMapping -> LImportDecl pass -> T.Text -> Maybe TextEdit mkExplicitEdit posMapping (L src imp) explicit - | RealSrcSpan l <- src, + | RealSrcSpan l _ <- src, L _ mn <- ideclName imp, -- (almost) no one wants to see an refine import list for Prelude mn /= moduleName pRELUDE, diff --git a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs index dca7a66346..dee36366cd 100644 --- a/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs +++ b/plugins/hls-rename-plugin/src/Ide/Plugin/Rename.hs @@ -125,7 +125,7 @@ refsAtName state nfp name = do True (nameOccName name) (Just $ moduleName mod) - (Just $ moduleUnitId mod) + (Just $ moduleUnit mod) [fromNormalizedFilePath nfp] pure $ nubOrd $ astRefs ++ dbRefs diff --git a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal index 277cb904f0..411429f7e2 100644 --- a/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal +++ b/plugins/hls-retrie-plugin/hls-retrie-plugin.cabal @@ -34,22 +34,6 @@ library , transformers , unordered-containers - if impl(ghc < 8.10.5) - build-depends: - ghc-api-compat ==8.6 - elif impl(ghc == 8.10.5) - build-depends: - ghc-api-compat ==8.10.5 - elif impl(ghc == 8.10.6) - build-depends: - ghc-api-compat ==8.10.6 - elif impl(ghc == 8.10.7) - build-depends: - ghc-api-compat ==8.10.7 - elif impl(ghc == 9.0.1) - build-depends: - ghc-api-compat ==9.0.1 - default-language: Haskell2010 default-extensions: DataKinds diff --git a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs index cf41005407..5771964067 100644 --- a/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs +++ b/plugins/hls-retrie-plugin/src/Ide/Plugin/Retrie.hs @@ -57,28 +57,30 @@ import Development.IDE.GHC.Compat (GenLocated (L), GhcRn, HscEnv, IdP, LRuleDecls, ModSummary (ModSummary, ms_hspp_buf, ms_mod), NHsValBindsLR (..), + Outputable, ParsedModule (..), RuleDecl (HsRule), RuleDecls (HsRules), + SourceText (..), SrcSpan (..), TyClDecl (SynDecl), TyClGroup (..), fun_id, + hm_iface, isQual, + isQual_maybe, mi_fixities, moduleNameString, + nameModule_maybe, + nameRdrName, occNameFS, + occNameString, parseModule, pattern IsBoot, pattern NotBoot, - pattern OldRealSrcSpan, - rds_rules, srcSpanFile) + pattern RealSrcSpan, + rdrNameOcc, rds_rules, + srcSpanFile) +import Development.IDE.GHC.Compat.Util hiding (catch, try) +import qualified GHC (parseModule) import GHC.Generics (Generic) -import GhcPlugins (Outputable, - SourceText (NoSourceText), - hm_iface, isQual, - isQual_maybe, - nameModule_maybe, - nameRdrName, occNameFS, - occNameString, - rdrNameOcc, unpackFS) import Ide.PluginUtils import Ide.Types import Language.LSP.Server (LspM, @@ -106,7 +108,6 @@ import Retrie.Replace (Change (..), import Retrie.Rewrites import Retrie.SYB (listify) import Retrie.Util (Verbosity (Loud)) -import StringBuffer (stringToStringBuffer) import System.Directory (makeAbsolute) descriptor :: PluginId -> PluginDescriptor IdeState @@ -374,7 +375,7 @@ callRetrie state session rewrites origin restrictToOriginatingFile = do } logPriority (ideLogger state) Info $ T.pack $ "Parsing module: " <> t parsed <- - evalGhcEnv session (parseModule ms') + evalGhcEnv session (GHC.parseModule ms') `catch` \e -> throwIO (GHCParseError nt (show @SomeException e)) (fixities, parsed) <- fixFixities f (fixAnns parsed) return (fixities, parsed) @@ -473,7 +474,7 @@ asTextEdits NoChange = [] asTextEdits (Change reps _imports) = [ (filePathToUri spanLoc, edit) | Replacement {..} <- nubOrdOn (realSpan . replLocation) reps, - (OldRealSrcSpan rspan) <- [replLocation], + (RealSrcSpan rspan _) <- [replLocation], let spanLoc = unpackFS $ srcSpanFile rspan, let edit = TextEdit (realSrcSpanToRange rspan) (T.pack replReplacement) ] diff --git a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs index 885b8ac72e..4e51e59b69 100644 --- a/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs +++ b/plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs @@ -23,6 +23,7 @@ where import Control.Applicative (Alternative ((<|>))) import Control.Arrow +import Control.Exception import qualified Control.Foldl as L import Control.Lens (Identity (..), ix, view, (%~), (<&>), (^.)) @@ -43,12 +44,10 @@ import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import qualified Data.Text as T import Development.IDE -import Development.IDE.GHC.Compat hiding (getLoc) +import Development.IDE.GHC.Compat as Compat hiding (getLoc) +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.ExactPrint -import Exception import GHC.Exts -import GhcMonad -import GhcPlugins hiding (Var, getLoc, (<>)) import Ide.Plugin.Splice.Types import Ide.Types import Language.Haskell.GHC.ExactPrint (setPrecedingLines, @@ -57,8 +56,6 @@ import Language.LSP.Server import Language.LSP.Types import Language.LSP.Types.Capabilities import qualified Language.LSP.Types.Lens as J -import RnSplice -import TcRnMonad descriptor :: PluginId -> PluginDescriptor IdeState descriptor plId = @@ -146,7 +143,7 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do dflags clientCapabilities uri - (graft (RealSrcSpan spliceSpan) expanded) + (graft (RealSrcSpan spliceSpan Nothing) expanded) ps maybe (throwE "No splice information found") (either throwE pure) $ case spliceContext of @@ -162,7 +159,7 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do dflags clientCapabilities uri - (graftDecls (RealSrcSpan spliceSpan) expanded) + (graftDecls (RealSrcSpan spliceSpan Nothing) expanded) ps <&> -- FIXME: Why ghc-exactprint sweeps preceeding comments? @@ -195,7 +192,7 @@ expandTHSplice _eStyle ideState params@ExpandSpliceParams {..} = do where range = realSrcSpanToRange spliceSpan - srcSpan = RealSrcSpan spliceSpan + srcSpan = RealSrcSpan spliceSpan Nothing setupHscEnv @@ -211,33 +208,27 @@ setupHscEnv ideState fp pm = do let ps = annotateParsedSource pm hscEnv0 = hscEnvWithImportPaths hscEnvEq modSum = pm_mod_summary pm - df' <- liftIO $ setupDynFlagsForGHCiLike hscEnv0 $ ms_hspp_opts modSum - let hscEnv = hscEnv0 { hsc_dflags = df' } - pure (ps, hscEnv, df') + hscEnv <- liftIO $ setupDynFlagsForGHCiLike hscEnv0 $ ms_hspp_opts modSum + pure (ps, hscEnv, hsc_dflags hscEnv) -setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags +setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO HscEnv setupDynFlagsForGHCiLike env dflags = do - let dflags3 = - dflags - { hscTarget = HscInterpreted - , ghcMode = CompManager - , ghcLink = LinkInMemory - } + let dflags3 = setInterpreterLinkerOptions dflags platform = targetPlatform dflags3 - dflags3a = updateWays $ dflags3 {ways = interpWays} + dflags3a = setWays hostFullWays dflags3 dflags3b = foldl gopt_set dflags3a $ - concatMap (wayGeneralFlags platform) interpWays + concatMap (wayGeneralFlags platform) hostFullWays dflags3c = foldl gopt_unset dflags3b $ - concatMap (wayUnsetGeneralFlags platform) interpWays + concatMap (wayUnsetGeneralFlags platform) hostFullWays dflags4 = dflags3c `gopt_set` Opt_ImplicitImportQualified `gopt_set` Opt_IgnoreOptimChanges `gopt_set` Opt_IgnoreHpcChanges `gopt_unset` Opt_DiagnosticsShowCaret - initializePlugins env dflags4 + initializePlugins (hscSetFlags dflags4 env) adjustToRange :: Uri -> Range -> WorkspaceEdit -> WorkspaceEdit adjustToRange uri ran (WorkspaceEdit mhult mlt x) = @@ -335,26 +326,26 @@ manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _e case classifyAST spliceContext of IsHsDecl -> fmap (fmap $ adjustToRange uri ran) $ flip (transformM dflags clientCapabilities uri) ps $ - graftDeclsWithM (RealSrcSpan srcSpan) $ \case + graftDeclsWithM (RealSrcSpan srcSpan Nothing) $ \case (L _spn (SpliceD _ (SpliceDecl _ (L _ spl) _))) -> do eExpr <- eitherM (fail . show) pure $ lift ( lift $ - gtry @_ @SomeException $ + Util.try @_ @SomeException $ (fst <$> rnTopSpliceDecls spl) ) pure $ Just eExpr _ -> pure Nothing OneToOneAST astP -> flip (transformM dflags clientCapabilities uri) ps $ - graftWithM (RealSrcSpan srcSpan) $ \case + graftWithM (RealSrcSpan srcSpan Nothing) $ \case (L _spn (matchSplice astP -> Just spl)) -> do eExpr <- eitherM (fail . show) pure $ lift ( lift $ - gtry @_ @SomeException $ + Util.try @_ @SomeException $ (fst <$> expandSplice astP spl) ) Just <$> either (pure . L _spn) (unRenamedE dflags) eExpr @@ -428,8 +419,8 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $ mkQ Continue ( \case - (L l@(RealSrcSpan spLoc) expr :: LHsExpr GhcPs) - | RealSrcSpan spn `isSubspanOf` l -> + (L l@(RealSrcSpan spLoc _) expr :: LHsExpr GhcPs) + | RealSrcSpan spn Nothing `isSubspanOf` l -> case expr of HsSpliceE {} -> Here (spLoc, Expr) _ -> Continue @@ -437,25 +428,25 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $ ) `extQ` \case #if __GLASGOW_HASKELL__ == 808 - (dL @(Pat GhcPs) -> L l@(RealSrcSpan spLoc) pat :: Located (Pat GhcPs)) + (dL @(Pat GhcPs) -> L l@(RealSrcSpan spLoc _) pat :: Located (Pat GhcPs)) #else - (L l@(RealSrcSpan spLoc) pat :: LPat GhcPs) + (L l@(RealSrcSpan spLoc _) pat :: LPat GhcPs) #endif - | RealSrcSpan spn `isSubspanOf` l -> + | RealSrcSpan spn Nothing `isSubspanOf` l -> case pat of SplicePat{} -> Here (spLoc, Pat) _ -> Continue _ -> Stop `extQ` \case - (L l@(RealSrcSpan spLoc) ty :: LHsType GhcPs) - | RealSrcSpan spn `isSubspanOf` l -> + (L l@(RealSrcSpan spLoc _) ty :: LHsType GhcPs) + | RealSrcSpan spn Nothing `isSubspanOf` l -> case ty of HsSpliceTy {} -> Here (spLoc, HsType) _ -> Continue _ -> Stop `extQ` \case - (L l@(RealSrcSpan spLoc) decl :: LHsDecl GhcPs) - | RealSrcSpan spn `isSubspanOf` l -> + (L l@(RealSrcSpan spLoc _) decl :: LHsDecl GhcPs) + | RealSrcSpan spn Nothing `isSubspanOf` l -> case decl of SpliceD {} -> Here (spLoc, HsDecl) _ -> Continue diff --git a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs index 9082c2b634..071341b36b 100644 --- a/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs +++ b/plugins/hls-stylish-haskell-plugin/src/Ide/Plugin/StylishHaskell.hs @@ -9,9 +9,8 @@ import Control.Monad.IO.Class import Data.Text (Text) import qualified Data.Text as T import Development.IDE hiding (pluginHandlers) -import Development.IDE.GHC.Compat (ModSummary (ms_hspp_opts)) -import qualified DynFlags as D -import qualified EnumSet as ES +import Development.IDE.GHC.Compat (ModSummary (ms_hspp_opts), extensionFlags) +import qualified Development.IDE.GHC.Compat.Util as Util import GHC.LanguageExtensions.Type import Ide.PluginUtils import Ide.Types @@ -52,7 +51,7 @@ provider ide typ contents fp _opts = do | otherwise = pure config - getExtensions = map showExtension . ES.toList . D.extensionFlags + getExtensions = map showExtension . Util.toList . extensionFlags showExtension Cpp = "CPP" showExtension other = show other diff --git a/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/TacticActions.hs b/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/TacticActions.hs index 89769ae8aa..c993f60a6c 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/TacticActions.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/AbstractLSP/TacticActions.hs @@ -16,8 +16,6 @@ import Development.IDE.Core.UseStale import Development.IDE.GHC.Compat import Development.IDE.GHC.ExactPrint import Generics.SYB.GHC (mkBindListT, everywhereM') -import GhcPlugins (occName) -import System.Timeout (timeout) import Wingman.AbstractLSP.Types import Wingman.CaseSplit import Wingman.GHC (liftMaybe, isHole, pattern AMatch, unXPat) @@ -76,7 +74,7 @@ makeTacticInteraction cmd = $ addTimeoutMessage rtr $ pure $ GraftEdit - $ graftHole (RealSrcSpan $ unTrack pm_span) rtr + $ graftHole (RealSrcSpan (unTrack pm_span) Nothing) rtr addTimeoutMessage :: RunTacticResults -> [ContinuationResult] -> [ContinuationResult] diff --git a/plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs b/plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs index e93af82e50..180229cf02 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/CaseSplit.hs @@ -12,7 +12,6 @@ import qualified Data.Set as S import Development.IDE.GHC.Compat import GHC.Exts (IsString (fromString)) import GHC.SourceGen (funBindsWithFixity, match, wildP) -import OccName import Wingman.GHC import Wingman.Types diff --git a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs index 07b112e01a..5f2f86605c 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/CodeGen.hs @@ -10,7 +10,6 @@ module Wingman.CodeGen ) where -import ConLike import Control.Lens ((%~), (<>~), (&)) import Control.Monad.Except import Control.Monad.Reader (ask) @@ -22,7 +21,6 @@ import Data.Generics.Labels () import Data.List import qualified Data.Set as S import Data.Traversable -import DataCon import Development.IDE.GHC.Compat import GHC.Exts import GHC.SourceGen (occNameToStr) @@ -30,11 +28,6 @@ import GHC.SourceGen.Binds import GHC.SourceGen.Expr import GHC.SourceGen.Overloaded import GHC.SourceGen.Pat -import GhcPlugins (isSymOcc, mkVarOccFS) -import OccName (occName) -import PatSyn -import Type hiding (Var) -import TysPrim (alphaTy) import Wingman.CodeGen.Utils import Wingman.GHC import Wingman.Judgements @@ -202,7 +195,7 @@ conLikeInstOrigArgTys' con uniTys = conLikeExTys :: ConLike -> [TyCoVar] -conLikeExTys (RealDataCon d) = dataConExTys d +conLikeExTys (RealDataCon d) = dataConExTyCoVars d conLikeExTys (PatSynCon p) = patSynExTys p patSynExTys :: PatSyn -> [TyCoVar] diff --git a/plugins/hls-tactics-plugin/src/Wingman/CodeGen/Utils.hs b/plugins/hls-tactics-plugin/src/Wingman/CodeGen/Utils.hs index 1f1738dacc..d683db9ffd 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/CodeGen/Utils.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/CodeGen/Utils.hs @@ -1,14 +1,10 @@ module Wingman.CodeGen.Utils where -import ConLike (ConLike(RealDataCon), conLikeName) +import Data.String import Data.List -import DataCon import Development.IDE.GHC.Compat -import GHC.Exts import GHC.SourceGen (RdrNameStr (UnqualStr), recordConE, string) -import GHC.SourceGen.Overloaded -import GhcPlugins (nilDataCon, charTy, eqType) -import Name +import GHC.SourceGen.Overloaded as SourceGen import Wingman.GHC (getRecordFields) @@ -48,7 +44,7 @@ coerceName = UnqualStr . fromString . occNameString . occName ------------------------------------------------------------------------------ -- | Like 'var', but works over standard GHC 'OccName's. -var' :: Var a => OccName -> a +var' :: SourceGen.Var a => OccName -> a var' = var . fromString . occNameString diff --git a/plugins/hls-tactics-plugin/src/Wingman/Context.hs b/plugins/hls-tactics-plugin/src/Wingman/Context.hs index 0cfd6488d6..9aea0bf5eb 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Context.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Context.hs @@ -1,6 +1,5 @@ module Wingman.Context where -import Bag import Control.Arrow import Control.Monad.Reader import Data.Coerce (coerce) @@ -8,12 +7,7 @@ import Data.Foldable.Extra (allM) import Data.Maybe (fromMaybe, isJust, mapMaybe) import qualified Data.Set as S import Development.IDE.GHC.Compat -import GhcPlugins (ExternalPackageState (eps_inst_env), piResultTys, eps_fam_inst_env, extractModule) -import InstEnv (lookupInstEnv, InstEnvs(..), is_dfun) -import OccName -import TcRnTypes -import TcType (tcSplitTyConApp, tcSplitPhiTy) -import TysPrim (alphaTys) +import Development.IDE.GHC.Compat.Util import Wingman.GHC (normalizeType) import Wingman.Judgements.Theta import Wingman.Types diff --git a/plugins/hls-tactics-plugin/src/Wingman/Debug.hs b/plugins/hls-tactics-plugin/src/Wingman/Debug.hs index 7db728b9ab..1c5e0f5517 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Debug.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Debug.hs @@ -17,19 +17,9 @@ module Wingman.Debug import Control.DeepSeq import Control.Exception import Debug.Trace -import DynFlags (unsafeGlobalDynFlags) -import Outputable hiding ((<>)) +import Development.IDE.GHC.Compat (PlainGhcException, Outputable(..), SDoc, showSDocUnsafe) import System.IO.Unsafe (unsafePerformIO) -#if __GLASGOW_HASKELL__ >= 808 -import PlainPanic (PlainGhcException) -type GHC_EXCEPTION = PlainGhcException -#else -import Panic (GhcException) -type GHC_EXCEPTION = GhcException -#endif - - ------------------------------------------------------------------------------ -- | Print something unsafeRender :: Outputable a => a -> String @@ -38,10 +28,10 @@ unsafeRender = unsafeRender' . ppr unsafeRender' :: SDoc -> String unsafeRender' sdoc = unsafePerformIO $ do - let z = showSDoc unsafeGlobalDynFlags sdoc + let z = showSDocUnsafe sdoc -- We might not have unsafeGlobalDynFlags (like during testing), in which -- case GHC panics. Instead of crashing, let's just fail to print. - !res <- try @GHC_EXCEPTION $ evaluate $ deepseq z z + !res <- try @PlainGhcException $ evaluate $ deepseq z z pure $ either (const "") id res {-# NOINLINE unsafeRender' #-} diff --git a/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs b/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs index 93deee4e3a..42c62cfc19 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs @@ -22,16 +22,13 @@ import Development.IDE (realSrcSpanToRange) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake (IdeState (..)) import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding (empty) import Development.IDE.GHC.ExactPrint import Development.IDE.Spans.LocalBindings (getLocalScope) import Ide.Types import Language.LSP.Server import Language.LSP.Types -import OccName import Prelude hiding (span) -import Prelude hiding (span) -import TcRnTypes (tcg_binds) import Wingman.AbstractLSP.Types import Wingman.CodeGen (destructionFor) import Wingman.GHC @@ -73,7 +70,7 @@ emptyCaseInteraction = Interaction $ ty edits <- liftMaybe $ hush $ mkWorkspaceEdits le_dflags ccs fc_uri (unTrack pm) $ - graftMatchGroup (RealSrcSpan $ unTrack ss) $ + graftMatchGroup (RealSrcSpan (unTrack ss) Nothing) $ noLoc matches pure ( range @@ -153,7 +150,7 @@ emptyCaseScrutinees state nfp = do True -> pure empty False -> case ss of - RealSrcSpan r -> do + RealSrcSpan r _ -> do rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r pure $ Just (rss', ty) UnhelpfulSpan _ -> empty diff --git a/plugins/hls-tactics-plugin/src/Wingman/GHC.hs b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs index 43eb2cfa6a..647d6cd60b 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/GHC.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/GHC.hs @@ -3,12 +3,8 @@ module Wingman.GHC where -import Bag (bagToList) -import Class (classTyVars) -import ConLike import Control.Monad.State import Control.Monad.Trans.Maybe (MaybeT(..)) -import CoreUtils (exprType) import Data.Bool (bool) import Data.Function (on) import Data.Functor ((<&>)) @@ -18,24 +14,10 @@ import Data.Maybe (isJust) import Data.Set (Set) import qualified Data.Set as S import Data.Traversable -import DataCon -import Development.IDE.GHC.Compat hiding (exprType) -import DsExpr (dsExpr) -import DsMonad (initDs) -import FamInst (tcLookupDataFamInst_maybe) -import FamInstEnv (normaliseType) +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util import GHC.SourceGen (lambda) import Generics.SYB (Data, everything, everywhere, listify, mkQ, mkT) -import GhcPlugins (Role (Nominal)) -import OccName -import TcRnMonad -import TcType -import TyCoRep -import Type -import TysWiredIn (charTyCon, doubleTyCon, floatTyCon, intTyCon) -import Unify -import Unique -import Var import Wingman.StaticPlugin (pattern MetaprogramSyntax) import Wingman.Types @@ -61,8 +43,8 @@ instantiateType t = do cloneTyVar :: TyVar -> TyVar cloneTyVar t = let uniq = getUnique t - some_magic_number = 49 - in setVarUnique t $ deriveUnique uniq some_magic_number + some_magic_char = 'w' -- 'w' for wingman ;D + in setVarUnique t $ newTagUnique uniq some_magic_char ------------------------------------------------------------------------------ @@ -92,7 +74,7 @@ tacticsThetaTy (tcSplitSigmaTy -> (_, theta, _)) = theta -- | Get the data cons of a type, if it has any. tacticsGetDataCons :: Type -> Maybe ([DataCon], [Type]) tacticsGetDataCons ty - | Just (_, ty') <- tcSplitForAllTy_maybe ty + | Just (_, ty') <- tcSplitForAllTyVarBinder_maybe ty = tacticsGetDataCons ty' tacticsGetDataCons ty | Just _ <- algebraicTyCon ty @@ -118,7 +100,7 @@ freshTyvars t = do case M.lookup tv reps of Just tv' -> tv' Nothing -> tv - ) $ snd $ tcSplitForAllTys t + ) $ snd $ tcSplitForAllTyVars t ------------------------------------------------------------------------------ @@ -137,7 +119,7 @@ getRecordFields dc = -- | Is this an algebraic type? algebraicTyCon :: Type -> Maybe TyCon algebraicTyCon ty - | Just (_, ty') <- tcSplitForAllTy_maybe ty + | Just (_, ty') <- tcSplitForAllTyVarBinder_maybe ty = algebraicTyCon ty' algebraicTyCon (splitTyConApp_maybe -> Just (tycon, _)) | tycon == intTyCon = Nothing @@ -322,15 +304,6 @@ pattern TopLevelRHS name ps body where_binds <- (GRHSs _ [L _ (GRHS _ [] body)] (L _ where_binds)) - -dataConExTys :: DataCon -> [TyCoVar] -#if __GLASGOW_HASKELL__ >= 808 -dataConExTys = DataCon.dataConExTyCoVars -#else -dataConExTys = DataCon.dataConExTyVars -#endif - - ------------------------------------------------------------------------------ -- | In GHC 8.8, sometimes patterns are wrapped in 'XPat'. -- The nitty gritty details are explained at @@ -354,16 +327,6 @@ liftMaybe a = MaybeT $ pure a typeCheck :: HscEnv -> TcGblEnv -> HsExpr GhcTc -> IO (Maybe Type) typeCheck hscenv tcg = fmap snd . initDs hscenv tcg . fmap exprType . dsExpr - -mkFunTys' :: [Type] -> Type -> Type -mkFunTys' = -#if __GLASGOW_HASKELL__ <= 808 - mkFunTys -#else - mkVisFunTys -#endif - - ------------------------------------------------------------------------------ -- | Expand type and data families normalizeType :: Context -> Type -> Type diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs index 21c1e609a8..1b5a88999b 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements.hs @@ -1,6 +1,5 @@ module Wingman.Judgements where -import ConLike (ConLike) import Control.Arrow import Control.Lens hiding (Context) import Data.Bool @@ -13,10 +12,8 @@ import Data.Maybe import Data.Set (Set) import qualified Data.Set as S import Development.IDE.Core.UseStale (Tracked, unTrack) +import Development.IDE.GHC.Compat hiding (isTopLevel) import Development.IDE.Spans.LocalBindings -import OccName -import SrcLoc -import Type import Wingman.GHC (algebraicTyCon, normalizeType) import Wingman.Judgements.Theta import Wingman.Types diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements/SYB.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements/SYB.hs index 0365e5e392..ba3bba4378 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Judgements/SYB.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements/SYB.hs @@ -8,8 +8,8 @@ import Data.Foldable (foldl') import Data.Generics hiding (typeRep) import qualified Data.Text as T import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util (unpackFS) import GHC.Exts (Any) -import GhcPlugins (unpackFS) import Type.Reflection import Unsafe.Coerce (unsafeCoerce) import Wingman.StaticPlugin (pattern WingmanMetaprogram) diff --git a/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs b/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs index 21b16edbc4..c2fccd4d7d 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Judgements/Theta.hs @@ -12,7 +12,6 @@ module Wingman.Judgements.Theta , allEvidenceToSubst ) where -import Class (classTyVars) import Control.Applicative (empty) import Control.Lens (preview) import Data.Coerce (coerce) @@ -21,20 +20,9 @@ import Data.Generics.Sum (_Ctor) import Data.Set (Set) import qualified Data.Set as S import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding (empty) import Generics.SYB hiding (tyConName, empty, Generic) import GHC.Generics -import GhcPlugins (mkVarOcc, splitTyConApp_maybe, getTyVar_maybe, zipTvSubst, unionTCvSubst, emptyTCvSubst, TCvSubst) -#if __GLASGOW_HASKELL__ > 806 -import GhcPlugins (eqTyCon) -#else -import GhcPlugins (nameRdrName, tyConName) -import PrelNames (eqTyCon_RDR) -#endif -import TcEvidence -import TcType (substTy) -import TcType (tcTyConAppTyCon_maybe) -import TysPrim (eqPrimTyCon) import Wingman.GHC import Wingman.Types diff --git a/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs index 5158ce4fc8..c5df1c80c1 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies.hs @@ -1,7 +1,7 @@ module Wingman.KnownStrategies where import Data.Foldable (for_) -import OccName (mkVarOcc, mkClsOcc) +import Development.IDE.GHC.Compat.Core import Refinery.Tactic import Wingman.Judgements (jGoal) import Wingman.KnownStrategies.QuickCheck (deriveArbitrary) diff --git a/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies/QuickCheck.hs b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies/QuickCheck.hs index f6013af5af..4cc1d4afb8 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies/QuickCheck.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/KnownStrategies/QuickCheck.hs @@ -1,11 +1,9 @@ module Wingman.KnownStrategies.QuickCheck where -import ConLike (ConLike(RealDataCon)) import Data.Bool (bool) import Data.Generics (everything, mkQ) import Data.List (partition) -import DataCon (DataCon, dataConName) -import Development.IDE.GHC.Compat (GhcPs, HsExpr, noLoc) +import Development.IDE.GHC.Compat import GHC.Exts (IsString (fromString)) import GHC.List (foldl') import GHC.SourceGen (int) @@ -13,10 +11,7 @@ import GHC.SourceGen.Binds (match, valBind) import GHC.SourceGen.Expr (case', lambda, let') import GHC.SourceGen.Overloaded (App ((@@)), HasList (list)) import GHC.SourceGen.Pat (conP) -import OccName (HasOccName (occName), mkVarOcc, occNameString) import Refinery.Tactic (goal, rule, failure) -import TyCon (TyCon, tyConDataCons, tyConName) -import Type (splitTyConApp_maybe) import Wingman.CodeGen import Wingman.Judgements (jGoal) import Wingman.Machinery (tracePrim) diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs index 10a09bccd9..3524194fb1 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer.hs @@ -8,7 +8,6 @@ module Wingman.LanguageServer where -import ConLike import Control.Arrow ((***)) import Control.Monad import Control.Monad.IO.Class @@ -35,16 +34,15 @@ import Development.IDE.Core.Service (runAction) import Development.IDE.Core.Shake (IdeState (..), uses, define, use) import qualified Development.IDE.Core.Shake as IDE import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat hiding (parseExpr) +import Development.IDE.GHC.Compat hiding (empty) +import qualified Development.IDE.GHC.Compat.Util as FastString import Development.IDE.GHC.Error (realSrcSpanToRange) import Development.IDE.GHC.ExactPrint import Development.IDE.Graph (Action, RuleResult, Rules, action) import Development.IDE.Graph.Classes (Binary, Hashable, NFData) import Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings) -import qualified FastString import GHC.Generics (Generic) import Generics.SYB hiding (Generic) -import GhcPlugins (tupleDataCon, consDataCon, substTyAddInScope, ExternalPackageState, HscEnv (hsc_EPS), unpackFS) import qualified Ide.Plugin.Config as Plugin import Ide.Plugin.Properties import Ide.PluginUtils (usePropertyLsp) @@ -57,11 +55,8 @@ import Language.LSP.Types hiding SemanticTokenRelative (length), SemanticTokensEdit (_start)) import Language.LSP.Types.Capabilities -import OccName import Prelude hiding (span) import Retrie (transformA) -import SrcLoc (containsSpan) -import TcRnTypes (tcg_binds, TcGblEnv) import Wingman.Context import Wingman.GHC import Wingman.Judgements @@ -183,7 +178,7 @@ getIdeDynflags state nfp = do getAllMetaprograms :: Data a => a -> [String] getAllMetaprograms = everything (<>) $ mkQ mempty $ \case - WingmanMetaprogram fs -> [ unpackFS fs ] + WingmanMetaprogram fs -> [ FastString.unpackFS fs ] (_ :: HsExpr GhcTc) -> mempty @@ -222,7 +217,7 @@ judgementForHole state nfp range cfg = do eps <- liftIO $ readIORef $ hsc_EPS $ hscEnv henv (jdg, ctx) <- liftMaybe $ mkJudgementAndContext cfg g binds new_rss tcg (hscEnv henv) eps - let mp = getMetaprogramAtSpan (fmap RealSrcSpan tcg_rss) tcg_t + let mp = getMetaprogramAtSpan (fmap (`RealSrcSpan` Nothing) tcg_rss) tcg_t dflags <- getIdeDynflags state nfp pure $ HoleJudgment @@ -261,10 +256,10 @@ mkJudgementAndContext cfg g (TrackedStale binds bmap) rss (TrackedStale tcg tcgm eps evidence top_provs = getRhsPosVals tcg_rss tcs - already_destructed = getAlreadyDestructed (fmap RealSrcSpan tcg_rss) tcs + already_destructed = getAlreadyDestructed (fmap (`RealSrcSpan` Nothing) tcg_rss) tcs local_hy = spliceProvenance top_provs $ hypothesisFromBindings binds_rss binds - evidence = getEvidenceAtHole (fmap RealSrcSpan tcg_rss) tcs + evidence = getEvidenceAtHole (fmap (`RealSrcSpan` Nothing) tcg_rss) tcs cls_hy = foldMap evidenceToHypothesis evidence subst = ts_unifier $ evidenceToSubst evidence defaultTacticState pure $ @@ -339,7 +334,7 @@ getRhsPosVals getRhsPosVals (unTrack -> rss) (unTrack -> tcs) = everything (<>) (mkQ mempty $ \case TopLevelRHS name ps - (L (RealSrcSpan span) -- body with no guards and a single defn + (L (RealSrcSpan span _) -- body with no guards and a single defn (HsVar _ (L _ hole))) _ | containsSpan rss span -- which contains our span @@ -495,7 +490,7 @@ isRhsHoleWithoutWhere isRhsHoleWithoutWhere (unTrack -> rss) (unTrack -> tcs) = everything (||) (mkQ False $ \case TopLevelRHS _ _ - (L (RealSrcSpan span) _) + (L (RealSrcSpan span _) _) (EmptyLocalBinds _) -> containsSpan rss span _ -> False ) tcs diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs index 915724f1aa..1cdee0b02d 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/Metaprogram.hs @@ -21,13 +21,10 @@ import Development.IDE (realSrcSpanToRange) import Development.IDE.Core.RuleTypes import Development.IDE.Core.Shake (IdeState (..)) import Development.IDE.Core.UseStale -import Development.IDE.GHC.Compat -import GhcPlugins (containsSpan, realSrcLocSpan, realSrcSpanStart) +import Development.IDE.GHC.Compat hiding (empty) import Ide.Types import Language.LSP.Types import Prelude hiding (span) -import Prelude hiding (span) -import TcRnTypes (tcg_binds) import Wingman.GHC import Wingman.Judgements.SYB (metaprogramQ) import Wingman.LanguageServer @@ -44,7 +41,7 @@ hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurr cfg <- getTacticConfig plId liftIO $ fromMaybeT (Right Nothing) $ do - holes <- getMetaprogramsAtSpan state nfp $ RealSrcSpan $ unTrack loc + holes <- getMetaprogramsAtSpan state nfp $ RealSrcSpan (unTrack loc) Nothing fmap (Right . Just) $ case (find (flip containsSpan (unTrack loc) . unTrack . fst) holes) of @@ -80,7 +77,7 @@ getMetaprogramsAtSpan state nfp ss = do let scrutinees = traverse (metaprogramQ ss . tcg_binds) tcg for scrutinees $ \aged@(unTrack -> (ss, program)) -> do case ss of - RealSrcSpan r -> do + RealSrcSpan r _ -> do rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r pure (rss', program) UnhelpfulSpan _ -> empty diff --git a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs index 5a0844b73c..631baf58b7 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/LanguageServer/TacticProviders.hs @@ -16,12 +16,10 @@ import Data.Maybe import Data.Monoid import qualified Data.Set as S import qualified Data.Text as T -import DataCon (dataConName) import Development.IDE.GHC.Compat import GHC.LanguageExtensions.Type (Extension (LambdaCase)) import Ide.Types import Language.LSP.Types hiding (SemanticTokenAbsolute (..), SemanticTokenRelative (..)) -import OccName import Prelude hiding (span) import Wingman.AbstractLSP.Types import Wingman.Auto diff --git a/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs b/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs index 9a369cdd0a..56fd9f7b2e 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Machinery.hs @@ -24,16 +24,12 @@ import Data.Ord (Down (..), comparing) import qualified Data.Set as S import Data.Traversable (for) import Development.IDE.Core.Compile (lookupName) -import Development.IDE.GHC.Compat -import GhcPlugins (GlobalRdrElt (gre_name), lookupOccEnv, varType) +import Development.IDE.GHC.Compat hiding (isTopLevel, empty) import Refinery.Future import Refinery.ProofState import Refinery.Tactic import Refinery.Tactic.Internal import System.Timeout (timeout) -import TcType -import Type (tyCoVarsOfTypeWellScoped) -import TysPrim (alphaTyVar, alphaTy) import Wingman.Context (getInstance) import Wingman.GHC (tryUnifyUnivarsButNotSkolems, updateSubst, tacticsGetDataCons, freshTyvars) import Wingman.Judgements @@ -235,7 +231,7 @@ newtype Reward a = Reward a newUnivar :: MonadState TacticState m => m Type newUnivar = do freshTyvars $ - mkInvForAllTys [alphaTyVar] alphaTy + mkInfForAllTys [alphaTyVar] alphaTy ------------------------------------------------------------------------------ diff --git a/plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Lexer.hs b/plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Lexer.hs index 2c15cee171..a9bdb694d1 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Lexer.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Lexer.hs @@ -11,7 +11,7 @@ import Data.Foldable (asum) import Data.Text (Text) import qualified Data.Text as T import Data.Void -import Name +import Development.IDE.GHC.Compat.Core (OccName, mkVarOcc) import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P import qualified Text.Megaparsec.Char.Lexer as L diff --git a/plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Parser.hs b/plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Parser.hs index c16b9dca70..96c93da2d1 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Parser.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Parser.hs @@ -11,7 +11,7 @@ import Data.Functor import Data.Maybe (listToMaybe) import qualified Data.Text as T import Development.IDE.GHC.Compat (RealSrcLoc, srcLocLine, srcLocCol, srcLocFile) -import FastString (unpackFS) +import Development.IDE.GHC.Compat.Util (unpackFS) import Refinery.Tactic (failure) import qualified Refinery.Tactic as R import qualified Text.Megaparsec as P diff --git a/plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Parser/Documentation.hs b/plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Parser/Documentation.hs index b63dea6f08..7b047513f8 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Parser/Documentation.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Metaprogramming/Parser/Documentation.hs @@ -8,7 +8,7 @@ import Data.String (IsString) import Data.Text (Text) import Data.Text.Prettyprint.Doc hiding (parens) import Data.Text.Prettyprint.Doc.Render.String (renderString) -import GhcPlugins (OccName) +import Development.IDE.GHC.Compat (OccName) import qualified Text.Megaparsec as P import Wingman.Metaprogramming.Lexer (Parser, identifier, variable, parens) import Wingman.Types (TacticsM) diff --git a/plugins/hls-tactics-plugin/src/Wingman/Naming.hs b/plugins/hls-tactics-plugin/src/Wingman/Naming.hs index 51416ecd21..05f5c2b85a 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Naming.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Naming.hs @@ -14,13 +14,8 @@ import Data.Monoid import Data.Set (Set) import qualified Data.Set as S import Data.Traversable -import GhcPlugins (charTy, maybeTyCon) -import Name -import TcType +import Development.IDE.GHC.Compat.Core hiding (IsFunction) import Text.Hyphenation (hyphenate, english_US) -import TyCon -import Type -import TysWiredIn (listTyCon, unitTyCon) import Wingman.GHC (tcTyVar_maybe) diff --git a/plugins/hls-tactics-plugin/src/Wingman/Range.hs b/plugins/hls-tactics-plugin/src/Wingman/Range.hs index fed5729996..b7ae845663 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Range.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Range.hs @@ -4,15 +4,16 @@ module Wingman.Range where import Development.IDE hiding (rangeToRealSrcSpan, rangeToSrcSpan) -import qualified FastString as FS -import SrcLoc +import Development.IDE.GHC.Compat.Core +import Development.IDE.GHC.Compat.Util as FS + ------------------------------------------------------------------------------ -- | Convert a DAML compiler Range to a GHC SrcSpan -- TODO(sandy): this doesn't belong here rangeToSrcSpan :: String -> Range -> SrcSpan -rangeToSrcSpan file range = RealSrcSpan $ rangeToRealSrcSpan file range +rangeToSrcSpan file range = RealSrcSpan (rangeToRealSrcSpan file range) Nothing rangeToRealSrcSpan :: String -> Range -> RealSrcSpan diff --git a/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs b/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs index 635fa463a5..441c0ae329 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/StaticPlugin.hs @@ -9,12 +9,11 @@ module Wingman.StaticPlugin import Data.Data import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat.Util import GHC.LanguageExtensions.Type (Extension(EmptyCase, QuasiQuotes)) import Generics.SYB -import GhcPlugins hiding ((<>)) import Ide.Types - staticPlugin :: DynFlagsModifications staticPlugin = mempty { dynFlagsModifyGlobal = @@ -41,9 +40,15 @@ pattern MetaprogramSourceText = SourceText "wingman-meta-program" pattern WingmanMetaprogram :: FastString -> HsExpr p -pattern WingmanMetaprogram mp - <- HsSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp) +pattern WingmanMetaprogram mp <- +#if __GLASGOW_HASKELL__ >= 900 + HsPragE _ (HsPragSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp)) + (L _ ( HsVar _ _)) +#else + HsSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp) (L _ ( HsVar _ _)) +#endif + enableQuasiQuotes :: DynFlags -> DynFlags @@ -63,7 +68,7 @@ metaprogrammingPlugin :: StaticPlugin metaprogrammingPlugin = StaticPlugin $ PluginWithArgs (defaultPlugin { parsedResultAction = worker }) [] where - worker :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule + worker :: Monad m => [CommandLineOption] -> ModSummary -> HsParsedModule -> m HsParsedModule worker _ _ pm = pure $ pm { hpm_module = addMetaprogrammingSyntax $ hpm_module pm } #endif @@ -73,7 +78,11 @@ metaprogramHoleName = mkVarOcc "_$metaprogram" mkMetaprogram :: SrcSpan -> FastString -> HsExpr GhcPs mkMetaprogram ss mp = +#if __GLASGOW_HASKELL__ >= 900 + HsPragE noExtField (HsPragSCC noExtField MetaprogramSourceText (StringLiteral NoSourceText mp)) +#else HsSCC noExtField MetaprogramSourceText (StringLiteral NoSourceText mp) +#endif $ L ss $ HsVar noExtField $ L ss diff --git a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs index 7971ca4671..d6909a11ca 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Tactics.hs @@ -6,7 +6,6 @@ module Wingman.Tactics , runTactic ) where -import ConLike (ConLike(RealDataCon)) import Control.Applicative (Alternative(empty), (<|>)) import Control.Lens ((&), (%~), (<>~)) import Control.Monad (filterM) @@ -26,16 +25,12 @@ import Data.Set (Set) import qualified Data.Set as S import Data.Traversable (for) import DataCon -import Development.IDE.GHC.Compat +import Development.IDE.GHC.Compat hiding (empty) import GHC.Exts import GHC.SourceGen ((@@)) import GHC.SourceGen.Expr -import Name (occNameString, occName) -import OccName (mkVarOcc) import Refinery.Tactic import Refinery.Tactic.Internal -import TcType -import Type hiding (Var) import Wingman.CodeGen import Wingman.GHC import Wingman.Judgements @@ -150,7 +145,7 @@ intros' params = rule $ \jdg -> do bound_occs = fmap fst bindings hy' = lambdaHypothesis top_hole bindings jdg' = introduce ctx hy' - $ withNewGoal (CType $ mkFunTys' (drop num_occs args) res) jdg + $ withNewGoal (CType $ mkVisFunTys (drop num_occs args) res) jdg ext <- newSubgoal jdg' pure $ ext @@ -289,7 +284,7 @@ apply (Unsaturated n) hi = tracing ("apply' " <> show (hi_name hi)) $ do saturated_args = dropEnd n all_args unsaturated_args = takeEnd n all_args rule $ \jdg -> do - unify g (CType $ mkFunTys' unsaturated_args ret) + unify g (CType $ mkVisFunTys unsaturated_args ret) ext <- fmap unzipTrace $ traverse ( newSubgoal @@ -545,7 +540,7 @@ nary :: Int -> TacticsM () nary n = do a <- newUnivar b <- newUnivar - applyByType $ mkFunTys' (replicate n a) b + applyByType $ mkVisFunTys (replicate n a) b self :: TacticsM () @@ -630,7 +625,7 @@ with_arg = rule $ \jdg -> do let g = jGoal jdg fresh_ty <- newUnivar a <- newSubgoal $ withNewGoal (CType fresh_ty) jdg - f <- newSubgoal $ withNewGoal (coerce mkFunTys' [fresh_ty] g) jdg + f <- newSubgoal $ withNewGoal (coerce mkVisFunTys [fresh_ty] g) jdg pure $ fmap noLoc $ (@@) <$> fmap unLoc f <*> fmap unLoc a diff --git a/plugins/hls-tactics-plugin/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/src/Wingman/Types.hs index 491ff9724a..63c30a82ae 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Types.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Types.hs @@ -14,7 +14,6 @@ module Wingman.Types , Span ) where -import ConLike (ConLike) import Control.Lens hiding (Context) import Control.Monad.Reader import Control.Monad.State @@ -33,23 +32,17 @@ import Data.Tree import Development.IDE (Range) import Development.IDE.Core.UseStale import Development.IDE.GHC.Compat hiding (Node) +import qualified Development.IDE.GHC.Compat.Util as Util import Development.IDE.GHC.Orphans () -import FamInstEnv (FamInstEnvs) import GHC.Exts (fromString) import GHC.Generics import GHC.SourceGen (var) -import GhcPlugins (GlobalRdrElt, mkRdrUnqual) -import InstEnv (InstEnvs(..)) -import OccName import Refinery.ProofState import Refinery.Tactic import Refinery.Tactic.Internal (TacticT(TacticT), RuleT (RuleT)) import System.IO.Unsafe (unsafePerformIO) -import Type (TCvSubst, Var, eqType, nonDetCmpType, emptyTCvSubst) -import UniqSupply (takeUniqFromSupply, mkSplitUniqSupply, UniqSupply) -import Unique (nonDetCmpUnique, Uniquable, getUnique, Unique, mkUnique) import Wingman.Debug -import Data.IORef +import Data.IORef ------------------------------------------------------------------------------ @@ -199,7 +192,7 @@ defaultTacticState = ------------------------------------------------------------------------------ -- | Generate a new 'Unique' -freshUnique :: MonadState TacticState m => m Unique +freshUnique :: MonadState TacticState m => m Util.Unique freshUnique = do (uniq, supply) <- gets $ takeUniqFromSupply . ts_unique_gen modify' $! field @"ts_unique_gen" .~ supply @@ -269,11 +262,11 @@ newtype Uniquely a = Uniquely { getViaUnique :: a } deriving Show via a deriving stock (Data, Typeable) -instance Uniquable a => Eq (Uniquely a) where - (==) = (==) `on` getUnique . getViaUnique +instance Util.Uniquable a => Eq (Uniquely a) where + (==) = (==) `on` Util.getUnique . getViaUnique -instance Uniquable a => Ord (Uniquely a) where - compare = nonDetCmpUnique `on` getUnique . getViaUnique +instance Util.Uniquable a => Ord (Uniquely a) where + compare = Util.nonDetCmpUnique `on` Util.getUnique . getViaUnique -- NOTE(sandy): The usage of list here is mostly for convenience, but if it's @@ -349,7 +342,7 @@ instance MonadReader r m => MonadReader r (RuleT jdg ext err s m) where local f (RuleT m) = RuleT $ Effect $ local f $ pure m mkMetaHoleName :: Int -> RdrName -mkMetaHoleName u = mkRdrUnqual $ mkVarOcc $ "_" <> show (mkUnique 'w' u) +mkMetaHoleName u = mkRdrUnqual $ mkVarOcc $ "_" <> show (Util.mkUnique 'w' u) instance MetaSubst Int (Synthesized (LHsExpr GhcPs)) where -- TODO(sandy): This join is to combine the synthesizeds diff --git a/stack-8.10.2.yaml b/stack-8.10.2.yaml index 13663cba29..085909f607 100644 --- a/stack-8.10.2.yaml +++ b/stack-8.10.2.yaml @@ -38,7 +38,6 @@ 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 @@ -57,7 +56,7 @@ extra-deps: - temporary-1.2.1.1 - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - - hiedb-0.4.0.0 + - hiedb-0.4.1.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 diff --git a/stack-8.10.3.yaml b/stack-8.10.3.yaml index a24c3512d3..8ce1cce932 100644 --- a/stack-8.10.3.yaml +++ b/stack-8.10.3.yaml @@ -38,7 +38,6 @@ 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 @@ -57,7 +56,7 @@ extra-deps: - temporary-1.2.1.1 - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - - hiedb-0.4.0.0 + - hiedb-0.4.1.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 diff --git a/stack-8.10.4.yaml b/stack-8.10.4.yaml index f00ff4d014..82f9d4dc33 100644 --- a/stack-8.10.4.yaml +++ b/stack-8.10.4.yaml @@ -38,7 +38,6 @@ 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-source-gen-0.4.1.0 @@ -53,7 +52,7 @@ extra-deps: - temporary-1.2.1.1 - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - - hiedb-0.4.0.0 + - hiedb-0.4.1.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 diff --git a/stack-8.10.5.yaml b/stack-8.10.5.yaml index b97fc70e81..f94d4f74ef 100644 --- a/stack-8.10.5.yaml +++ b/stack-8.10.5.yaml @@ -41,7 +41,6 @@ extra-deps: - data-tree-print-0.1.0.2@rev:2 - floskell-0.10.5 - fourmolu-0.3.0.0 - - ghc-api-compat-8.10.5 - ghc-check-0.5.0.4 - ghc-exactprint-0.6.4 - ghc-source-gen-0.4.1.0 @@ -58,7 +57,7 @@ extra-deps: - temporary-1.2.1.1 - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - - hiedb-0.4.0.0 + - hiedb-0.4.1.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682 diff --git a/stack-8.10.6.yaml b/stack-8.10.6.yaml index 2675a9bbdc..41bedc7cb9 100644 --- a/stack-8.10.6.yaml +++ b/stack-8.10.6.yaml @@ -35,9 +35,8 @@ extra-deps: - bytestring-encoding-0.1.1.0@sha256:1c3b97eb6345fd7153006211c8272215cd78bb0cf440c41185290822f1e3f2c2,1738 - data-tree-print-0.1.0.2@sha256:d845e99f322df70e0c06d6743bf80336f5918d5423498528beb0593a2afc1703,1620 - floskell-0.10.5@sha256:77f0bc1569573d9666b10975a5357fef631d32266c071733739393ccae521dab,3803 - - ghc-api-compat-8.10.6@sha256:cde370b1b4c8a090de1ba6a8e27f65def9af43ca88710b412a6545b876568626,3324 - heapsize-0.3.0.1@sha256:0b69aa97a46d819b700ac7b145f3b5493c3565cf2c5b8298682238d405d0326e,1417 - - hiedb-0.4.0.0@sha256:b6dadd5cefc8c1052bc4b29144f616ca9c22e863a96d8e447d66a4d32c96fd4a,2987 + - hiedb-0.4.1.0 - implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998 - implicit-hie-cradle-0.3.0.5@sha256:5f5e575f549b2a9db664be7650b5c3c9226e313bddc46c79e2e83eb349f8e692,2610 - lsp-1.2.0.1@sha256:5b37d26fcbf037434e257e953c08513d4cb125ed784d4611038905c72dc0f58c,5431 diff --git a/stack-8.10.7.yaml b/stack-8.10.7.yaml index 3959b71d80..fbaf2d380e 100644 --- a/stack-8.10.7.yaml +++ b/stack-8.10.7.yaml @@ -35,9 +35,8 @@ extra-deps: - bytestring-encoding-0.1.1.0@sha256:1c3b97eb6345fd7153006211c8272215cd78bb0cf440c41185290822f1e3f2c2,1738 - data-tree-print-0.1.0.2@sha256:d845e99f322df70e0c06d6743bf80336f5918d5423498528beb0593a2afc1703,1620 - floskell-0.10.5@sha256:77f0bc1569573d9666b10975a5357fef631d32266c071733739393ccae521dab,3803 - - ghc-api-compat-8.10.7 - heapsize-0.3.0.1@sha256:0b69aa97a46d819b700ac7b145f3b5493c3565cf2c5b8298682238d405d0326e,1417 - - hiedb-0.4.0.0@sha256:b6dadd5cefc8c1052bc4b29144f616ca9c22e863a96d8e447d66a4d32c96fd4a,2987 + - hiedb-0.4.1.0 - implicit-hie-0.1.2.6@sha256:f50a908979a574a881f753c0f9a5224f023f438b30fdefc5b7fa01803b07a280,2998 - implicit-hie-cradle-0.3.0.5@sha256:5f5e575f549b2a9db664be7650b5c3c9226e313bddc46c79e2e83eb349f8e692,2610 - lsp-1.2.0.1@sha256:5b37d26fcbf037434e257e953c08513d4cb125ed784d4611038905c72dc0f58c,5431 diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 82c9b6628b..5329bef27f 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -45,7 +45,6 @@ extra-deps: - floskell-0.10.4 - fourmolu-0.3.0.0 - fuzzy-0.1.0.0 - - ghc-api-compat-8.6 - ghc-check-0.5.0.4 - ghc-events-0.13.0 - ghc-exactprint-0.6.4 @@ -92,7 +91,7 @@ extra-deps: - 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.4.0.0 + - hiedb-0.4.1.0 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 51d4473532..cb42915a43 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -46,7 +46,6 @@ extra-deps: - floskell-0.10.4 - fourmolu-0.3.0.0 - fuzzy-0.1.0.0 - - ghc-api-compat-8.6 - ghc-check-0.5.0.4 - ghc-events-0.13.0 - ghc-exactprint-0.6.4 @@ -93,7 +92,7 @@ extra-deps: - 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.4.0.0 + - hiedb-0.4.1.0 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 diff --git a/stack-8.8.3.yaml b/stack-8.8.3.yaml index e1fc082b96..42a23df0c4 100644 --- a/stack-8.8.3.yaml +++ b/stack-8.8.3.yaml @@ -40,7 +40,6 @@ 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 @@ -71,7 +70,7 @@ extra-deps: - uniplate-1.6.13 - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - - hiedb-0.4.0.0 + - hiedb-0.4.1.0 - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 - extra-1.7.9@sha256:f1dec740f0f2025790c540732bfd52c556ec55bde4f5dfd7cf18e22bd44ff3d0,2683 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml index 3742c83f56..444168f8ce 100644 --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -40,7 +40,6 @@ 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 @@ -69,7 +68,7 @@ extra-deps: - temporary-1.2.1.1 - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - - hiedb-0.4.0.0 + - hiedb-0.4.1.0 - sqlite-simple-0.4.18.0@sha256:3ceea56375c0a3590c814e411a4eb86943f8d31b93b110ca159c90689b6b39e5,3002 - direct-sqlite-2.3.26@sha256:04e835402f1508abca383182023e4e2b9b86297b8533afbd4e57d1a5652e0c23,3718 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml index 5e71865dac..010e96af4a 100644 --- a/stack-9.0.1.yaml +++ b/stack-9.0.1.yaml @@ -13,11 +13,11 @@ packages: - ./plugins/hls-haddock-comments-plugin - ./plugins/hls-eval-plugin - ./plugins/hls-explicit-imports-plugin - # - ./plugins/hls-refine-imports-plugin + - ./plugins/hls-refine-imports-plugin - ./plugins/hls-hlint-plugin - ./plugins/hls-rename-plugin - ./plugins/hls-retrie-plugin - # - ./plugins/hls-splice-plugin + - ./plugins/hls-splice-plugin # - ./plugins/hls-tactics-plugin # - ./plugins/hls-brittany-plugin # - ./plugins/hls-stylish-haskell-plugin @@ -37,11 +37,10 @@ extra-deps: - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:0e419237f5b86da3659772afff9cab355c0f8d5b3fdb15a5b30e673d8dc83941,2147 - floskell-0.10.5 -- ghc-api-compat-9.0.1 - ghc-source-gen-0.4.1.0 - heapsize-0.3.0.1@sha256:0b69aa97a46d819b700ac7b145f3b5493c3565cf2c5b8298682238d405d0326e,1417 - hie-bios-0.7.6 -- hiedb-0.4.0.0 +- hiedb-0.4.1.0 - hspec-2.7.10 - hspec-core-2.7.10 - hspec-discover-2.7.10 @@ -104,8 +103,6 @@ flags: pedantic: true class: false - splice: false - refineImports: false tactic: false # Dependencies fail fourmolu: false diff --git a/stack.yaml b/stack.yaml index 67e3104e9f..7c78883d27 100644 --- a/stack.yaml +++ b/stack.yaml @@ -38,7 +38,6 @@ 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 - ghc-source-gen-0.4.1.0 - heapsize-0.3.0 @@ -52,7 +51,7 @@ extra-deps: - temporary-1.2.1.1 - th-compat-0.1.2@sha256:3d55de1adc542c1a870c9ada90da2fbbe5f4e8bcd3eed545a55c3df9311b32a8,2854 - bytestring-encoding-0.1.0.0@sha256:460b49779fbf0112e8e2f1753c1ed9131eb18827600c298f4d6bb51c4e8c1c0d,1727 - - hiedb-0.4.0.0 + - hiedb-0.4.1.0 - dependent-map-0.4.0.0@sha256:ca2b131046f4340a1c35d138c5a003fe4a5be96b14efc26291ed35fd08c62221,1657 - dependent-sum-0.7.1.0@sha256:5599aa89637db434431b1dd3fa7c34bc3d565ee44f0519bfbc877be1927c2531,2068 - dependent-sum-template-0.1.0.3@sha256:0bbbacdfbd3abf2a15aaf0cf2c27e5bdd159b519441fec39e1e6f2f54424adde,1682